Cleaner and events sender background workers

Author: soupi

src/Web/Gathering/Database.hs

@@ -44,7 +44,6 @@ getNewUser name email =
       (contramap fst (SqlE.value SqlE.text) <> contramap snd (SqlE.value SqlE.text))
       (SqlD.maybeRow decodeUser)
       True
-  
 
 -- | Get a user from the users table with a specific id
 getUserById :: UserId -> Sql.Session (Maybe User)
@@ -213,7 +212,7 @@ verifyNewUser key email = do
       case insertResult of
         Just r ->
           pure (pure r)
-        Nothing -> 
+        Nothing ->
           pure (Left "Could not find associated email. Maybe verification expired?")
 
 

src/Web/Gathering/Run.hs

@@ -15,6 +15,8 @@ import Web.Gathering.Types
 import Web.Gathering.Config
 import Web.Gathering.Database
 import Web.Gathering.Router
+import Web.Gathering.Workers.SendEmails
+import Web.Gathering.Workers.Cleaner
 
 import Control.Monad (void)
 import Control.Concurrent (forkIO)
@@ -35,11 +37,18 @@ import Web.Spock.Config
 --
 run :: IO ()
 run = do
-  (config, cmd) <- parseArgs
-  print (config, cmd)
-  let connstr = cfgDbConnStr config
-  spockCfg <- defaultSpockCfg EmptySession (PCConn $ hasqlPool connstr) (AppState config cmd)
-  case cmd of
+  (uncurry AppState -> state) <- parseArgs
+  print state
+  let connstr = cfgDbConnStr (appConfig state)
+  spockCfg <- defaultSpockCfg EmptySession (PCConn $ hasqlPool connstr) state
+
+  -- Background workers
+  void $ forkIO $ newEventsWorker state
+  void $ forkIO $ cleanerWorker state
+
+  -- app
+
+  case appCommand state of
     HTTP port ->
       runSpock port (spock spockCfg appRouter)
     HTTPS tls -> do
@@ -49,6 +58,7 @@ run = do
       runHttps spockCfg tls
 
 
+
 -- | Run the spock app with HTTPS
 runHttps :: SpockCfg Connection MySession AppState -> TLSConfig -> IO ()
 runHttps spockCfg tls = do

src/Web/Gathering/Workers/Cleaner.hs

@@ -11,10 +11,23 @@ import Hasql.Session
 import Hasql.Connection
 
 import Web.Gathering.Database
+import Web.Gathering.Types
+import Web.Gathering.Config
 
-cleanerWorker :: Connection -> IO ()
-cleanerWorker conn = forever $ do
-  cleaner conn
+cleanerWorker :: AppState -> IO ()
+cleanerWorker state = forever $ do
+  mConn <- acquire (cfgDbConnStr $ appConfig state)
+
+  case mConn of
+    Right conn -> do
+      putStrLn "Cleaner starting..."
+      cleaner conn
+      release conn
+
+    Left ex ->
+      err ("Cleaner: " <> pack (show ex))
+
+  putStrLn "Cleaner sleeping..."
   sleep (60 * 60) -- sleep for 1 hour
 
 cleaner :: Connection -> IO ()

src/Web/Gathering/Workers/SendEmails.hs

@@ -34,15 +34,17 @@ import Web.Gathering.Database
 
 newEventsWorker :: AppState -> IO ()
 newEventsWorker config = forever $ do
+  putStrLn "Events worker starting..."
   newEventsWorker' config
+  putStrLn "Events Worker sleeping..."
   sleep (60 * 20) -- sleep for 20 minutes
 
 newEventsWorker' :: AppState -> IO ()
 newEventsWorker' config = do
   mConn <- acquire (cfgDbConnStr $ appConfig config)
   case mConn of
     Right conn -> do
-      sendNewEvents config conn `catch` \ex -> err ("New Events Worker: " <> (pack $ show (ex :: IOException)))
+      sendNewEvents config conn `catch` \ex -> err ("New Events Worker: " <> (pack $ show (ex :: SomeException)))
       release conn
     Left ex ->
       err ("New Events Worker: " <> pack (show ex))