From 2f12a917b9f156e012c9dd6cae382bdc36fae7c7 Mon Sep 17 00:00:00 2001
From: Lia Lenckowski <lialenck@protonmail.com>
Date: Tue, 29 Aug 2023 00:01:45 +0200
Subject: pending bang verdict notifications

---
 src/Config.hs | 26 ++++++++++++++++++++++----
 src/Main.hs   | 19 +++++++++++++++++--
 2 files changed, 39 insertions(+), 6 deletions(-)

(limited to 'src')

diff --git a/src/Config.hs b/src/Config.hs
index 071cc26..2b2f341 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -1,22 +1,27 @@
-{-# LANGUAGE OverloadedStrings, LambdaCase #-}
+{-# LANGUAGE OverloadedStrings, LambdaCase, TemplateHaskell #-}
 
 module Config (
     Config(..),
     getConfig,
-    makeOpenSearch
+    makeOpenSearch,
+    sendEmail
 ) where
 
 import Prelude hiding (lookup)
 
 import Control.Applicative ((<|>))
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Logger (MonadLogger, logInfo, logWarn, logError)
 import Data.Aeson.KeyMap (empty, lookup)
 import Data.Functor ((<&>))
 import Data.Maybe (fromMaybe)
 import Data.String (fromString, IsString)
-import Data.Text (Text)
+import Data.Text (Text, pack)
 import Data.Yaml
 import Network.Wai.Handler.Warp (HostPreference)
 import System.Environment (lookupEnv)
+import System.Exit (ExitCode(..))
+import System.Process (proc, createProcess, waitForProcess)
 
 data Config = Config {
     confPort :: Int,
@@ -24,7 +29,8 @@ data Config = Config {
     confBaseUrl :: Text,
     confFavicon :: Text,
     confUser :: Text,
-    confPwHash :: Text
+    confPwHash :: Text,
+    confEmailCmd :: Maybe FilePath
 } deriving (Show, Eq)
 
 getConfig :: IO Config
@@ -40,6 +46,7 @@ getConfig = do
         <*> resolveVal (lookup "favicon-url"   confFile) "FAVICON_URL"   ""
         <*> resolveVal (lookup "admin-user"    confFile) "ADMIN_USER"    "bleb"
         <*> resolveVal (lookup "admin-pw-hash" confFile) "ADMIN_PW_HASH" "" -- prevent login without manual pw
+        <*> fmap (<|> lookup "email-command" confFile) (lookupEnv "EMAIL_CMD")
 
   where resolveVal :: IsString s => Maybe String -> String -> String -> IO s
         resolveVal mayConf q def = do
@@ -60,3 +67,14 @@ makeOpenSearch cfg defBang =
   where (searchUrl, name) = case defBang of
             Nothing -> (confBaseUrl cfg <> "/#{searchTerms}", "FastBangs")
             Just b  -> (confBaseUrl cfg <> "/#" <> b <> "#{searchTerms}", "FastBangs (" <> b <> ")")
+
+sendEmail :: (MonadLogger m, MonadIO m) => Config -> String -> String -> String -> m ()
+sendEmail cfg to subject body = case confEmailCmd cfg of
+    Nothing -> do
+        $(logWarn) $ "Would've send email to " <> pack (show to) <> ", but no command was configured"
+    Just cmd -> do
+        (_, _, _, ph) <- liftIO $ createProcess $ proc cmd [to, subject, body]
+        exitCode <- liftIO $ waitForProcess ph
+        case exitCode of
+            ExitSuccess -> $(logInfo)  $ "Sent email to " <> pack (show to)
+            ExitFailure i -> $(logError) $ "Sending email returned " <> pack (show i)
diff --git a/src/Main.hs b/src/Main.hs
index 049e709..91da385 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -9,6 +9,7 @@ import Control.Monad.Logger (runStdoutLoggingT)
 import Control.Monad.Trans.Resource (runResourceT)
 import Control.Monad (when, unless)
 import Database.Persist.Sqlite
+import Data.Bool (bool)
 import Data.Function ((&))
 import Network.Wai.Handler.Warp hiding (getPort, getHost)
 import Yesod
@@ -98,7 +99,8 @@ getOpenSearchR = do
 
 postVerdictR :: Bool -> Handler ()
 postVerdictR b = do
-    ensureAuth . config =<< getYesod
+    cfg <- config <$> getYesod
+    ensureAuth cfg
 
     (PendingBang n u dp mayEm) <- requireCheckJsonBody
     -- NOTE: known race condition: the bang bang may be deleted from the database
@@ -106,8 +108,21 @@ postVerdictR b = do
     -- a pending bang on very specific crash timing.
     st <- bangState <$> getYesod
     when b $ liftIO $ addBang n u dp st
-    --sendEmail mayEm $ "your bang was " <> bool b "rejected" "accepted" -- TODO
     runDB $ deleteWhere [PendingBangBang ==. n]
+
+    case mayEm of
+        Nothing -> return ()
+        Just em -> do
+            let e = T.unpack em
+            sendEmail cfg e ("Your bang was " <> bool "rejected" "accepted!" b) $
+                "Hello,\n" <>
+                "\n" <>
+                "We're " <> bool "sorry" "happy" b <> " to announce that your" <>
+                " submitted bang \"" <> T.unpack dp <> "\" (\"!" <> T.unpack n <>
+                "\", leading to " <> T.unpack u <> ") has been " <>
+                bool "rejected" "accepted" b <>
+                " by an administrator. Good look with your future banging!\n"
+
     return ()
 
 postAcceptR, postRejectR :: Handler ()
-- 
cgit v1.2.3-70-g09d2