add `acms serve`

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)