Replace hardcoded values with flags

.guix/modules/datarekisteri-package.scm

@@ -34,6 +34,7 @@
                   ghc-mime-mail
                   ghc-morpheus-graphql
                   ghc-morpheus-graphql-client
+                  ghc-optparse-applicative
                   ghc-persistent
                   ghc-persistent-postgresql
                   ghc-scotty

datarekisteri.cabal

@@ -26,6 +26,7 @@ executable datarekisteri
     morpheus-graphql-core,
     morpheus-graphql-server,
     mtl,
+    optparse-applicative,
     persistent,
     persistent-postgresql,
     process,

src/Client.hs

@@ -19,13 +19,31 @@ import Client.Types
 import Client.Handlers
 import Client.Auth ()
 import Yesod.Static (static, Static)
-import Server (runMigrations)
+import Options.Applicative
+import Server (Config(..), runMigrations, checkSendmailPath, configOpts)
 import System.Directory (createDirectoryIfMissing)
 
 mkYesodDispatch "DataIdClient" resourcesDataIdClient
 
 main :: IO ()
-main = runMigrations >> getStaticDir "/tmp/data-id" >>= warp 3000 . DataIdClient
+main = do
+    yesodConfig' <- readConfig
+    serverConfig' <- checkSendmailPath $ serverConfig yesodConfig'
+    let config = yesodConfig' {serverConfig = serverConfig'}
+    runMigrations (configDbUrl . serverConfig $ config)
+    static <- getStaticDir "/tmp/data-id"
+    warp (configPort . serverConfig $ config) $ DataIdClient static config
+
+readConfig :: IO YesodConfig
+readConfig = execParser $ info (configOpts' <**> helper)
+    (fullDesc <> progDesc "Serve datarekisteri http client and graphql server"
+    <> header "Client and server backend servers for datarekisteri")
+
+configOpts' :: Parser YesodConfig
+configOpts' = YesodConfig
+    <$> configOpts
+    <*> strOption (long "approot" <> short 'r' <> metavar "URL" <> value "http://localhost:3100" <> help "External URL of the server path /")
+    -- TODO make port depend on the --port flag
 
 getStaticDir :: FilePath -> IO Static
 getStaticDir dir = createDirectoryIfMissing True dir >> static dir

src/Client/Handlers.hs

@@ -33,4 +33,6 @@ getHomeR :: Handler Html
 getHomeR = ifM (isJust <$> maybeAuthId) (redirect OwnProfileR) (redirect $ AuthR LoginR)
 
 postApiR :: Handler ()
-postApiR = sendWaiApplication =<< liftIO serverApp
+postApiR = do
+    config <- serverConfig . yesodConfig <$> getYesod
+    sendWaiApplication =<< liftIO (serverApp config)

src/Client/Types.hs

@@ -29,10 +29,18 @@ import Data.Time.Format.ISO8601 (iso8601Show)
 import Client.Auth
 import Client.ApiRequests
 import Data.Morpheus.Client
-import Server (readPermission)
+import Server (Config(..), readPermission)
 import Data.Map (findWithDefault)
 
-data DataIdClient = DataIdClient { getStatic :: Static }
+data DataIdClient = DataIdClient
+    { getStatic :: Static
+    , yesodConfig :: YesodConfig
+    }
+
+data YesodConfig = YesodConfig
+    { serverConfig :: Config
+    , configApproot :: Text
+    }
 
 instance PathPiece UserID where
     toPathPiece (UserID id) = show id
@@ -124,7 +132,7 @@ authorizedHelper scope False = requirePermission scope ReadOnly
 
 instance Yesod DataIdClient where
     authRoute = const $ Just $ AuthR LoginR
-    approot = ApprootStatic "http://localhost:3000"
+    approot = ApprootMaster $ configApproot . yesodConfig
     makeSessionBackend = const $ sslOnlySessions $ laxSameSiteSessions $
         Just <$> defaultClientSessionBackend (60*24*7) "client_session_key.aes"
     isAuthorized (AuthR _) _ = pure Authorized

src/Server.hs

@@ -15,9 +15,9 @@ import Data.Map (findWithDefault)
 import Data.Text (toLower, breakOn, stripPrefix)
 import Database.Persist (entityVal)
 import Database.Persist.Postgresql (withPostgresqlConn, runSqlConn)
-import Network.Mail.Mime (renderSendMail, Address(..))
+import Network.Mail.Mime (renderSendMailCustom, Address(..))
 import Network.Wai (Application)
-import Network.Wai.Handler.Warp (run)
+import Network.Wai.Handler.Warp (Port, run)
 import Network.Wai.Middleware.Cors
 import Network.Wai.Middleware.Gzip
 import Server.API
@@ -25,24 +25,48 @@ import Server.DB
 import Server.DB.Queries (getUserByEmail, getPermissions, getToken)
 import Server.Types
 import Server.Utils (checkPassword)
+import System.Directory (findExecutable)
 import System.Process (callProcess)
+import Options.Applicative hiding (header)
+import qualified Options.Applicative as O
 import Web.Scotty.Trans hiding (readEither)
 import qualified "base64" Data.ByteString.Base64 as B64 (decodeBase64)
 import Paths_datarekisteri
 
 main :: IO ()
-main = run 3100 =<< serverApp
+main = do
+    config <- readConfig >>= checkSendmailPath
+    runMigrations (configDbUrl config)
+    serverApp config >>= run 3100
 
-dbUrl :: IsString a => a
+readConfig :: IO Config
-dbUrl = "postgres:///id.rekisteri"
+readConfig = do
+    execParser $ info (configOpts <**> helper)
+            (fullDesc <> progDesc "Serve a GraphQL API for datarekisteri"
+            <> O.header "Backend API server for datarekisteri")
 
-runMigrations :: IO ()
+checkSendmailPath :: Config -> IO Config
-runMigrations = do
+checkSendmailPath config = do
+    sendmailPath <- maybe (error "Sendmail command or file not found!") pure =<<
+        findExecutable (configSendmail config)
+    pure $ config {configSendmail = sendmailPath}
+
+configOpts :: Parser Config
+configOpts = Config
+    <$> strOption (long "sendmail" <> short 'm' <> metavar "COMMAND" <> value "sendmail" <> help "Sendmail command")
+    <*> (Address
+        <$> optional (strOption (long "sender-name" <> short 'n' <> metavar "NAME" <> help "Display name for email address"))
+        <*> strOption (long "address" <> short 'a' <> metavar "EMAIL" <> help "Email address to send mail"))
+    <*> option auto (long "port" <> short 'p' <> metavar "PORT" <> value 3100 <> help "Port to listen on")
+    <*> strOption (long "db-url" <> short 'u' <> metavar "URL" <> value "postgres:///id.rekisteri" <> help "Postgresql database url")
+
+runMigrations :: Text -> IO ()
+runMigrations dbUrl = do
     migrationsPath <- getDataFileName "db/migrations"
-    callProcess "dbmate" ["--url", dbUrl, "--migrations-dir", migrationsPath, "up"]
+    callProcess "dbmate" ["--url", toString dbUrl, "--migrations-dir", migrationsPath, "up"]
 
-serverApp :: IO Application
+serverApp :: Config -> IO Application
-serverApp = scottyAppT runAPIM $ do
+serverApp config = scottyAppT (runAPIM config) $ do
     middleware $ gzip def
     middleware $ cors $ const $ Just CorsResourcePolicy
         { corsOrigins = Nothing -- all
@@ -122,18 +146,29 @@ newtype APIM a = APIM (ReaderT RequestState IO a)
 data RequestState = RequestState
     { stateCurrentUser :: Maybe UserID
     , statePermissions :: Map Scope Permission
+    , stateConfig :: Config
     }
 
+data Config = Config
+    { configSendmail :: FilePath
+    , configEmailAddress :: Address
+    , configPort :: Port
+    , configDbUrl :: Text
+    }
 
 instance MonadTime APIM where
     currentTime = liftIO currentTime
 
 instance MonadDB APIM where
-    runQuery = liftIO . runStderrLoggingT . withPostgresqlConn dbUrl . runSqlConn
+    runQuery query = do
+        dbUrl <- asks $ configDbUrl . stateConfig
+        liftIO $ runStderrLoggingT $ withPostgresqlConn (encodeUtf8 dbUrl) $ runSqlConn query
 
 instance MonadEmail APIM where
-    sendEmail = liftIO . renderSendMail
+    sendEmail email = do
-    fromAddress = pure $ Address Nothing "id@datat.fi"
+        sendmailPath <- asks $ configSendmail . stateConfig
+        liftIO $ renderSendMailCustom sendmailPath ["-t"] email
+    fromAddress = asks $ configEmailAddress . stateConfig
 
 instance MonadRequest APIM where
     currentUser = asks stateCurrentUser
@@ -163,5 +198,9 @@ instance MonadPermissions APIM where
 readPermission :: Text -> Maybe (Map Scope Permission)
 readPermission = rightToMaybe . readEither . toString 
 
-runAPIM :: APIM a -> IO a
+runAPIM :: Config -> APIM a -> IO a
-runAPIM (APIM m) = runReaderT m RequestState { stateCurrentUser = Nothing, statePermissions = fromList [] }
+runAPIM config (APIM m) = runReaderT m RequestState
+    { stateCurrentUser = Nothing
+    , statePermissions = fromList []
+    , stateConfig = config
+    }