Merge branch 'main' into basic-webservice

Pull LiBro monad changes into the webservice branch

LICENSE

@@ -1,4 +1,4 @@
-Copyright (c) 2023 Mirko Westermeier
+Copyright (c) 2023-2024 Mirko Westermeier
 
 Permission is hereby granted, free of charge, to any person obtaining
 a copy of this software and associated documentation files (the

README.md

@@ -36,6 +36,6 @@ $ make test_only pattern="SafeText wrapper/Safe packing"
 
 ## Author and license
 
-Copyright (c) 2023 Mirko Westermeier
+Copyright (c) 2023-2024 Mirko Westermeier
 
 Released under the MIT license (see LICENSE) for details.

lib/LiBro/Base.hs

@@ -0,0 +1,18 @@
+-- |  Basic definitions.
+module LiBro.Base where
+
+import LiBro.Config
+import Control.Monad.Reader
+
+newtype LiBro a = LiBro
+  { unLiBro :: ReaderT Config IO a
+  } deriving  ( Functor
+              , Applicative
+              , Monad
+              , MonadReader Config
+              , MonadFail
+              , MonadIO
+              )
+
+runLiBro :: Config -> LiBro a -> IO a
+runLiBro config = flip runReaderT config . unLiBro

lib/LiBro/Control.hs

@@ -1,6 +1,7 @@
 -- |  Controlling the LiBro data flow.
 module LiBro.Control where
 
+import LiBro.Base
 import LiBro.Config
 import LiBro.Data
 import LiBro.Data.Storage
@@ -16,24 +17,25 @@ data Blocking
 
 -- |  Initially load data and put it into the shared state.
 --    Expects the given 'MVar' to be empty.
-initData :: Config -> MVar Blocking -> MVar LiBroData -> IO ()
-initData cfg blocking libroData = do
-  putMVar blocking Reading
-  putMVar libroData =<< loadData cfg
-  _ <- takeMVar blocking
+initData :: MVar Blocking -> MVar LiBroData -> LiBro ()
+initData blocking libroData = do
+  liftIO $ putMVar blocking Reading
+  ld <- loadData
+  _ <- liftIO $ putMVar libroData ld
+  _ <- liftIO $ takeMVar blocking
   return ()
 
--- |  Try to store shared state data. Expects the given blocking MVar
+-- |  Try to store shared state data. Expects the given blocking 'MVar'
 --    to be empty. Iff not, returns 'False'.
-saveData :: Config -> MVar Blocking -> MVar LiBroData -> IO Bool
-saveData cfg blocking libroData = do
-  isBlocked <- not <$> isEmptyMVar blocking
+saveData :: MVar Blocking -> MVar LiBroData -> LiBro Bool
+saveData blocking libroData = do
+  isBlocked <- not <$> liftIO (isEmptyMVar blocking)
   if isBlocked
     then return False
     else do
-      putMVar blocking Writing
-      storeData cfg =<< readMVar libroData
-      _ <- takeMVar blocking
+      liftIO $ putMVar blocking Writing
+      storeData =<< liftIO (readMVar libroData)
+      _ <- liftIO $ takeMVar blocking
       return True
 
 -- |  Shared libro system state to access data any time.
@@ -44,11 +46,12 @@ data LiBroState = LiBroState
   }
 
 -- |  Initialization of a 'LiBroState'.
-initLiBroState :: Config -> IO LiBroState
-initLiBroState cfg = do
-  mvb <- newEmptyMVar
-  mvd <- newEmptyMVar
-  initData cfg mvb mvd
+initLiBroState :: LiBro LiBroState
+initLiBroState = do
+  mvb <- liftIO newEmptyMVar
+  mvd <- liftIO newEmptyMVar
+  initData mvb mvd
+  cfg <- ask
   return $ LiBroState cfg mvb mvd
 
 -- |  Type alias for actions holding a 'LiBroState' inside 'ReaderT'.
@@ -77,12 +80,12 @@ lsInitData = do
   cfg <- asks config
   mvb <- asks mvBlocking
   mvd <- asks mvData
-  lift $ initData cfg mvb mvd
+  lift $ runLiBro cfg $ initData mvb mvd
 
 -- |  'saveData' action.
 lsSaveData :: Action Bool
 lsSaveData = do
   cfg <- asks config
   mvb <- asks mvBlocking
   mvd <- asks mvData
-  lift $ saveData cfg mvb mvd
+  lift $ runLiBro cfg $ saveData mvb mvd

lib/LiBro/Data/Storage.hs

@@ -18,6 +18,7 @@ module LiBro.Data.Storage
   , loadData
   ) where
 
+import LiBro.Base
 import LiBro.Config
 import LiBro.Data
 import LiBro.Data.SafeText
@@ -28,6 +29,7 @@ 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
@@ -97,56 +99,55 @@ taskRecordsToTasks pmap trs =
           }
 
 -- |  Store 'Person's at the configured storage space
---    via 'Config'.
-storePersons :: Config -> Persons -> IO ()
-storePersons conf pmap = do
-  let sconf = storage conf
-      fp    = directory sconf </> personFile sconf
-  storeAsXlsx fp $ M.elems pmap
+storePersons :: Persons -> LiBro ()
+storePersons pmap = do
+  sconf <- asks storage
+  let fp = directory sconf </> personFile sconf
+  liftIO $ storeAsXlsx fp $ M.elems pmap
 
--- |  Load a list of 'Person's from the configured storage space
---    via 'Config'. Returns empty data if no input file was found.
-loadPersons :: Config -> IO Persons
-loadPersons conf = do
-  let sconf = storage conf
-      fp    = directory sconf </> personFile sconf
-  exists <- doesFileExist fp
+-- |  Load a list of 'Person's from the configured storage space.
+--    Returns empty data if no input file was found.
+loadPersons :: LiBro Persons
+loadPersons = do
+  sconf <- asks storage
+  let fp = directory sconf </> personFile sconf
+  exists <- liftIO $ doesFileExist fp
   if not exists then return M.empty
     else do
-      Right prs <- loadFromXlsx fp
+      Right prs <- liftIO $ loadFromXlsx fp
       return $ personMap prs
 
--- |  Store 'Tasks' at the configured storage space via 'Config'.
-storeTasks :: Config -> Tasks -> IO ()
-storeTasks conf ts = do
-  let sconf = storage conf
-      fp    = directory sconf </> tasksFile sconf
-  storeAsXlsx fp $ tasksToTaskRecords ts
+-- |  Store 'Tasks' at the configured storage space.
+storeTasks :: Tasks -> LiBro ()
+storeTasks ts = do
+  sconf <- asks storage
+  let fp = directory sconf </> tasksFile sconf
+  liftIO $ storeAsXlsx fp $ tasksToTaskRecords ts
 
--- |  Load 'Tasks' from the configured storage space via 'Config'.
+-- |  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 :: Config -> Persons -> IO Tasks
-loadTasks conf pmap = do
-  let sconf = storage conf
-      fp    = directory sconf </> tasksFile sconf
-  exists <- doesFileExist fp
+loadTasks :: Persons -> LiBro Tasks
+loadTasks pmap = do
+  sconf <- asks storage
+  let fp = directory sconf </> tasksFile sconf
+  exists <- liftIO $ doesFileExist fp
   if not exists then return []
     else do
-      Right records <- loadFromXlsx fp
+      Right records <- liftIO $ loadFromXlsx fp
       return $ taskRecordsToTasks pmap records
 
--- |  Store a complete dataset at the 'Config'ured file system
+-- |  Store a complete dataset at the configured file system
 --    locations.
-storeData :: Config -> LiBroData -> IO ()
-storeData conf ld = do
-  storePersons  conf (persons ld)
-  storeTasks    conf (tasks ld)
+storeData :: LiBroData -> LiBro ()
+storeData ld = do
+  storePersons  $ persons ld
+  storeTasks    $ tasks ld
 
--- |  Load a complete dataset from the 'Config'ured file system
+-- |  Load a complete dataset from the configured file system
 --    locations. Returns empty data if no input files were found.
-loadData :: Config -> IO LiBroData
-loadData conf = do
-  pmap <- loadPersons conf
-  ts   <- loadTasks   conf pmap
+loadData :: LiBro LiBroData
+loadData = do
+  pmap <- loadPersons
+  ts   <- loadTasks pmap
   return $ LBS pmap ts

libro-backend.cabal

@@ -10,7 +10,7 @@ license:              MIT
 license-file:         LICENSE
 author:               Mirko Westermeier
 maintainer:           [email protected]
-copyright:            (c) 2023 Mirko Westermeier
+copyright:            (c) 2023-2024 Mirko Westermeier
 
 source-repository head
   type:     git
@@ -33,10 +33,12 @@ common consumer
 library
   import:             basic
   default-extensions: OverloadedStrings
+                    , GeneralizedNewtypeDeriving
                     , DeriveGeneric
                     , DataKinds
                     , TypeOperators
-  exposed-modules:    LiBro.Config
+  exposed-modules:    LiBro.Base
+                    , LiBro.Config
                     , LiBro.Data
                     , LiBro.Data.Storage
                     , LiBro.Data.SafeText

server/Main.hs

@@ -1,5 +1,6 @@
 module Main where
 
+import LiBro.Base
 import LiBro.Config
 import LiBro.Control
 import LiBro.WebService
@@ -9,7 +10,7 @@ configuredMain :: Config -> IO ()
 configuredMain cfg = do
   let p = port $ server cfg
   putStrLn $ "Serving LiBro backend on port " ++ show p ++ "."
-  initState <- initLiBroState cfg
+  initState <- runLiBro cfg initLiBroState
   run p $ libro initState
 
 main :: IO ()

test/LiBro/ControlSpec.hs

@@ -2,6 +2,7 @@ module LiBro.ControlSpec where
 
 import Test.Hspec
 
+import LiBro.Base
 import LiBro.Config
 import LiBro.Data
 import LiBro.Data.Storage
@@ -20,14 +21,14 @@ dataInitialization :: Spec
 dataInitialization = describe "Blocking data loading" $ do
 
   context "With simple data files" $ do
-    let cfg = def { storage = def { directory = "test/storage-files/data" }}
-    expectedData  <- runIO $ loadData cfg
+    let config = def { storage = def { directory = "test/storage-files/data" }}
+    expectedData  <- runIO $ runLiBro config loadData
     blocking      <- runIO $ newEmptyMVar
     libroData     <- runIO $ newEmptyMVar
     (beb, bed, aeb, aned, ld) <- runIO $ do
       beforeEmptyBlocking <- isEmptyMVar blocking
       beforeEmptyData     <- isEmptyMVar libroData
-      initData cfg blocking libroData
+      runLiBro config $ initData blocking libroData
       afterEmptyBlocking  <- isEmptyMVar blocking
       afterNonEmptyData   <- isEmptyMVar libroData
       loadedData          <- readMVar libroData
@@ -57,21 +58,21 @@ dataStorage = describe "Storing complete LiBro data" $ do
     blocking  <- runIO $ newMVar Reading
     libroData <- runIO $ newMVar ldata
     rv <- runIO $ withSystemTempDirectory "storage" $ \tdir -> do
-      let conf = def { storage = def { directory = tdir }}
-      saveData conf blocking libroData
+      let config = def { storage = def { directory = tdir }}
+      runLiBro 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
     testData  <- runIO $ withSystemTempDirectory "storage" $ \tdir -> do
-      let conf = def { storage = def { directory = tdir }}
+      let config = def { storage = def { directory = tdir }}
       beforeEmptyBlocking <- isEmptyMVar blocking
       beforeLibroData     <- readMVar libroData
-      returnValue         <- saveData conf blocking libroData
+      returnValue         <- runLiBro config $ saveData blocking libroData
       afterEmptyBlocking  <- isEmptyMVar blocking
       afterLibroData      <- readMVar libroData
-      storedData          <- loadData conf
+      storedData          <- runLiBro config loadData
       return
         ( beforeEmptyBlocking
         , beforeLibroData

test/LiBro/Data/StorageSpec.hs

@@ -7,6 +7,7 @@ import Test.Hspec.QuickCheck
 import Test.QuickCheck.Arbitrary.Generic
 import LiBro.TestUtil
 
+import LiBro.Base
 import LiBro.Config
 import LiBro.Data
 import LiBro.Data.Storage
@@ -133,7 +134,8 @@ personStorage = describe "XLSX storage of Person data" $ do
 
   describe "Loading without a file" $ do
     result <- runIO $ withSystemTempDirectory "person-storage" $ \tdir -> do
-      loadPersons $ def { storage = def { directory = tdir }}
+      let config = def { storage = def { directory = tdir }}
+      runLiBro config loadPersons 
     it "Empty Person map" $
       result `shouldBe` M.empty
 
@@ -142,16 +144,16 @@ personStorage = describe "XLSX storage of Person data" $ do
       forAll genPersons $ \pmap -> ioProperty $ do
         withSystemTempDirectory "person-storage" $ \tdir -> do
           let config = def { storage = def { directory = tdir }}
-          storePersons config pmap
-          loadedPersons <- loadPersons config
+          loadedPersons <- runLiBro config $ storePersons pmap >> loadPersons
           return $ loadedPersons === pmap
 
 taskStorage :: Spec
 taskStorage = describe "XLSX storage of Task data" $ do
 
   describe "Loading without a file" $ do
     result <- runIO $ withSystemTempDirectory "task-storage" $ \tdir -> do
-      loadTasks (def { storage = def { directory = tdir }}) M.empty
+      let config = def { storage = def { directory = tdir }}
+      runLiBro config $ loadTasks M.empty
     it "Empty task list" $
       result `shouldBe` []
 
@@ -170,16 +172,14 @@ taskStorage = describe "XLSX storage of Task data" $ do
   describe "Storing empty data" $ do
     loadedTasks <- runIO $ withSystemTempDirectory "task-storage" $ \tdir -> do
       let config = def { storage = def { directory = tdir }}
-      storeTasks config []
-      loadTasks config pmap
+      runLiBro config $ storeTasks [] >> loadTasks pmap
     it "Got empty task forest" $
       loadedTasks `shouldBe` []
 
   describe "Storing some task data" $ do
     loadedTasks <- runIO $ withSystemTempDirectory "task-storage" $ \tdir -> do
       let config = def { storage = def { directory = tdir }}
-      storeTasks config ts
-      loadTasks config pmap
+      runLiBro config $ storeTasks ts >> loadTasks pmap
     it "Got the right task forest" $
       loadedTasks `shouldBe` ts
 
@@ -200,7 +200,7 @@ dataStorage = describe "Complete dataset" $ do
                     ]
                   ]
     let conf = def { storage = def { directory = "test/storage-files/data" }}
-    (LBS loadedPersons loadedTasks) <- runIO $ loadData conf
+    (LBS loadedPersons loadedTasks) <- runIO $ runLiBro conf loadData
     it "Load correct persons" $
       loadedPersons `shouldBe` personMap pmap
     it "Load correct task forest" $
@@ -212,7 +212,6 @@ dataStorage = describe "Complete dataset" $ do
         forAll genPersonsTasks $ \d ->
           ioProperty $ do
             withSystemTempDirectory "storage" $ \tdir -> do
-              let conf = def { storage = def { directory = tdir }}
-              storeData conf d
-              loadedData <- loadData conf
+              let config = def { storage = def { directory = tdir }}
+              loadedData <- runLiBro config $ storeData d >> loadData
               return $ loadedData `shouldBe` d

test/LiBro/DataSpec.hs

@@ -30,8 +30,8 @@ assigneesOfTasks = describe "Assignees of tasks" $ do
                     , Task 3 "3t" "3d" []
                     ]
         taskF     = [ Node (myTasks !! 0) [Node (myTasks !! 1) []]
-                  , Node (myTasks !! 2) []
-                  ]
+                    , Node (myTasks !! 2) []
+                    ]
     it "Correct tasks for person 1" $
       tid <$> assignedTasks (myPersons !! 0) taskF `shouldBe` [1, 2]
     it "Correct tasks for person 2" $