diff options
| -rw-r--r-- | README.md | 1 | ||||
| -rw-r--r-- | fastbangs.cabal | 1 | ||||
| -rw-r--r-- | fastbangs.yaml | 5 | ||||
| -rw-r--r-- | package.yaml | 1 | ||||
| -rw-r--r-- | src/Config.hs | 26 | ||||
| -rw-r--r-- | src/Main.hs | 19 |
6 files changed, 47 insertions, 6 deletions
@@ -21,6 +21,7 @@ If you go with environment variables, the following options are available: - BASE\_URL: url of the deployed website, without trailing slash. Default: "http://localhost:20546" - ADMIN\_USER: username for logging into the interface for accepting/rejecting bangs. Default: "bleb" - ADMIN\_PW\_HASH: hash of the passwort used for logging in. Default: "" +- EMAIL\_CMD: path to an executable for sending emails. Will be called with the recipient, subject and body as command-line arguments. Default: "" On the password hash: The default setting makes it impossible to log in, forcing you to set your own. You DON'T NEED TO DO THIS if you don't plan on adding custom bangs. The format is the sha512 hash of the password, converted to base64. diff --git a/fastbangs.cabal b/fastbangs.cabal index 689548e..32d2a26 100644 --- a/fastbangs.cabal +++ b/fastbangs.cabal @@ -41,6 +41,7 @@ executable fastbangs , monad-logger , persistent , persistent-sqlite + , process , resourcet , stm , text diff --git a/fastbangs.yaml b/fastbangs.yaml index 0151744..d184bae 100644 --- a/fastbangs.yaml +++ b/fastbangs.yaml @@ -16,3 +16,8 @@ favicon-url: http://69owo.de/favicon.ico # for help with the admin-pw-hash please read the README.md admin-user: bleb admin-pw-hash: "" + +# Users can leave their email in order to be notified when their bang is +# accepted/rejected. In order to send emails, the following command (if not +# commented out) will receive as arguments, in order: recipient, subject, body +#email-command: "/path/to/your/email/script" diff --git a/package.yaml b/package.yaml index 382537c..e3287e7 100644 --- a/package.yaml +++ b/package.yaml @@ -30,6 +30,7 @@ dependencies: - cryptonite - memory - yaml +- process ghc-options: - -Wall 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 () |