Add CLI (#376)

* Add CLI

* fix makefile

* Add comments

* Update back/src/Guide/Cli.hs

Co-Authored-By: Artyom Kazak <artyom@aelve.com>

* Update back/src/Guide/Cli.hs

Co-Authored-By: Artyom Kazak <artyom@aelve.com>

* Refactor on review

* Fix tests

* Rename some functions, add comments, minor formatting

Makefile

@@ -26,7 +26,7 @@ back/test-db: back
 	mv guide-database back/state
 	(cd back/state && gzip -d *.gz)
 	(cd back/state && git branch -v && git status && ls)
-	stack exec --cwd back -- guide --dry-run
+	stack exec --cwd back -- guide dry-run
 	rm -rf back/state
 	if [ -d back/state-old ]; then mv back/state-old back/state; fi
 

back/guide.cabal

@@ -56,6 +56,7 @@ library
       Guide.Api.Error
       Guide.Api.Utils
       Guide.Api.Guider
+    Guide.Cli
     Guide.Database
       Guide.Database.Add
       Guide.Database.Connection
@@ -130,6 +131,7 @@ library
                      , fmt
                      , friendly-time == 0.4.*
                      , generics-eot
+                     , gitrev
                      , hashable
                      , hasql
                      , hasql-transaction
@@ -151,6 +153,7 @@ library
                      , neat-interpolation == 0.3.*
                      , network
                      , network-uri
+                     , optparse-applicative
                      , patches-vector
                      , profunctors
                      , random >= 1.1
@@ -211,6 +214,9 @@ library
                      , TemplateHaskellQuotes
                      , ScopedTypeVariables
 
+  other-modules:       Paths_guide
+  autogen-modules:     Paths_guide
+
 test-suite tests
   main-is:             Main.hs
   other-modules:

back/src/Guide/Cli.hs

@@ -0,0 +1,106 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+
+-- | Guide's command line interface.
+--
+-- Run @guide --help@ to see available commands.
+module Guide.Cli
+       ( Command (..)
+       , parseCommandLine
+       ) where
+
+
+import Imports
+
+import Data.Version (showVersion)
+import Development.GitRev (gitCommitDate, gitDirty, gitHash)
+import Options.Applicative (Parser)
+
+import Paths_guide (version)
+
+import qualified Data.Text as T
+import qualified Options.Applicative as Opt
+
+
+-- | All available commands
+data Command
+    = RunServer             -- ^ run server
+    | DryRun                -- ^ load database and exit
+    | LoadPublic FilePath   -- ^ load PublicDB, create base on it and exit
+
+----------------------------------------------------------------------------
+-- Parsers
+----------------------------------------------------------------------------
+
+{-
+To see help run command:
+$ guide --help
+Usage: guide [-v|--version] [COMMAND]
+
+Available options:
+  -h,--help                Show this help text
+  -v,--version             Show Guide version
+
+Available commands:
+  run                      Run server
+  dry-run                  Load database and exit
+  load-public              Load PublicDB, create base on it and exit
+
+NOTE:
+Command 'guide' is the same as 'guide run'
+
+----------------------------------------------------------------------------
+
+$ guide load-public --help
+Usage: guide load-public (-p|--path FILEPATH)
+  Load PublicDB, create base on it and exit
+
+Available options:
+  -h,--help                Show this help text
+  -p,--path FILEPATH       Public DB file name
+
+-}
+
+-- | Parse the command line of the application.
+--
+-- If no command is supplied, we say the command was 'RunServer'.
+parseCommandLine :: IO Command
+parseCommandLine = Opt.execParser
+    $ Opt.info (Opt.helper <*> versionOption <*> (pure RunServer <|> commandsParser))
+    $ Opt.fullDesc
+
+-- | All possible commands.
+commandsParser :: Parser Command
+commandsParser = Opt.subparser
+    $  Opt.command "run" (infoP (pure RunServer) "Start server")
+    <> Opt.command "dry-run" (infoP (pure DryRun) "Load database and exit")
+    <> Opt.command "load-public"
+         (infoP loadPublicParser "Load PublicDB, create base on it and exit")
+  where
+    infoP parser desc = Opt.info (Opt.helper <*> parser) $ Opt.progDesc desc
+
+-- | Parse the arguments of 'LoadPublic'.
+loadPublicParser :: Parser Command
+loadPublicParser = LoadPublic <$> Opt.strOption
+    (  Opt.long "path"
+    <> Opt.short 'p'
+    <> Opt.help "Public DB file name"
+    <> Opt.metavar "FILEPATH"
+    )
+
+-- | Parse version option.
+versionOption :: Parser (a -> a)
+versionOption = Opt.infoOption guideVersion
+    $ Opt.long "version"
+   <> Opt.short 'v'
+   <> Opt.help "Show Guide version"
+
+-- | A message with current Guide version and Git info.
+guideVersion :: String
+guideVersion = T.unpack $ T.intercalate "\n" $
+    [sVersion, sHash, sDate] ++ [sDirty | $(gitDirty)]
+  where
+    sVersion = "Aelve Guide " <> "v" <> T.pack (showVersion version)
+    sHash = " ➤ " <> "Git revision: " <> $(gitHash)
+    sDate = " ➤ " <> "Commit date:  " <> $(gitCommitDate)
+    sDirty = "There are non-committed files."

back/src/Guide/Main.hs

@@ -6,15 +6,15 @@
 {-# LANGUAGE TypeOperators       #-}
 
 -- | Description : The main module that starts the server.
---
--- This module provides two functions that are of interest:
---
---   * Run 'main' to actually start the server.
---   * Run 'mainWith' to run it with a custom config.
 module Guide.Main
 (
+  -- * Main
   main,
-  mainWith,
+
+  -- * All supported commands
+  runServer,
+  dryRun,
+  loadPublic,
 )
 where
 
@@ -23,8 +23,6 @@ import Imports
 
 -- Concurrent
 import Control.Concurrent.Async
--- Lists
-import Safe (headDef)
 -- Monads and monad transformers
 import Control.Monad.Morph
 -- Web
@@ -51,10 +49,11 @@ import Data.HVect hiding (length)
 
 import Guide.Api (runApiServer)
 import Guide.App
+import Guide.Cli
 import Guide.Config
 import Guide.Handlers
-import Guide.Logger
 import Guide.JS (JS (..), allJSFunctions)
+import Guide.Logger
 import Guide.Routes (authRoute, haskellRoute)
 import Guide.ServerStuff
 import Guide.Session
@@ -73,8 +72,8 @@ import qualified Web.Spock as Spock
 {- Note [acid-state]
 ~~~~~~~~~~~~~~~~~~~~
 
-This application doesn't use a database – instead, it uses
-acid-state. Acid-state works as follows:
+Until we are done with migrating to PostgreSQL, this app uses acid-state.
+Acid-state works as follows:
 
   * Everything is stored as Haskell values (in particular, all data is stored
     in 'GlobalState').
@@ -108,48 +107,31 @@ acid-state. Acid-state works as follows:
 
 -}
 
--- TODO: rename GlobalState to DB, and DB to AcidDB
-
-lucidWithConfig
-  :: (MonadIO m, HasSpock (ActionCtxT cxt m),
-      SpockState (ActionCtxT cxt m) ~ ServerState)
-  => HtmlT (ReaderT Config IO) a -> ActionCtxT cxt m a
-lucidWithConfig x = do
-  cfg <- getConfig
-  lucidIO (hoist (flip runReaderT cfg) x)
-
 ----------------------------------------------------------------------------
--- The entry point
+-- Main
 ----------------------------------------------------------------------------
 
--- | Start the site.
+-- | Parse an input and run a command.
 main :: IO ()
-main = mainWith =<< readConfig
+main = do
+  command <- parseCommandLine
+  config <- readConfig
+  runCommand config command
 
--- | Start the site with a specific 'Config'.
-mainWith :: Config -> IO ()
-mainWith config@Config{..} = withLogger config $ \logger -> do
-  args <- getArgs
-  let option = headDef "" args
-  when (option == "--dry-run") $ do
-    db :: DB <- openLocalStateFrom "state/" (error "couldn't load state")
-    logDebugIO logger "loaded the database successfully"
-    closeAcidState db
-    exitSuccess
-  -- USAGE: --load-public <filename>
-  -- loads PublicDB from <filename>, converts it to GlobalState, saves & exits
-  when (option == "--load-public") $ do
-    let path = fromMaybe
-          (error "you haven't provided public DB file name")
-          (args ^? ix 1)
-    (Cereal.runGet SafeCopy.safeGet <$> BS.readFile path) >>= \case
-      Left err -> error err
-      Right publicDB -> do
-        db <- openLocalStateFrom "state/" emptyState
-        Acid.update db (ImportPublicDB publicDB)
-        createCheckpointAndClose' db
-        logDebugIO logger "PublicDB imported to GlobalState"
-        exitSuccess
+-- | Run a specific 'Command' with the given 'Config'.
+runCommand :: Config -> Command -> IO ()
+runCommand config = \case
+  RunServer -> runServer config
+  DryRun -> dryRun config
+  LoadPublic path -> loadPublic config path
+
+----------------------------------------------------------------------------
+-- Commands
+----------------------------------------------------------------------------
+
+-- | Start the server.
+runServer :: Config -> IO ()
+runServer config@Config{..} = withLogger config $ \logger -> do
   installTerminationCatcher =<< myThreadId
   workAsync <- async $ withDB (pure ()) $ \db -> do
     hSetBuffering stdout NoBuffering
@@ -163,18 +145,52 @@ mainWith config@Config{..} = withLogger config $ \logger -> do
   forever (threadDelay (1000000 * 60))
     `finally` cancel workAsync
 
--- Create a checkpoint every six hours. Note: if nothing was changed, the
+-- | Load database from @state/@, check that it can be loaded successfully,
+-- and exit.
+dryRun :: Config -> IO ()
+dryRun config = withLogger config $ \logger -> do
+  db :: DB <- openLocalStateFrom "state/" (error "couldn't load state")
+  logDebugIO logger "loaded the database successfully"
+  closeAcidState db
+  exitSuccess
+
+-- | Load 'PublicDB' from given file, create acid-state database from it,
+-- and exit.
+loadPublic :: Config -> FilePath -> IO ()
+loadPublic config path = withLogger config $ \logger ->
+  (Cereal.runGet SafeCopy.safeGet <$> BS.readFile path) >>= \case
+    Left err -> error err
+    Right publicDB -> do
+      db <- openLocalStateFrom "state/" emptyState
+      Acid.update db (ImportPublicDB publicDB)
+      createCheckpointAndClose' db
+      logDebugIO logger "PublicDB imported to GlobalState"
+      exitSuccess
+
+----------------------------------------------------------------------------
+-- Helpers
+----------------------------------------------------------------------------
+
+lucidWithConfig
+  :: (MonadIO m, HasSpock (ActionCtxT cxt m),
+      SpockState (ActionCtxT cxt m) ~ ServerState)
+  => HtmlT (ReaderT Config IO) a -> ActionCtxT cxt m a
+lucidWithConfig x = do
+  cfg <- getConfig
+  lucidIO (hoist (flip runReaderT cfg) x)
+
+-- | Create a checkpoint every six hours. Note: if nothing was changed, the
 -- checkpoint won't be created, which saves us some space.
 checkPoint :: DB -> IO b
 checkPoint db = forever $ do
   createCheckpoint' db
   threadDelay (1000000 * 3600 * 6)
 
--- Run the API (new server)
+-- | Run the API (new server)
 runNewApi :: Logger -> Config -> AcidState GlobalState -> IO ()
 runNewApi logger = runApiServer (pushLogger "api" logger)
 
--- Run the Spock (old server).
+-- | Run Spock (old server).
 runOldServer :: Logger -> Config -> DB -> IO ()
 runOldServer logger config@Config{..} db = do
   let serverState = ServerState {
@@ -356,7 +372,7 @@ adminHook = do
     then return (IsAdmin :&: oldCtx)
     else Spock.text "Not authorized."
 
--- |Redirect the user to a given path if they are logged in.
+-- | Redirect the user to a given path if they are logged in.
 authRedirect :: Text -> GuideAction ctx a -> GuideAction ctx a
 authRedirect path action = do
   user <- getLoggedInUser

back/tests/WebSpec.hs

@@ -530,7 +530,7 @@ run logFile ts = do
         when exold' $ renameDirectory "state-old" "state"
 
   bracket prepare finish $ \_ -> do
-    withAsync (Guide.Main.mainWith config) $ \_ -> hspec ts
+    withAsync (Guide.Main.runServer config) $ \_ -> hspec ts
 
 _site :: IO ()
 _site = run "" $ do