From c33d9a36ad934b4a1a84557ae4946dc43c6ff8ca Mon Sep 17 00:00:00 2001 From: Alexander Foremny Date: Thu, 20 Feb 2025 12:41:02 +0100 Subject: add `acms serve` --- acms/app/Main.hs | 32 +++++++++++++++- acms/src/ACMS/ACMS.hs | 102 ++++++++++++++++++++------------------------------ 2 files changed, 72 insertions(+), 62 deletions(-) diff --git a/acms/app/Main.hs b/acms/app/Main.hs index 9759660..3dd339c 100644 --- a/acms/app/Main.hs +++ b/acms/app/Main.hs @@ -1,5 +1,6 @@ module Main where +import ACMS.ACMS qualified import ACMS.API.Query qualified import ACMS.API.REST.Collection qualified import Collection @@ -21,6 +22,7 @@ args = Args <$> cmd_ data Cmd = CollectionCmd CollectionCmd | QueryCmd + | ServeCmd ServeOpts cmd_ :: O.Parser Cmd cmd_ = @@ -28,7 +30,9 @@ cmd_ = [ O.command "collection" . O.info collectionCmd $ O.progDesc "Manage content collections", O.command "query" . O.info queryCmd $ - O.progDesc "Manage content through queries" + O.progDesc "Manage content through queries", + O.command "serve" . O.info serveCmd $ + O.progDesc "Serve content repository" ] data CollectionCmd @@ -69,6 +73,30 @@ collectionArg = queryCmd :: O.Parser Cmd queryCmd = pure QueryCmd +data ServeOpts = ServeOpts + { serverPort :: Int, + contentRepositoryPath :: FilePath + } + +serveCmd :: O.Parser Cmd +serveCmd = + ServeCmd + <$> ( ServeOpts + <$> O.option + O.auto + ( O.metavar "PORT" + <> O.showDefault + <> O.value 8081 + <> O.long "port" + <> O.short 'p' + <> O.help "The server port" + ) + <*> O.strArgument + ( O.metavar "PATH" + <> O.help "Path to the content repository" + ) + ) + main :: IO () main = O.execParser (O.info (args <**> O.helper) O.idm) >>= \case @@ -99,3 +127,5 @@ main = LB.putStr . J.encodePretty @J.Value =<< ACMS.API.Query.query . LB.toString =<< LB.getContents + Args {cmd = ServeCmd (ServeOpts {serverPort, contentRepositoryPath})} -> + ACMS.ACMS.run ACMS.ACMS.Config {serverPort, contentRepositoryPath} diff --git a/acms/src/ACMS/ACMS.hs b/acms/src/ACMS/ACMS.hs index 12f8866..58efd5b 100644 --- a/acms/src/ACMS/ACMS.hs +++ b/acms/src/ACMS/ACMS.hs @@ -1,8 +1,11 @@ -module ACMS.ACMS where +module ACMS.ACMS + ( Config (..), + run, + ) +where import AutoTypes qualified as U import AutoTypes.Unify qualified as U -import Control.Applicative ((<**>)) import Control.Concurrent import Control.Concurrent.STM import Control.Exception (throwIO) @@ -32,7 +35,6 @@ import Git.Libgit2 qualified as GB import Network.HTTP.Types.Status qualified as W import Network.Wai qualified as W import Network.Wai.Handler.Warp qualified as W -import Options.Applicative qualified as A import Safe import Store qualified as Q import System.Directory (doesDirectoryExist, makeAbsolute, setCurrentDirectory) @@ -48,31 +50,6 @@ import Version getUUID :: IO U.UUID getUUID = maybe U.nextRandom (const randomIO) =<< lookupEnv "UUID_SEED" -data Args = Args - { cmd :: Cmd - } - -args :: A.Parser Args -args = Args <$> cmd' - -data Cmd = Serve - { serverPort :: Int, - contentRepositoryPath :: FilePath - } - -cmd' :: A.Parser Cmd -cmd' = - A.hsubparser . mconcat $ - [ A.command "serve" . A.info serveCmd $ - A.progDesc "Run webserver" - ] - -serveCmd :: A.Parser Cmd -serveCmd = do - serverPort <- A.option A.auto (A.metavar "PORT" <> A.showDefault <> A.value 8081 <> A.long "port" <> A.short 'p' <> A.help "The server port") - contentRepositoryPath <- A.strArgument (A.metavar "PATH" <> A.help "Path to the content repository") - pure Serve {..} - data Repo = Repo { commits :: [Commit] } @@ -296,42 +273,45 @@ buildRefMap = do ) (M.toList referencees) -main :: IO () -main = do +data Config = Config + { serverPort :: Int, + contentRepositoryPath :: FilePath + } + +run :: Config -> IO () +run (Config {serverPort, contentRepositoryPath}) = do uuidSeed <- lookupEnv "UUID_SEED" maybe (pure ()) (setStdGen . mkStdGen) $ readMay =<< uuidSeed - A.execParser (A.info (args <**> A.helper) A.idm) >>= \case - Args {cmd = Serve {contentRepositoryPath, serverPort}} -> do - contentRepositoryPath' <- makeAbsolute contentRepositoryPath - contentRepositoryPathExists <- doesDirectoryExist (contentRepositoryPath' ".git") - - unless contentRepositoryPathExists $ do - logStderr $ "Content repository '" ++ contentRepositoryPath ++ "' is not a git repository." - exitFailure - - setCurrentDirectory contentRepositoryPath' - - let root = "." - ref = "refs/heads/master" - repoT <- newEmptyTMVarIO - - stopM <- newEmptyMVar - flip forkFinally (putMVar stopM) do watch repoT root ref - mapM - ( \hostPref -> flip forkFinally (putMVar stopM) do - W.runSettings - ( W.defaultSettings - & W.setPort serverPort - & W.setHost hostPref - ) - . restApi root ref repoT - . queryApi root ref repoT - $ (\_ resp -> resp (W.responseLBS W.status404 [] "Not found")) - ) - ["!4", "::1"] -- XXX note !6 does not work.. - logStderr ("Serving " ++ contentRepositoryPath' ++ " on port " ++ show serverPort ++ ".") - either throwIO pure =<< takeMVar stopM + contentRepositoryPath' <- makeAbsolute contentRepositoryPath + contentRepositoryPathExists <- doesDirectoryExist (contentRepositoryPath' ".git") + + unless contentRepositoryPathExists $ do + logStderr $ "Content repository '" ++ contentRepositoryPath ++ "' is not a git repository." + exitFailure + + setCurrentDirectory contentRepositoryPath' + + let root = "." + ref = "refs/heads/master" + repoT <- newEmptyTMVarIO + + stopM <- newEmptyMVar + flip forkFinally (putMVar stopM) do watch repoT root ref + mapM + ( \hostPref -> flip forkFinally (putMVar stopM) do + W.runSettings + ( W.defaultSettings + & W.setPort serverPort + & W.setHost hostPref + ) + . restApi root ref repoT + . queryApi root ref repoT + $ (\_ resp -> resp (W.responseLBS W.status404 [] "Not found")) + ) + ["!4", "::1"] -- XXX note !6 does not work.. + logStderr ("Serving " ++ contentRepositoryPath' ++ " on port " ++ show serverPort ++ ".") + either throwIO pure =<< takeMVar stopM data InvalidSchemaVersion = InvalidSchemaVersion String deriving (Show) -- cgit v1.2.3