Improve custom monad

lib/LiBro/Base.hs

@@ -2,19 +2,67 @@
 module LiBro.Base where
 
 import LiBro.Config
+import LiBro.Log
+import LiBro.Util as Util
+import Data.Csv
+import Data.Time.Clock
+import System.Directory as Dir
 import Control.Monad.Reader
+import Control.Monad.Writer
+import Control.Concurrent as Conc
 
--- |  Internal monad for 'Config'ured libro effects.
-newtype LiBro a = LiBro
-  { unLiBro :: ReaderT Config IO a
-  } deriving  ( Functor
-              , Applicative
-              , Monad
+-- |  Type class for 'Config'ured libro effects.
+class (Monad m, MonadFail m) => MonadLiBro m where
+
+  readConfig :: (Config -> a) -> m a
+
+  logInfo, logWarning, logError, logFatal :: LogSource -> LogMessage -> m ()
+  logInfo     = addLog INFO
+  logWarning  = addLog WARNING
+  logError    = addLog ERROR
+  logFatal    = addLog FATAL
+  addLog :: LogLevel -> LogSource -> LogMessage -> m ()
+  failError, failFatal :: LogSource -> LogMessage -> m a
+  failError s m = logError s m >> fail m
+  failFatal s m = logFatal s m >> fail m
+
+  doesFileExist :: FilePath -> m Bool
+
+  loadFromXlsx  :: FromNamedRecord a => FilePath -> m (Either String [a])
+  storeAsXlsx   :: (DefaultOrdered a, ToNamedRecord a) => FilePath -> [a] -> m ()
+
+  readMVar    :: MVar a -> m a
+  putMVar     :: MVar a -> a -> m ()
+  takeMVar    :: MVar a -> m a
+  isEmptyMVar :: MVar a -> m Bool
+
+-- |  The default configured 'LiBro' effect using 'IO'.
+newtype LiBroIO a = LiBro
+  { unLiBro :: ReaderT Config (WriterT [Log] IO) a
+  } deriving  ( Functor, Applicative, Monad, MonadFail
               , MonadReader Config
-              , MonadFail
+              , MonadWriter [Log]
               , MonadIO
               )
 
+instance MonadLiBro LiBroIO where
+  readConfig        = asks
+  addLog l s m      = do {now <- liftIO getCurrentTime; tell [Log now l s m]}
+  doesFileExist fp  = liftIO $ Dir.doesFileExist fp
+  loadFromXlsx fp   = liftIO $ Util.loadFromXlsx fp
+  storeAsXlsx fp d  = liftIO $ Util.storeAsXlsx fp d
+  readMVar mv       = liftIO $ Conc.readMVar mv
+  putMVar mv d      = liftIO $ Conc.putMVar mv d
+  takeMVar mv       = liftIO $ Conc.takeMVar mv
+  isEmptyMVar mv    = liftIO $ Conc.isEmptyMVar mv
+
 -- |  Run a 'Config'ured libro effect in 'IO'.
-runLiBro :: Config -> LiBro a -> IO a
-runLiBro config = flip runReaderT config . unLiBro
+runLiBroIO :: Config -> LiBroIO a -> IO a
+runLiBroIO config action = do
+  (result, logs) <- runLiBroIOLogs config action
+  mapM_ print logs
+  return result
+
+-- |  Run a 'Config'ured libro effect in 'IO' with logs attached.
+runLiBroIOLogs :: Config -> LiBroIO a -> IO (a, [Log])
+runLiBroIOLogs config = runWriterT . flip runReaderT config . unLiBro

lib/LiBro/Config.hs

@@ -39,8 +39,8 @@ parseConfig = flip parseIniFile $ do
 
 -- |  Reads a 'Config' value from @config.ini@.
 --    Prints parsing error messages to @STDERR@ when failing.
-readConfig :: IO (Maybe Config)
-readConfig = readConfigFrom "config.ini"
+readDefaultConfig :: IO (Maybe Config)
+readDefaultConfig = readConfigFrom "config.ini"
 
 -- |  Reads a 'Config' value from the given file path.
 --    Prints parsing error messages to @STDERR@ when failing.

lib/LiBro/Control.hs

@@ -2,11 +2,9 @@
 module LiBro.Control where
 
 import LiBro.Base
-import LiBro.Config
 import LiBro.Data
 import LiBro.Data.Storage
-import Control.Concurrent
-import Control.Monad.Reader
+import Control.Concurrent (MVar)
 
 -- |  Represents a blocking action because the system is loading
 --    or saving data.
@@ -17,23 +15,23 @@ data Blocking
 
 -- |  Initially load data and put it into the shared state.
 --    Expects the given 'MVar' to be empty.
-initData :: MVar Blocking -> MVar LiBroData -> LiBro ()
+initData :: MonadLiBro m => MVar Blocking -> MVar LiBroData -> m ()
 initData blocking libroData = do
-  liftIO $ putMVar blocking Reading
+  putMVar blocking Reading
   ld <- loadData
-  _ <- liftIO $ putMVar libroData ld
-  _ <- liftIO $ takeMVar blocking
+  _ <- putMVar libroData ld
+  _ <- takeMVar blocking
   return ()
 
 -- |  Try to store shared state data. Expects the given blocking 'MVar'
 --    to be empty. Iff not, returns 'False'.
-saveData :: MVar Blocking -> MVar LiBroData -> LiBro Bool
+saveData :: MonadLiBro m => MVar Blocking -> MVar LiBroData -> m Bool
 saveData blocking libroData = do
-  isBlocked <- not <$> liftIO (isEmptyMVar blocking)
+  isBlocked <- not <$> isEmptyMVar blocking
   if isBlocked
     then return False
     else do
-      liftIO $ putMVar blocking Writing
-      storeData =<< liftIO (readMVar libroData)
-      _ <- liftIO $ takeMVar blocking
+      putMVar blocking Writing
+      storeData =<< readMVar libroData
+      _ <- takeMVar blocking
       return True

lib/LiBro/Data/Storage.hs

@@ -22,17 +22,15 @@ import LiBro.Base
 import LiBro.Config
 import LiBro.Data
 import LiBro.Data.SafeText
-import LiBro.Util
+import qualified LiBro.Util as Util
 import Data.Function
 import Data.Map ((!))
 import qualified Data.Map as M
 import Data.Tree
 import Data.Csv
 import qualified Data.ByteString.Char8 as B
-import Control.Monad.Reader
 import GHC.Generics
 import System.FilePath
-import System.Directory
 
 -- |  A thin wrapper around lists of 'Int' with a simple
 --    (space-separated) 'String' representation.
@@ -89,7 +87,7 @@ taskRecordsToTasks :: Persons -> [TaskRecord] -> Tasks
 taskRecordsToTasks pmap trs =
   let tmap        = M.fromList $ map ((,) =<< trid) trs
       parentList  = map ((,) <$> trid <*> parentTid) trs
-      idForest    = readForest parentList
+      idForest    = Util.readForest parentList
   in  map (fmap $ fromRecord . (tmap !)) idForest
   where fromRecord tr = Task
           { tid         = trid tr
@@ -99,54 +97,58 @@ taskRecordsToTasks pmap trs =
           }
 
 -- |  Store 'Person's at the configured storage space
-storePersons :: Persons -> LiBro ()
+storePersons :: MonadLiBro m => Persons -> m ()
 storePersons pmap = do
-  sconf <- asks storage
+  sconf <- readConfig storage
   let fp = directory sconf </> personFile sconf
-  liftIO $ storeAsXlsx fp $ M.elems pmap
+  storeAsXlsx fp $ M.elems pmap
 
 -- |  Load a list of 'Person's from the configured storage space.
 --    Returns empty data if no input file was found.
-loadPersons :: LiBro Persons
+loadPersons :: MonadLiBro m => m Persons
 loadPersons = do
-  sconf <- asks storage
+  sconf <- readConfig storage
   let fp = directory sconf </> personFile sconf
-  exists <- liftIO $ doesFileExist fp
-  if not exists then return M.empty
+  exists <- doesFileExist fp
+  if not exists then fail $ fp ++ " does not exist"
     else do
-      Right prs <- liftIO $ loadFromXlsx fp
-      return $ personMap prs
+      mprs <- loadFromXlsx fp
+      case mprs of
+        Right prs -> return $ personMap prs
+        Left e    -> failFatal "XLSX persons loader" e
 
 -- |  Store 'Tasks' at the configured storage space.
-storeTasks :: Tasks -> LiBro ()
+storeTasks :: MonadLiBro m => Tasks -> m ()
 storeTasks ts = do
-  sconf <- asks storage
+  sconf <- readConfig storage
   let fp = directory sconf </> tasksFile sconf
-  liftIO $ storeAsXlsx fp $ tasksToTaskRecords ts
+  storeAsXlsx fp $ tasksToTaskRecords ts
 
 -- |  Load 'Tasks' from the configured storage space.
 --    Needs an additional 'Data.Map.Map' to find 'Person's for given
 --    person ids ('Int'). Returns empty data if no input file was found.
-loadTasks :: Persons -> LiBro Tasks
+loadTasks :: MonadLiBro m => Persons -> m Tasks
 loadTasks pmap = do
-  sconf <- asks storage
+  sconf <- readConfig storage
   let fp = directory sconf </> tasksFile sconf
-  exists <- liftIO $ doesFileExist fp
-  if not exists then return []
+  exists <- doesFileExist fp
+  if not exists then fail $ fp ++ " does not exist"
     else do
-      Right records <- liftIO $ loadFromXlsx fp
-      return $ taskRecordsToTasks pmap records
+      mrecords <- loadFromXlsx fp
+      case mrecords of
+        Right records -> return $ taskRecordsToTasks pmap records
+        Left e        -> failFatal "XLSX tasks loader" e
 
 -- |  Store a complete dataset at the configured file system
 --    locations.
-storeData :: LiBroData -> LiBro ()
+storeData :: MonadLiBro m => LiBroData -> m ()
 storeData ld = do
   storePersons  $ persons ld
   storeTasks    $ tasks ld
 
 -- |  Load a complete dataset from the configured file system
 --    locations. Returns empty data if no input files were found.
-loadData :: LiBro LiBroData
+loadData :: MonadLiBro m => m LiBroData
 loadData = do
   pmap <- loadPersons
   ts   <- loadTasks pmap

lib/LiBro/Log.hs

@@ -0,0 +1,18 @@
+module LiBro.Log where
+
+import Text.Printf
+import Data.Time.Clock
+
+data LogLevel   = INFO | WARNING | ERROR | FATAL
+                  deriving (Eq, Ord, Enum, Bounded, Show)
+type LogSource  = String
+type LogMessage = String
+data Log = Log
+  { time    :: UTCTime
+  , level   :: LogLevel
+  , source  :: LogSource
+  , message :: LogMessage
+  }
+
+instance Show Log where
+  show (Log t l s m) = printf "%s [%s] (%s): %s" (show l) (show t) s m

libro-backend.cabal

@@ -33,10 +33,12 @@ common consumer
 library
   import:             basic
   default-extensions: OverloadedStrings
+                    , FlexibleContexts
                     , GeneralizedNewtypeDeriving
                     , DeriveGeneric
   exposed-modules:    LiBro.Base
                     , LiBro.Config
+                    , LiBro.Log
                     , LiBro.Data
                     , LiBro.Data.Storage
                     , LiBro.Data.SafeText
@@ -57,6 +59,7 @@ library
                     , QuickCheck
                     , temporary
                     , text
+                    , time
                     , unordered-containers
                     , vector
   hs-source-dirs:     lib
@@ -76,6 +79,7 @@ test-suite libro-backend-test
   other-modules:      LiBro.TestUtil
                     , LiBro.TestUtilSpec
                     , LiBro.ConfigSpec
+                    , LiBro.LogSpec
                     , LiBro.DataSpec
                     , LiBro.Data.StorageSpec
                     , LiBro.Data.SafeTextSpec
@@ -99,5 +103,6 @@ test-suite libro-backend-test
                     , silently
                     , temporary
                     , text
+                    , time
                     , transformers
                     , vector

test/LiBro/ControlSpec.hs

@@ -9,7 +9,7 @@ import LiBro.Data.Storage
 import LiBro.Control
 import Data.Default
 import Data.Tree
-import Control.Concurrent
+import qualified Control.Concurrent as Conc
 import System.IO.Temp
 
 spec :: Spec
@@ -22,16 +22,16 @@ dataInitialization = describe "Blocking data loading" $ do
 
   context "With simple data files" $ do
     let config = def { storage = def { directory = "test/storage-files/data" }}
-    expectedData  <- runIO $ runLiBro config loadData
-    blocking      <- runIO $ newEmptyMVar
-    libroData     <- runIO $ newEmptyMVar
+    expectedData  <- runIO $ runLiBroIO config loadData
+    blocking      <- runIO $ Conc.newEmptyMVar
+    libroData     <- runIO $ Conc.newEmptyMVar
     (beb, bed, aeb, aned, ld) <- runIO $ do
-      beforeEmptyBlocking <- isEmptyMVar blocking
-      beforeEmptyData     <- isEmptyMVar libroData
-      runLiBro config $ initData blocking libroData
-      afterEmptyBlocking  <- isEmptyMVar blocking
-      afterNonEmptyData   <- isEmptyMVar libroData
-      loadedData          <- readMVar libroData
+      beforeEmptyBlocking <- Conc.isEmptyMVar blocking
+      beforeEmptyData     <- Conc.isEmptyMVar libroData
+      runLiBroIO config $ initData blocking libroData
+      afterEmptyBlocking  <- Conc.isEmptyMVar blocking
+      afterNonEmptyData   <- Conc.isEmptyMVar libroData
+      loadedData          <- Conc.readMVar libroData
       return
         ( beforeEmptyBlocking
         , beforeEmptyData
@@ -55,24 +55,24 @@ dataStorage = describe "Storing complete LiBro data" $ do
       ldata     = LBS (personMap [ldPerson]) [Node ldTask []]
 
   context "Manual saving while blocked" $ do
-    blocking  <- runIO $ newMVar Reading
-    libroData <- runIO $ newMVar ldata
+    blocking  <- runIO $ Conc.newMVar Reading
+    libroData <- runIO $ Conc.newMVar ldata
     rv <- runIO $ withSystemTempDirectory "storage" $ \tdir -> do
       let config = def { storage = def { directory = tdir }}
-      runLiBro config $ saveData blocking libroData
+      runLiBroIO config $ saveData blocking libroData
     it "Saving returns False" $ rv `shouldBe` False
 
   context "Manual saving of simple data" $ do
-    blocking  <- runIO $ newEmptyMVar
-    libroData <- runIO $ newMVar ldata
+    blocking  <- runIO $ Conc.newEmptyMVar
+    libroData <- runIO $ Conc.newMVar ldata
     testData  <- runIO $ withSystemTempDirectory "storage" $ \tdir -> do
       let config = def { storage = def { directory = tdir }}
-      beforeEmptyBlocking <- isEmptyMVar blocking
-      beforeLibroData     <- readMVar libroData
-      returnValue         <- runLiBro config $ saveData blocking libroData
-      afterEmptyBlocking  <- isEmptyMVar blocking
-      afterLibroData      <- readMVar libroData
-      storedData          <- runLiBro config loadData
+      beforeEmptyBlocking <- Conc.isEmptyMVar blocking
+      beforeLibroData     <- Conc.readMVar libroData
+      returnValue         <- runLiBroIO config $ saveData blocking libroData
+      afterEmptyBlocking  <- Conc.isEmptyMVar blocking
+      afterLibroData      <- Conc.readMVar libroData
+      storedData          <- runLiBroIO config loadData
       return
         ( beforeEmptyBlocking
         , beforeLibroData