Implement server for the REST API

.github/workflows/haskell-ci.yml

@@ -12,7 +12,7 @@ jobs:
       fail-fast: false
       matrix:
         os: [ubuntu-latest]
-        ghc-version: ['9.4', '9.6', '9.8']
+        ghc-version: ['9.4', '9.6']
     steps:
 
       - name: Checkout repository content

.gitignore

@@ -1,6 +1,12 @@
 # Vim swap files
 *.sw[a-p]
 
+# LibreOffice swap files
+.~lock.*#
+
+# Data storage files
+data-storage/*.xlsx
+
 # Generated documentstion
 api-docs
 

Makefile

@@ -1,4 +1,4 @@
-.PHONY: all build warnings test test_only doc stats
+.PHONY: all build warnings test test_only doc serve stats
 
 all: build test doc stats
 
@@ -17,6 +17,9 @@ test_only:
 doc:
 	cabal haddock --haddock-hyperlinked-source --haddock-html-location='https://hackage.haskell.org/package/$$pkg-$$version/docs'
 
+serve:
+	cabal run libro-backend
+
 stats:
 	find lib -name '*.hs' -not -path "./dist-newstyle/*" | sort | xargs wc -l
 	find test -name '*.hs' -not -path "./dist-newstyle/*" | sort | xargs wc -l

README.md

@@ -17,6 +17,12 @@ Haskell dependencies:
 cabal install --only-dependencies all
 ```
 
+## Run the RESTful JSON web service
+
+```
+make serve
+```
+
 ## Run tests
 
 Running all the tests with `make test` may take some time. Run individual tests with

config.ini

@@ -1,4 +1,8 @@
 [storage]
 directory     = data-storage
-tasks-file    = tasks.csv
-tracking-file = tracking.csv
+person-file   = persons.xlsx
+tasks-file    = tasks.xlsx
+tracking-file = tracking.xlsx
+
+[server]
+port = 8080

lib/LiBro/Config.hs

@@ -18,13 +18,22 @@ data StorageConfig = Storage
 instance Default StorageConfig where
   def = Storage "data-storage" "persons.xlsx" "tasks.xlsx" "tracking.xlsx"
 
+-- |  Configuration of server details
+data ServerConfig = Server
+  { port :: Int
+  } deriving (Eq, Show)
+
+instance Default ServerConfig where
+  def = Server 8080
+
 -- |  Global settings.
 data Config = Config
   { storage :: StorageConfig
+  , server  :: ServerConfig
   } deriving (Eq, Show)
 
 instance Default Config where
-  def = Config def
+  def = Config def def
 
 -- |  Parses a 'Config' value from a given 'Text'
 --    or gives a parsing error message.
@@ -35,7 +44,9 @@ parseConfig = flip parseIniFile $ do
             <*> fieldOf "person-file"   string
             <*> fieldOf "tasks-file"    string
             <*> fieldOf "tracking-file" string
-  return $ Config st
+  srv <- section "server" $
+    Server <$> fieldOf "port" number
+  return $ Config st srv
 
 -- |  Reads a 'Config' value from @config.ini@.
 --    Prints parsing error messages to @STDERR@ when failing.

lib/LiBro/Control.hs

@@ -37,3 +37,55 @@ saveData blocking libroData = do
       storeData =<< liftIO (readMVar libroData)
       _ <- liftIO $ takeMVar blocking
       return True
+
+-- |  Shared libro system state to access data any time.
+data LiBroState = LiBroState
+  { config      :: Config
+  , mvBlocking  :: MVar Blocking
+  , mvData      :: MVar LiBroData
+  }
+
+-- |  Initialization of a 'LiBroState'.
+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'.
+type Action = ReaderT LiBroState IO
+
+-- |  'Config' accessor action.
+lsConfig :: Action Config
+lsConfig = asks config
+
+-- |  Checks whether the system is blocked
+--    and by what type of 'Blocking' action.
+lsBlockedBy :: Action (Maybe Blocking)
+lsBlockedBy = do
+  mvb <- asks mvBlocking
+  lift $ tryTakeMVar mvb
+
+-- |  'LiBroData' accessor action.
+lsData :: Action LiBroData
+lsData = do
+  mvd <- asks mvData
+  lift $ readMVar mvd
+
+-- |  'initData' action.
+lsInitData :: Action ()
+lsInitData = do
+  cfg <- asks config
+  mvb <- asks mvBlocking
+  mvd <- asks mvData
+  lift $ runLiBro cfg $ initData mvb mvd
+
+-- |  'saveData' action.
+lsSaveData :: Action Bool
+lsSaveData = do
+  cfg <- asks config
+  mvb <- asks mvBlocking
+  mvd <- asks mvData
+  lift $ runLiBro cfg $ saveData mvb mvd

lib/LiBro/Data.hs

@@ -50,7 +50,7 @@ type Tasks = Forest Task
 
 -- |  Find all 'Task's assigned to a given 'Person'.
 assignedTasks :: Person -> Tasks -> [Task]
-assignedTasks p = filter ((p `elem`) . assignees) . concatMap flatten
+assignedTasks p = concatMap (filter ((p `elem`) . assignees) . flatten)
 
 -- |  Complete LiBro state in one type
 data LiBroData = LBS

lib/LiBro/Util.hs

@@ -2,9 +2,10 @@
 --    in more than one place.
 module LiBro.Util
   (
-  -- * Tree building
+  -- * Tree utilities
     ParentList
   , readForest
+  , findSubtree
   -- * Counting monad transformer
   , CountingT
   , next
@@ -59,6 +60,13 @@ readForest pairs =
                               Nothing -> []; Just [] -> []
                               Just xs -> fill cs <$> sort xs
 
+-- |  Find the first matching subtree of a forest
+findSubtree :: (a -> Bool) -> Forest a -> Maybe (Tree a)
+findSubtree p = asum . map findTree
+  where findTree t@(Node x cs)
+          | p x       = Just t
+          | otherwise = findSubtree p cs
+
 -- |  Simple monad transformer that allows to read an increasing 'Int'.
 type CountingT m = StateT Int m
 

lib/LiBro/WebService.hs

@@ -0,0 +1,83 @@
+module LiBro.WebService where
+
+import LiBro.Control
+import LiBro.Data
+import LiBro.Util
+import qualified Data.Map as M
+import Data.Tree
+import Data.Aeson
+import Data.Proxy
+import Servant
+import Control.Monad.Reader
+import GHC.Generics
+
+type LiBroHandler = ReaderT LiBroState Handler
+
+runAction :: Action a -> LiBroHandler a
+runAction action = ask >>= liftIO . runReaderT action
+
+data PersonDetails = PersonDetails
+  { person      :: Person
+  , personTasks :: [Task]
+  } deriving Generic
+instance ToJSON PersonDetails
+
+-- JSON-friendly rewrite of Forest/Tree, their ToJSON instance is weird
+type TaskForest = [TaskTree]
+data TaskTree   = TaskTree
+  { task        :: Task
+  , subTasks    :: TaskForest
+  } deriving Generic
+instance ToJSON TaskTree
+
+convertTaskTree :: Tree Task -> TaskTree
+convertTaskTree (Node t ts) = TaskTree t (convertTasksForest ts)
+
+convertTasksForest :: Tasks -> TaskForest
+convertTasksForest = map convertTaskTree
+
+type LiBroAPI =
+        "person"                        :> Get '[JSON]  [Person]
+  :<|>  "person"  :> Capture "pid" Int  :> Get '[JSON]  PersonDetails
+  :<|>  "task"                          :> Get '[JSON]  [Task]
+  :<|>  "task"    :> "tree"             :> Get '[JSON]  TaskForest
+  :<|>  "task"    :> Capture "tid" Int  :> Get '[JSON]  TaskTree
+
+libroServer :: ServerT LiBroAPI LiBroHandler
+libroServer =     hPersonList
+            :<|>  hPersonDetails
+            :<|>  hTaskTopLevelList
+            :<|>  hTaskFullForest
+            :<|>  hTaskDetails
+  where
+        hPersonList :: LiBroHandler [Person]
+        hPersonList = M.elems . persons <$> runAction lsData
+
+        hPersonDetails :: Int -> LiBroHandler PersonDetails
+        hPersonDetails pId = do
+          d <- runAction lsData
+          case M.lookup pId (persons d) of
+            Just p  ->  let ts = assignedTasks p (tasks d)
+                        in  return $ PersonDetails p ts
+            Nothing -> throwError err404 {errBody = "Person not found"}
+
+        hTaskTopLevelList :: LiBroHandler [Task]
+        hTaskTopLevelList = map rootLabel . tasks <$> runAction lsData
+
+        hTaskFullForest :: LiBroHandler TaskForest
+        hTaskFullForest = convertTasksForest . tasks <$> runAction lsData
+
+        hTaskDetails :: Int -> LiBroHandler TaskTree
+        hTaskDetails tId = do
+          result <- findSubtree ((== tId) . tid) . tasks <$> runAction lsData
+          case result of
+            Just tree -> return $ convertTaskTree tree
+            Nothing   -> throwError err404 {errBody = "Task not found"}
+
+libroApi :: Proxy LiBroAPI
+libroApi = Proxy
+
+libro :: LiBroState -> Application
+libro initState =
+  let server = hoistServer libroApi (`runReaderT` initState) libroServer
+  in  serve libroApi server

libro-backend.cabal

@@ -35,12 +35,15 @@ library
   default-extensions: OverloadedStrings
                     , GeneralizedNewtypeDeriving
                     , DeriveGeneric
+                    , DataKinds
+                    , TypeOperators
   exposed-modules:    LiBro.Base
                     , LiBro.Config
                     , LiBro.Data
                     , LiBro.Data.Storage
                     , LiBro.Data.SafeText
                     , LiBro.Control
+                    , LiBro.WebService
                     , LiBro.Util
   build-depends:      aeson
                     , attoparsec
@@ -55,6 +58,8 @@ library
                     , mtl
                     , process
                     , QuickCheck
+                    , servant
+                    , servant-server
                     , temporary
                     , text
                     , unordered-containers
@@ -65,11 +70,13 @@ executable libro-backend
   import:             consumer
   main-is:            Main.hs
   build-depends:      libro-backend
-  hs-source-dirs:     app
+                    , warp
+  hs-source-dirs:     server
 
 test-suite libro-backend-test
   import:             consumer
   default-extensions: OverloadedStrings
+                    , QuasiQuotes
                     , DeriveGeneric
   type:               exitcode-stdio-1.0
   hs-source-dirs:     test
@@ -80,10 +87,13 @@ test-suite libro-backend-test
                     , LiBro.Data.StorageSpec
                     , LiBro.Data.SafeTextSpec
                     , LiBro.ControlSpec
+                    , LiBro.WebServiceSpec
                     , LiBro.UtilSpec
   main-is:            run-all-tests.hs
   build-depends:      libro-backend
                     , hspec
+                    , hspec-wai
+                    , hspec-wai-json
                     , QuickCheck
                     , quickcheck-text
                     , generic-arbitrary
@@ -101,3 +111,4 @@ test-suite libro-backend-test
                     , text
                     , transformers
                     , vector
+                    , wai

server/Main.hs

@@ -0,0 +1,18 @@
+module Main where
+
+import LiBro.Base
+import LiBro.Config
+import LiBro.Control
+import LiBro.WebService
+import Network.Wai.Handler.Warp
+
+configuredMain :: Config -> IO ()
+configuredMain cfg = do
+  let p = port $ server cfg
+  putStrLn $ "Serving LiBro backend on port " ++ show p ++ "."
+  initState <- runLiBro cfg initLiBroState
+  run p $ libro initState
+
+main :: IO ()
+main = readConfig >>= maybe complain configuredMain
+  where complain = putStrLn "Invalid config: aborting"