Merge pull request #18 from libro-app/librio

Use LiBro monad for Config-ured effects

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,10 +1,12 @@
 -- |  Controlling the LiBro data flow.
 module LiBro.Control where
 
+import LiBro.Base
 import LiBro.Config
 import LiBro.Data
 import LiBro.Data.Storage
 import Control.Concurrent
+import Control.Monad.Reader
 
 -- |  Represents a blocking action because the system is loading
 --    or saving data.
@@ -15,22 +17,23 @@ 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 config blocking libroData = do
-  putMVar blocking Reading
-  putMVar libroData =<< loadData config
-  _ <- 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'
 --    to be empty. Iff not, returns 'False'.
-saveData :: Config -> MVar Blocking -> MVar LiBroData -> IO Bool
-saveData config 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 config =<< readMVar libroData
-      _ <- takeMVar blocking
+      liftIO $ putMVar blocking Writing
+      storeData =<< liftIO (readMVar libroData)
+      _ <- liftIO $ takeMVar blocking
       return True

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

@@ -33,8 +33,10 @@ common consumer
 library
   import:             basic
   default-extensions: OverloadedStrings
+                    , GeneralizedNewtypeDeriving
                     , DeriveGeneric
-  exposed-modules:    LiBro.Config
+  exposed-modules:    LiBro.Base
+                    , LiBro.Config
                     , LiBro.Data
                     , LiBro.Data.Storage
                     , LiBro.Data.SafeText

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
@@ -21,13 +22,13 @@ dataInitialization = describe "Blocking data loading" $ do
 
   context "With simple data files" $ do
     let config = def { storage = def { directory = "test/storage-files/data" }}
-    expectedData  <- runIO $ loadData config
+    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 config 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