Merge pull request #28 from yaitskov/command-line-params

Parse existing args with optparse-applicative

app/astro/package.yaml

@@ -114,8 +114,11 @@ dependencies:
 - http-client-tls
 - data-default
 - generic-lens
+- optparse-applicative
+- network-uri
 - Hydra
 
+
 library:
   source-dirs:
   - src

app/astro/src/Astro/Client/Common.hs

@@ -22,8 +22,7 @@ import qualified Astro.API             as API
 
 data TcpConn = DummyTcpConn
 
-data ReportChannel = TcpChannel | HttpChannel
-  deriving (Show, Read)
+data ReportChannel = TcpChannel | HttpChannel deriving Show
 
 data Approach
   = SH    -- ^ ServiceHandle
@@ -33,7 +32,7 @@ data Approach
   | FT2   -- ^ Final Tagless 2 (mtl-style)
   | CEFM  -- ^ Church Encoded Free Monad
   | GADT  -- ^ GADT
-  deriving (Show, Read)
+  deriving (Show, Read, Bounded, Enum)
 
 meteors  :: Maybe Int -> Maybe Int -> ClientM Meteors
 meteor   :: API.MeteorTemplate     -> ClientM MeteorId

app/astro/src/Astro/ConsoleOptions.hs

@@ -0,0 +1,105 @@
+module Astro.ConsoleOptions
+    ( ConsoleOptions (..)
+    , Command (..)
+    , ServerOptions (..)
+    , ClientOptions (..)
+    , RelDbOptions
+    , parseConsoleOptions
+    ) where
+
+import           Hydra.Prelude
+
+import           Data.Semigroup ((<>))
+import           Network.URI
+import           Options.Applicative
+
+import           Astro.Client.Common        (ReportChannel(..), Approach(..))
+
+data ConsoleOptions = ConsoleOptions Command deriving (Show)
+
+data Command
+    = Server ServerOptions
+    | Client ClientOptions
+      deriving (Show)
+
+data ServerOptions = ServerOptions
+    { soRelDbOptions :: RelDbOptions
+    } deriving (Show)
+
+data RelDbOptions = UseSqliteDb String | UseMySqlDb URI deriving (Show)
+
+data ClientOptions = ClientOptions
+    { coApproach :: Approach,
+      coReportChannel :: ReportChannel
+    } deriving (Show)
+
+parseConsoleOptions :: IO ConsoleOptions
+parseConsoleOptions
+    = execParser $ info (consoleOptionParser <**> helper) fullDesc
+
+consoleOptionParser =
+    ConsoleOptions
+    <$> subparser
+            (  command "server"
+                 (info serverOptionParser (progDesc "runs as server"))
+            <> command "client"
+                 (info clientOptionParser (progDesc "runs as client"))
+            )
+
+serverOptionParser :: Parser Command
+serverOptionParser = (Server . ServerOptions) <$> relDbParser
+    where
+      relDbParser = sqliteParser <|> mysqlParser
+      sqliteParser = option filePathParser
+                     (  long "sqlite"
+                     <> metavar "DB"
+                     <> help "path to sqlite file"
+                     <> showDefault
+                     <> value (UseSqliteDb "/tmp/astro.db")
+                     )
+
+      mysqlParser = option uriParser (  long "mysql"
+                                     <> short 'u'
+                                     <> metavar "URI"
+                                     <> help "uri to database"
+                                     <> showDefault
+                                     <> value defaultUri
+                                     )
+      defaultUri = UseMySqlDb
+                   $ fromJust (parseURI "mysql://root@localhost:3600/astro")
+
+filePathParser = eitherReader parse
+    where
+      parse path = Right . UseSqliteDb $ path
+
+uriParser = eitherReader parse
+    where
+      parse uri = maybe err (Right . UseMySqlDb) parsed
+          where
+            err = Left $ "Bad URI " ++ uri
+            parsed = parseURI uri
+
+
+
+clientOptionParser :: Parser Command
+clientOptionParser
+    = Client
+      <$> (ClientOptions
+              <$> option auto (  long "approach"
+                      <> help ("approach one of: "
+                               ++ show ([minBound .. maxBound] :: [Approach]))
+                      <> showDefault
+                      <> value SH
+                      )
+              <*> option channelParser
+                      (  long "channel"
+                      <> help "channel: http or tcp"
+                      <> showDefault
+                      <> value HttpChannel
+                      ))
+
+channelParser = eitherReader parse
+    where
+      parse "http" = Right HttpChannel
+      parse "tcp" = Right TcpChannel
+      parse o  = Left $ "Bad channel [" ++ o ++ "] must be [http] or [tcp]"

app/astro/src/Main.hs

@@ -5,12 +5,12 @@
 module Main where
 
 import           Hydra.Prelude
-import           System.Environment         (getArgs)
 
 import qualified Hydra.Runtime              as R
 import qualified Hydra.Interpreters         as R
 
 import           Astro.Config               (loggerCfg)
+import           Astro.ConsoleOptions
 import           Astro.Server               (runAstroServer)
 import           Astro.Client.Common        (ReportChannel(..), Approach(..))
 import qualified Astro.Client.ServiceHandle as SH
@@ -20,9 +20,9 @@ import qualified Astro.Client.FinalTagless  as FT
 import qualified Astro.Client.FinalTagless2 as FT2
 import qualified Astro.Client.GADT          as GADT
 
-
-runAstroClient :: Approach -> ReportChannel -> IO ()
-runAstroClient appr ch = R.withAppRuntime (Just loggerCfg) (\rt -> R.runAppL rt app')
+runAstroClient :: ClientOptions -> IO ()
+runAstroClient (ClientOptions appr ch)
+    = R.withAppRuntime (Just loggerCfg) (\rt -> R.runAppL rt app')
   where
     app' = app'' appr ch
 
@@ -36,21 +36,9 @@ runAstroClient appr ch = R.withAppRuntime (Just loggerCfg) (\rt -> R.runAppL rt
     app'' FT2  TcpChannel  = FT2.consoleApp @(FT2.TcpAstroService)
     app'' _ _    = error $ "Approach not yet implemented: " <> show appr
 
-getChannel :: String -> ReportChannel
-getChannel "http" = HttpChannel
-getChannel "tcp"  = TcpChannel
-getChannel ch     = error $ show $ "Channel not supported: " <> ch <> " Supported: http tcp"
-
-getApproach :: String -> Approach
-getApproach apprStr = case readMaybe apprStr of
-  Just appr -> appr
-  Nothing   -> error $ show $ "Approach not supported: " <> apprStr <> " Supported: SH RT FM FT FT2 GADT"
-
 main :: IO ()
 main = do
-  args <- getArgs
-  case args of
-    (chan : appr : _) -> runAstroClient (getApproach appr) (getChannel chan)
-    ("client" : _)    -> runAstroClient SH HttpChannel
-    ("server" : _)    -> runAstroServer
-    _                 -> putStrLn @String "Args not recognized."
+  (ConsoleOptions cmd) <- parseConsoleOptions
+  case cmd of
+    Client cliOpts -> runAstroClient cliOpts
+    Server _   -> runAstroServer