batched/commulative notifications about pending bangs

1 files changed, 19 insertions, 3 deletions

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)