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