Add schedule module move some ExceptTs around

src/Yore/DB.hs

@@ -9,7 +9,7 @@ module Yore.DB
   , Error (..)
   , initDB
   , withConn
-  , withConn'
+  , withTransaction
   , DayIndex (..)
   , DayFile (..)
   , createDayFile
@@ -18,9 +18,11 @@ module Yore.DB
   , readDayPaths
   , getDayFileByIssue
   , getNumberOfIssues
+  , lift
   ) where
 
 import Control.Concurrent (getNumCapabilities)
+import Control.Monad.Trans.Except (ExceptT (..), catchE, runExceptT, throwE)
 import Data.Functor.Identity (Identity (..))
 import Data.Pool (Pool, defaultPoolConfig, newPool, withResource)
 import Data.Text (Text)
@@ -49,22 +51,33 @@ initDB connString = do
 
 -- TODO: This should probably also do something like bracket...
 -- For now let's assume no exceptions are thrown in f.
-withConn :: DB -> (Opium.Connection -> IO (Either Error a)) -> IO (Either Error a)
+withConn :: DB -> (Opium.Connection -> ExceptT Error IO a) -> ExceptT Error IO a
 withConn (DB connPool) f =
-  withResource connPool $ \case
+  ExceptT $ withResource connPool $ \case
     Left connectionError ->
       pure $ Left $ ConnectionError connectionError
     Right conn ->
-      f conn >>= \case
-        Left err -> do
-          -- rollback open transactions and release transaction level locks.
-          _ <- Opium.execute_ "ROLLBACK" conn
-          pure $ Left err
-        Right x ->
-          pure $ Right x
+      runExceptT $ f conn
 
-withConn' :: DB -> (Opium.Connection -> IO (Either Opium.Error a)) -> IO (Either Error a)
-withConn' db f = withConn db $ fmap (first DBError) . f
+withTransaction :: DB -> (Opium.Connection -> ExceptT Error IO a) -> ExceptT Error IO a
+withTransaction db f =
+  withConn db $ \conn ->
+    ( do
+        lift $ Opium.execute_ "BEGIN" conn
+        x <- f conn
+        lift $ Opium.execute_ "COMMIT" conn
+        pure x
+    )
+      `catchE` ( \err -> do
+                  -- rollback open transactions and release transaction level locks...
+                  lift $ Opium.execute_ "ROLLBACK" conn
+                  -- ...then rethrow the error so the app can handle it too.
+                  throwE err
+               )
+
+lift :: IO (Either Opium.Error a) -> ExceptT Error IO a
+lift f =
+  ExceptT $ first DBError <$> f
 
 data DayIndex = DayIndex
   { day_index_id :: Int

src/Yore/Log.hs

@@ -1,18 +1,19 @@
 module Yore.Log (Yore.Log.error, info) where
 
+import Control.Monad.IO.Class (MonadIO (..))
 import Data.Time (ZonedTime, getZonedTime)
 import Data.Time.Format (defaultTimeLocale, formatTime)
 import GHC.Stack (HasCallStack, SrcLoc (..), callStack, getCallStack)
 import Text.Printf (printf)
 
-info :: (HasCallStack) => String -> IO ()
+info :: (HasCallStack, MonadIO m) => String -> m ()
 info = doLog "INF"
 
-error :: (HasCallStack) => String -> IO ()
+error :: (HasCallStack, MonadIO m) => String -> m ()
 error = doLog "ERR"
 
-doLog :: (HasCallStack) => String -> String -> IO ()
-doLog level msg = do
+doLog :: (HasCallStack, MonadIO m) => String -> String -> m ()
+doLog level msg = liftIO $ do
   now <- getZonedTime
   let location = getLocation $ getCallStack callStack
   printf "(%s) (%s) (%s) %s\n" (iso8601Show now) level location msg

src/Yore/Schedule.hs

@@ -0,0 +1,21 @@
+module Yore.Schedule (schedule) where
+
+import Control.Monad (when)
+import Data.Time (ZonedTime, getZonedTime, secondsToNominalDiffTime, nominalDiffTimeToSeconds)
+import Control.Concurrent (threadDelay, forkIO)
+import Data.Time.Clock.POSIX (getPOSIXTime)
+
+schedule :: (ZonedTime -> Bool) -> IO () -> IO ()
+schedule shouldRunAt f = everyMinute $ \now -> when (shouldRunAt now) f
+
+everyMinute :: (ZonedTime -> IO ()) -> IO ()
+everyMinute f = do
+  -- Use POSIX time to avoid having to handle leap seconds
+  now <- getPOSIXTime
+  let posixSeconds :: Int 
+      posixSeconds = floor $ nominalDiffTimeToSeconds now
+      lastFullMinute = secondsToNominalDiffTime $ fromIntegral $ posixSeconds - posixSeconds `mod` 60
+      secondsSinceLastFullMinute = now - lastFullMinute
+  threadDelay $ ceiling $ (60 - secondsSinceLastFullMinute) * 1_000_000
+  _ <- forkIO $ f =<< getZonedTime
+  everyMinute f