From d0d32a04fe4ba2e395655d29065873e8b1054c9c Mon Sep 17 00:00:00 2001 From: Saku Laesvuori Date: Fri, 15 Sep 2023 18:05:58 +0300 Subject: [PATCH] Replace hardcoded values with flags --- .guix/modules/datarekisteri-package.scm | 1 + datarekisteri.cabal | 1 + src/Client.hs | 22 +++++++- src/Client/Handlers.hs | 4 +- src/Client/Types.hs | 14 +++-- src/Server.hs | 69 +++++++++++++++++++------ 6 files changed, 90 insertions(+), 21 deletions(-) diff --git a/.guix/modules/datarekisteri-package.scm b/.guix/modules/datarekisteri-package.scm index 9ffc6d4..21fcf67 100644 --- a/.guix/modules/datarekisteri-package.scm +++ b/.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 diff --git a/datarekisteri.cabal b/datarekisteri.cabal index 1b01f73..4c4b7bb 100644 --- a/datarekisteri.cabal +++ b/datarekisteri.cabal @@ -26,6 +26,7 @@ executable datarekisteri morpheus-graphql-core, morpheus-graphql-server, mtl, + optparse-applicative, persistent, persistent-postgresql, process, diff --git a/src/Client.hs b/src/Client.hs index 8390f8e..ea81f47 100644 --- a/src/Client.hs +++ b/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 diff --git a/src/Client/Handlers.hs b/src/Client/Handlers.hs index ef78cb3..109b65f 100644 --- a/src/Client/Handlers.hs +++ b/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) diff --git a/src/Client/Types.hs b/src/Client/Types.hs index 9c6bc47..1cdf6ff 100644 --- a/src/Client/Types.hs +++ b/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 diff --git a/src/Server.hs b/src/Server.hs index d6cd4ea..db81ac6 100644 --- a/src/Server.hs +++ b/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 -dbUrl = "postgres:///id.rekisteri" +readConfig :: IO Config +readConfig = do + execParser $ info (configOpts <**> helper) + (fullDesc <> progDesc "Serve a GraphQL API for datarekisteri" + <> O.header "Backend API server for datarekisteri") -runMigrations :: IO () -runMigrations = do +checkSendmailPath :: Config -> IO Config +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 = scottyAppT runAPIM $ do +serverApp :: Config -> IO Application +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 - fromAddress = pure $ Address Nothing "id@datat.fi" + sendEmail email = do + 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 (APIM m) = runReaderT m RequestState { stateCurrentUser = Nothing, statePermissions = fromList [] } +runAPIM :: Config -> APIM a -> IO a +runAPIM config (APIM m) = runReaderT m RequestState + { stateCurrentUser = Nothing + , statePermissions = fromList [] + , stateConfig = config + }