From b20ee0b7de28ca261a76f1e5a7ed4c7743137ab2 Mon Sep 17 00:00:00 2001
From: iko <ilyakooo0@gmail.com>
Date: Tue, 25 Feb 2020 14:30:48 +0300
Subject: [PATCH] Added options parser

---
 app/Main.hs          | 29 +++++++++++++++++++++++------
 package.yaml         |  1 +
 src/Server.hs        |  6 +++---
 src/Server/Config.hs |  4 ++--
 4 files changed, 29 insertions(+), 11 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 8fe4e05..08edc52 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,13 +1,30 @@
 module Main (main) where
 
 import qualified Data.ByteString.Char8 as BS
-import Data.Yaml
+import Data.Yaml (encode)
+import Options.Applicative
 import Server
 import Server.Config
-import System.Environment
 
 main :: IO ()
-main = getArgs >>= \case
-  [] -> runServer
-  ["default"] -> putStrLn . BS.unpack . encode $ defaultConfig
-  xs -> error . show $ xs
+main =
+  execParser (info (getOptions <**> helper) fullDesc) >>= \case
+    PrintDefaultConfig -> putStrLn . BS.unpack . encode $ defaultConfig
+    RunServer config -> runServer config
+
+data Run
+  = PrintDefaultConfig
+  | RunServer FilePath
+
+getOptions :: Parser Run
+getOptions =
+  subparser
+    ( command "default" (info (pure PrintDefaultConfig <**> helper) fullDesc)
+    )
+    <|> ( RunServer
+            <$> strOption
+              ( long "config"
+                  <> help "Path to yaml config file."
+                  <> value "config.yaml"
+              )
+        )
diff --git a/package.yaml b/package.yaml
index 8c4eba7..5258cb4 100644
--- a/package.yaml
+++ b/package.yaml
@@ -66,6 +66,7 @@ executables:
     - sc-build
     - bytestring
     - yaml
+    - optparse-applicative
   sc-build-migrations:
     main:                Main.hs
     source-dirs:         migrations
diff --git a/src/Server.hs b/src/Server.hs
index a595b2d..653b542 100644
--- a/src/Server.hs
+++ b/src/Server.hs
@@ -161,9 +161,9 @@ instance MonadError ServerError (ServerM schema) where
 server :: ServerT API (ServerM Schema)
 server = (webhookInstallation :<|> webhookPushEvent) :<|> getSubmissionR :<|> retestSubmission :<|> getResults
 
-runServer :: IO ()
-runServer = do
-  c@Config {..} <- getConfig
+runServer :: FilePath -> IO ()
+runServer config = do
+  c@Config {..} <- getConfig config
   print c
   pem <- BS.readFile appPkPemPath
   appPkPem <- case readRsaPem pem of
diff --git a/src/Server/Config.hs b/src/Server/Config.hs
index 274a7e2..2ea1667 100644
--- a/src/Server/Config.hs
+++ b/src/Server/Config.hs
@@ -71,8 +71,8 @@ defaultConfig =
       githubContext = "MY CI NAME"
     }
 
-getConfig :: IO Config
-getConfig = decodeFileThrow "config.yaml"
+getConfig :: FilePath -> IO Config
+getConfig = decodeFileThrow
 
 -- getConfig :: IO Config
 -- getConfig =