add `acms serve`

1 files changed, 41 insertions, 61 deletions

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)