batched/commulative notifications about pending bangs

6 files changed, 31 insertions, 4 deletions

diff --git a/README.md b/README.md
index 1186725..f2b1103 100644
--- a/README.md
+++ b/README.md
@@ -22,6 +22,7 @@ If you go with environment variables, the following options are available:
 - 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: ""
+- ADMIN\_EMAIL: Email that receives notifications about pending bangs using EMAIL\_CMD. 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 32d2a26..f8bbd63 100644
--- a/fastbangs.cabal
+++ b/fastbangs.cabal
@@ -42,9 +42,11 @@ executable fastbangs
     , persistent
     , persistent-sqlite
     , process
+    , resource-pool
     , resourcet
     , stm
     , text
+    , unliftio-core
     , warp
     , yaml
     , yesod
diff --git a/fastbangs.yaml b/fastbangs.yaml
index 1927761..0c5be05 100644
--- a/fastbangs.yaml
+++ b/fastbangs.yaml
@@ -24,3 +24,7 @@ admin-pw-hash: ""
 # everything as their email address, so not being careful can easily lead to SQLI-type
 # vulnerabilities, and possibly remote command execution, so be careful.
 #email-command: "/path/to/your/email/script"
+
+# This email will receive notifications about pending bangs, using the email-command
+# given above.
+#admin-email: "blah@blub.bleh"
diff --git a/package.yaml b/package.yaml
index e3287e7..5657107 100644
--- a/package.yaml
+++ b/package.yaml
@@ -31,6 +31,8 @@ dependencies:
 - memory
 - yaml
 - process
+- resource-pool
+- unliftio-core
 
 ghc-options:
 - -Wall
diff --git a/src/Config.hs b/src/Config.hs
index 2b2f341..6ffb1fd 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -30,7 +30,8 @@ data Config = Config {
     confFavicon :: Text,
     confUser :: Text,
     confPwHash :: Text,
-    confEmailCmd :: Maybe FilePath
+    confEmailCmd :: Maybe FilePath,
+    confAdminEmail :: String
 } deriving (Show, Eq)
 
 getConfig :: IO Config
@@ -47,6 +48,7 @@ getConfig = do
         <*> 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")
+        <*> resolveVal (lookup "admin-email" confFile) "ADMIN_EMAIL" ""
 
   where resolveVal :: IsString s => Maybe String -> String -> String -> IO s
         resolveVal mayConf q def = do
diff --git a/src/Main.hs b/src/Main.hs
index 91da385..d69ced6 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,16 +1,18 @@
 {-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell,
-    TypeFamilies, LambdaCase, EmptyDataDecls #-}
+    TypeFamilies, LambdaCase, EmptyDataDecls, ScopedTypeVariables #-}
 
 {-# OPTIONS -Wno-unused-top-binds #-}
 
 module Main (main) where
 
+import Control.Monad.IO.Unlift (toIO)
 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 Data.Pool (Pool)
 import Network.Wai.Handler.Warp hiding (getPort, getHost)
 import Yesod
 
@@ -26,7 +28,8 @@ import BatchedRunner
 data Search = Search {
     bangState :: BangState,
     sqlPool :: ConnectionPool,
-    config :: Config
+    config :: Config,
+    notifyPbRunner :: Runner
 }
 
 mkYesod "Search" [parseRoutes|
@@ -89,6 +92,8 @@ postSubmitR = do
     unless (verifyPendingBang pb) $ invalidArgs []
     runDB $ insert400_ pb
 
+    liftIO . notifyRunner . notifyPbRunner =<< getYesod
+
 getOpenSearchR :: Handler TypedContent
 getOpenSearchR = do
     neverExpires
@@ -136,6 +141,14 @@ getPendingR = do
     pendingBangs <- runDB $ selectList [] []
     return $ toJSON $ map entityVal (pendingBangs :: [Entity PendingBang])
 
+sendPendingBangs :: forall m. (MonadLogger m, MonadUnliftIO m)
+                 => Config -> Pool SqlBackend -> m ()
+sendPendingBangs cfg pool = do
+    n <- length <$> (runSqlPool (selectList [] []) pool :: m [Entity PendingBang])
+    when (n > 0) $ sendEmail cfg (confAdminEmail cfg) "Pending Bang notification" $
+        "There are currently " <> show n <> " pending bangs.\n" <>
+        "Please do something about it.\n"
+
 main :: IO ()
 main = runStdoutLoggingT $ withSqlitePool "banger.db" 2 $ \pool -> do
     runResourceT $ flip runSqlPool pool $ runMigration migrateAll
@@ -144,7 +157,10 @@ main = runStdoutLoggingT $ withSqlitePool "banger.db" 2 $ \pool -> do
     cfg <- liftIO getConfig
     $(logInfo) $ "Using config: " <> T.pack (show cfg)
 
-    sApp <- liftIO $ toWaiApp $ Search bs pool cfg -- includes middlewares
+    sendPbIO <- toIO $ sendPendingBangs cfg pool
+    notifyPb <- liftIO $ makeRunner sendPbIO 600000000 {- 10 min -}
+
+    sApp <- liftIO $ toWaiApp $ Search bs pool cfg notifyPb -- includes middlewares
 
     let settings = defaultSettings
             & setHost (confHost cfg)