diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Config.hs | 26 | ||||
| -rw-r--r-- | src/Main.hs | 19 |
2 files changed, 39 insertions, 6 deletions
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 () |