diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 2601972..a183f4f 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.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 diff --git a/.gitignore b/.gitignore index 72b1946..4caa3f7 100644 --- a/.gitignore +++ b/.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 diff --git a/Makefile b/Makefile index 82e613a..1c7f3f4 100644 --- a/Makefile +++ b/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 diff --git a/README.md b/README.md index b7abd22..97716a1 100644 --- a/README.md +++ b/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 diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 index ef52089..0000000 --- a/app/Main.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where - -main :: IO () -main = putStrLn "42" diff --git a/config.ini b/config.ini index 2ed888e..6bd6409 100644 --- a/config.ini +++ b/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 diff --git a/lib/LiBro/Config.hs b/lib/LiBro/Config.hs index 1e6a3c5..a906cf7 100644 --- a/lib/LiBro/Config.hs +++ b/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. diff --git a/lib/LiBro/Control.hs b/lib/LiBro/Control.hs index ef89a53..85feb4d 100644 --- a/lib/LiBro/Control.hs +++ b/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 diff --git a/lib/LiBro/Data.hs b/lib/LiBro/Data.hs index 5a3b89f..1878c9b 100644 --- a/lib/LiBro/Data.hs +++ b/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 diff --git a/lib/LiBro/Util.hs b/lib/LiBro/Util.hs index e374501..99d2de4 100644 --- a/lib/LiBro/Util.hs +++ b/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 diff --git a/lib/LiBro/WebService.hs b/lib/LiBro/WebService.hs new file mode 100644 index 0000000..08d4710 --- /dev/null +++ b/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 diff --git a/libro-backend.cabal b/libro-backend.cabal index 480480b..81e974f 100644 --- a/libro-backend.cabal +++ b/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 diff --git a/server/Main.hs b/server/Main.hs new file mode 100644 index 0000000..6c279c1 --- /dev/null +++ b/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" diff --git a/test/LiBro/ConfigSpec.hs b/test/LiBro/ConfigSpec.hs index 28a2123..b20c47a 100644 --- a/test/LiBro/ConfigSpec.hs +++ b/test/LiBro/ConfigSpec.hs @@ -20,22 +20,28 @@ import System.IO.Silently writeConfig :: Config -> Text writeConfig c = T.unlines [ "[storage]" - , "directory = " <> T.pack (directory s) - , "person-file = " <> T.pack (personFile s) - , "tasks-file = " <> T.pack (tasksFile s) - , "tracking-file = " <> T.pack (trackingFile s) + , "directory = " <> T.pack (directory st) + , "person-file = " <> T.pack (personFile st) + , "tasks-file = " <> T.pack (tasksFile st) + , "tracking-file = " <> T.pack (trackingFile st) + , "" + , "[server]" + , "port = " <> T.pack (show $ port srv) ] <> "\n" - where s = storage c + where st = storage c + srv = server c instance Arbitrary Config where arbitrary = do - st <- Storage <$> name <*> name <*> name <*> name - return $ Config st - where chars = [choose ('a','z'), choose ('A','Z'), return '/'] - name = do a <- oneof chars - z <- oneof chars - as <- listOf $ oneof (return ' ' : chars) + st <- Storage <$> aname <*> aname <*> aname <*> aname + srv <- Server <$> aport + return $ Config st srv + where chars = '/' : ['a'..'z'] ++ ['A'..'Z'] + aname = do a <- elements chars + z <- elements chars + as <- listOf $ elements (' ' : chars) return (a : as ++ [z]) + aport = elements [1024 .. 49151] -- Wikipedia "Registered port" spec :: Spec spec = describe "INI file configuration" $ do @@ -51,6 +57,9 @@ defaultConfig = describe "Default config values" $ do it "person file" $ personFile st `shouldBe` "persons.xlsx" it "tasks file" $ tasksFile st `shouldBe` "tasks.xlsx" it "tracking file" $ trackingFile st `shouldBe` "tracking.xlsx" + describe "Server configuration" $ do + let srv = server dc + it "port" $ port srv `shouldBe` 8080 where dc = def :: Config parsing :: Spec @@ -58,7 +67,9 @@ parsing = describe "Configuration parsing" $ do context "With simple values" $ it "parse correct simple values" $ do - let simple = Config $ Storage "foo" "bar" "baz" "quux" + let simple = Config + (Storage "foo" "bar" "baz" "quux") + (Server 1742) parseConfig (writeConfig simple) `shouldBe` Right simple context "With invalid ini input" $ @@ -73,7 +84,9 @@ reading :: Spec reading = describe "Reading configuration from file" $ do context "With existing test config file" $ do - let simple = Config $ Storage "bar" "baz" "quux" "quuux" + let simple = Config + (Storage "bar" "baz" "quux" "quuux") + (Server 4217) config <- runIO $ withSystemTempFile "config.ini" $ \fp h -> do hPutStr h (T.unpack $ writeConfig simple) >> hClose h readConfigFrom fp diff --git a/test/LiBro/UtilSpec.hs b/test/LiBro/UtilSpec.hs index ade6ee0..abbafb1 100644 --- a/test/LiBro/UtilSpec.hs +++ b/test/LiBro/UtilSpec.hs @@ -18,6 +18,7 @@ import System.IO.Temp spec :: Spec spec = describe "Helper stuff" $ do forestFromParentList + findInForest countingT xlsx guarding @@ -35,6 +36,31 @@ forestFromParentList = describe "Read Forest from parent list" $ do , Node 42 [ Node 84 [ Node (168 :: Int) [] ]] ] +findInForest :: Spec +findInForest = describe "Find matching subtrees in a forest" $ do + let forest = [ Node 2 [ Node 4 [Node 8 []], Node 6 [Node 12 [Node 24 []]]] + , Node 3 [ Node 6 [Node 12 []], Node 9 [Node 18 [], Node 27 []]] + , Node 5 [ Node 10 []] + ] :: Forest Int + -- runIO $ putStr $ drawForest $ map (fmap show) forest + + context "Nothing to find" $ do + it "Get Nothing from empty forest" $ + findSubtree even ([] :: Forest Int) `shouldBe` Nothing + it "Nothing matches" $ + findSubtree (> 42) forest `shouldBe` Nothing + + context "Finding subtrees" $ do + it "Catch-all predicate: first tree" $ + findSubtree (const True) forest `shouldBe` Just (head forest) + it "Find the first '6' subtree" $ + findSubtree (== 6) forest `shouldBe` Just (Node 6 [Node 12 [Node 24[]]]) + it "Find the first odd subtree" $ + findSubtree odd forest `shouldBe` + Just ( Node 3 [ Node 6 [Node 12 []] + , Node 9 [Node 18 [], Node 27 []] + ]) + countingT :: Spec countingT = describe "The CountingT 'monad transformer'" $ do let nextTimes n = replicateM n next diff --git a/test/LiBro/WebServiceSpec.hs b/test/LiBro/WebServiceSpec.hs new file mode 100644 index 0000000..43dc710 --- /dev/null +++ b/test/LiBro/WebServiceSpec.hs @@ -0,0 +1,126 @@ +module LiBro.WebServiceSpec where + +import Test.Hspec +import Test.Hspec.Wai +import Test.Hspec.Wai.JSON + +import LiBro.Base +import LiBro.Config +import LiBro.Control +import LiBro.WebService +import Data.Default + +spec :: Spec +spec = describe "RESTful JSON web service" $ do + listings + +listings :: Spec +listings = describe "Simple data listing" $ with lws $ do + + context "Person listing endpoints" $ do + + describe "Person listing" $ do + it "Correct list" $ do + get "/person" `shouldRespondWith` + [json|[ + {"pid": 1, "name": "Foo Bar", "email": "foo@bar.com"}, + {"pid": 2, "name": "Baz Quux", "email": "baz@quux.com"} + ]|] + {matchStatus = 200} + + describe "details" $ do + it "Correct details" $ do + get "/person/2" `shouldRespondWith` + [json|{ + "person": {"pid": 2, "name": "Baz Quux", "email": "baz@quux.com"}, + "personTasks": [ + {"tid": 17, "title": "t17", "description": "d17", "assignees": [ + {"pid": 1, "name": "Foo Bar", "email": "foo@bar.com"}, + {"pid": 2, "name": "Baz Quux", "email": "baz@quux.com"} + ]}, + {"tid": 37, "title": "t37", "description": "d37", "assignees": [ + {"pid": 2, "name": "Baz Quux", "email": "baz@quux.com"} + ]} + ] + }|] + {matchStatus = 200} + + it "404 if person does not exist" $ do + get "/person/42" `shouldRespondWith` + "Person not found" + {matchStatus = 404} + + context "Task listing endpoints" $ do + + describe "Top level tasks" $ do + it "Correct list" $ do + get "/task" `shouldRespondWith` + [json|[ + {"tid": 17, "title": "t17", "description": "d17", "assignees": [ + {"pid": 1, "name": "Foo Bar", "email": "foo@bar.com"}, + {"pid": 2, "name": "Baz Quux", "email": "baz@quux.com"} + ]} + ]|] + {matchStatus = 200} + + describe "Full task hierarchy" $ do + it "Correct forest" $ do + get "/task/tree" `shouldRespondWith` + [json|[ + { "task": {"tid": 17, "title": "t17", "description": "d17", "assignees": [ + {"pid": 1, "name": "Foo Bar", "email": "foo@bar.com"}, + {"pid": 2, "name": "Baz Quux", "email": "baz@quux.com"} + ]}, + "subTasks": [ + { "task": {"tid": 37, "title": "t37", "description": "d37", "assignees": [ + {"pid": 2, "name": "Baz Quux", "email": "baz@quux.com"} + ]}, + "subTasks": [] + }, + { "task": {"tid": 42, "title": "t42", "description": "d42", "assignees": []}, + "subTasks": [] + } + ] + } + ]|] + {matchStatus = 200} + + describe "Subforest of a given task" $ do + + it "Task is a leaf" $ do + get "/task/37" `shouldRespondWith` + [json|{ + "task": {"tid": 37, "title": "t37", "description": "d37", "assignees": [ + {"pid": 2, "name": "Baz Quux", "email": "baz@quux.com"} + ]}, + "subTasks": [] + }|] + {matchStatus = 200} + + it "Task is an inner node" $ do + get "/task/17" `shouldRespondWith` + [json|{ + "task": {"tid": 17, "title": "t17", "description": "d17", "assignees": [ + {"pid": 1, "name": "Foo Bar", "email": "foo@bar.com"}, + {"pid": 2, "name": "Baz Quux", "email": "baz@quux.com"} + ]}, + "subTasks": [ + { "task": {"tid": 37, "title": "t37", "description": "d37", "assignees": [ + {"pid": 2, "name": "Baz Quux", "email": "baz@quux.com"} + ]}, + "subTasks": [] + }, + { "task": {"tid": 42, "title": "t42", "description": "d42", "assignees": []}, + "subTasks": [] + } + ] + }|] + {matchStatus = 200} + + it "404 if task does not exist" $ do + get "/task/666" `shouldRespondWith` + "Task not found" + {matchStatus = 404} + + where lws = libro <$> runLiBro cfg initLiBroState + cfg = Config (def {directory = "test/storage-files/data"}) def diff --git a/test/run-all-tests.hs b/test/run-all-tests.hs index d5459a5..a048e30 100644 --- a/test/run-all-tests.hs +++ b/test/run-all-tests.hs @@ -10,6 +10,7 @@ import qualified LiBro.ConfigSpec as Config import qualified LiBro.ControlSpec as Control import qualified LiBro.TestUtilSpec as TestUtil import qualified LiBro.UtilSpec as Util +import qualified LiBro.WebServiceSpec as WebService withLibreOffice :: IO () -> IO () withLibreOffice runTests = do @@ -31,3 +32,4 @@ main = hspec $ aroundAll_ withLibreOffice $ do Control.spec TestUtil.spec Util.spec + WebService.spec