add configuration options

app/AppTypes.hs

@@ -0,0 +1,5 @@
+module AppTypes
+  ( module T
+  ) where
+
+import AppTypes.Configuration as T

app/AppTypes/Configuration.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE OverloadedStrings #-}
+module AppTypes.Configuration where
+
+import qualified Data.Text as T
+
+import Data.YAML as Y
+
+import Options.Applicative as O
+
+data ServerConfig = ServerConfig
+  { configDbHost :: T.Text
+  , configDbPort :: Word
+  , configDbName :: T.Text
+  , configDbUser :: T.Text
+  , configDbPasswd :: T.Text
+  , configCurrencySymbol :: T.Text
+  , configListenPort :: Word
+  , configListenHost :: T.Text
+  }
+  deriving (Show)
+
+instance FromYAML ServerConfig where
+  parseYAML = withMap "Configuration" $ \m -> ServerConfig
+    <$> m .: "db_host"
+    <*> m .: "db_port"
+    <*> m .: "db_name"
+    <*> m .: "db_user"
+    <*> m .: "db_passwd"
+    <*> m .: "currency"
+    <*> m .: "listen_port"
+    <*> m .:? "listen_host" .!= "127.0.0.1"
+
+newtype Options = Options
+  { optConfigLocation :: T.Text
+  }
+  deriving (Show)
+
+options :: O.Parser Options
+options = Options
+  <$> strOption
+    ( long "configuration"
+    <> short 'c'
+    <> metavar "FILEPATH"
+    <> help "Location of the configuration YAML-file"
+    )

app/Main.hs

@@ -8,7 +8,11 @@ module Main where
 import Servant
 import Servant.Server.Experimental.Auth
 
-import Data.Set (empty)
+import Data.Set as S (empty)
+import Data.ByteString.Lazy as BL hiding (putStrLn)
+import qualified Data.Text as T
+import Data.String
+import Data.YAML
 
 import Database.PostgreSQL.Simple
 
@@ -20,19 +24,46 @@ import Control.Monad.Reader
 
 import Control.Concurrent.STM.TVar
 
+import Options.Applicative
+
 -- internal imports
 
 import API
 import Model as M
 
+import AppTypes
 import Types
 import Control
 
 main :: IO ()
 main = do
-  conn <- connectPostgreSQL
-    "host='localhost' port=5432 dbname='mateamt' user='mateamt' password='mateamt'"
-  store <- newTVarIO empty
+  (Options confLoc) <- execParser opts
+  raw <- BL.readFile (T.unpack confLoc)
+  case decode1 raw of
+    Left (loc, msg) ->
+      error (T.unpack $ confLoc <> ":" <>
+        fromString (prettyPosWithSource loc raw " error") <>
+        fromString msg
+        )
+    Right
+      (ServerConfig
+        db_host
+        db_port
+        db_name
+        db_user
+        db_passwd
+        sym
+        lport
+        lhost
+        ) -> do
+          conn <- connectPostgreSQL (
+            "host='" <> fromString (T.unpack db_host) <> "' " <>
+            "port=" <> fromString (show db_port) <> " " <>
+            "dbname='" <> fromString (T.unpack db_name) <> "' " <>
+            "user='" <> fromString (T.unpack db_user) <> "' " <>
+            "password='" <> fromString (T.unpack db_passwd) <> "'"
+            )
+          store <- newTVarIO S.empty
           void $ execute_ conn initAvatar
           void $ execute_ conn initUser
           void $ execute_ conn initProduct
@@ -41,12 +72,20 @@ main = do
           void $ execute_ conn initAmount
           void $ execute_ conn initJournal
           withStdoutLogger $ \ilog -> do
-    let settings = setPort 8000 $ setLogger ilog defaultSettings
+            let settings = setPort (fromIntegral lport) $
+                  setHost (fromString $ T.unpack lhost) $
+                  setLogger ilog defaultSettings
                 initState = ReadState
                   { rsConnection  = conn
                   , rsTicketStore = store
                   }
             runSettings settings (app initState)
+  where
+    opts = info (options <**> helper)
+      ( fullDesc
+        <> progDesc "Run the \"mateamt\" API-Server."
+        <> header "mateamt - Your friendly mate distribution office"
+        )
 
 app :: ReadState -> Application
 -- app conn = serveWithContext userApi genAuthServerContext (users conn)

config.yaml

@@ -0,0 +1,8 @@
+db_host: "localhost"
+db_port: 5432
+db_name: "mateamt"
+db_user: "mateamt"
+db_passwd: "mateamt"
+listen_port: 8000
+#listen_host: "127.0.0.1"
+currency: "€"

mateamt.cabal

@@ -22,9 +22,13 @@ flag develop
 
 executable mateamt
   main-is:             Main.hs
+  other-modules:       AppTypes
+                     , AppTypes.Configuration
   -- other-extensions:
   build-depends:       base ^>=4.12.0.0
                      , mateamt
+                     , text
+                     , bytestring
                      , base16-bytestring
                      , containers
                      , mtl
@@ -37,6 +41,8 @@ executable mateamt
                      , warp
                      , wai
                      , wai-logger
+                     , HsYAML
+                     , optparse-applicative
   hs-source-dirs:      app
   ghc-options:       -Wall
   default-language:    Haskell2010