From 5502467e283c94cc359d5afe9be9f3e7c3d4d0c0 Mon Sep 17 00:00:00 2001 From: Kirill Elizarov Date: Wed, 14 Apr 2021 18:06:18 +0700 Subject: [PATCH 1/4] Added first version for Dhall support for setting up app's config. --- config/dev.dhall | 30 +++++++++++++++++++++++ package.yaml | 1 + src/AppName/Config.hs | 57 +++++++++++++++++++++++++++++++++++++++---- 3 files changed, 83 insertions(+), 5 deletions(-) create mode 100644 config/dev.dhall diff --git a/config/dev.dhall b/config/dev.dhall new file mode 100644 index 0000000..d98a928 --- /dev/null +++ b/config/dev.dhall @@ -0,0 +1,30 @@ +let LogLevel = +let LogToFile = + +let dbConfig = { + host = "localhost", + port = +5431, + database = "placid_db", + user = "placid_user", + password = "placid_pass", + poolLimit = +10 +} + +let logConfig = { + appName = "AppName", + logToStdout = True, + logLevel = LogLevel.Debug, + logRawSql = True, + logToFile = LogToFile.AllowLogToFile "/tmp/haskell-starter-kit.log" +} + +let authConfig = { + pathToKey = "./keys/auth-key" +} + +in +{ + dbConfig = dbConfig, + logConfig = logConfig, + authConfig = authConfig +} \ No newline at end of file diff --git a/package.yaml b/package.yaml index c012460..5f68816 100644 --- a/package.yaml +++ b/package.yaml @@ -38,6 +38,7 @@ dependencies: - basement - configurator +- dhall - resourcet - resource-pool diff --git a/src/AppName/Config.hs b/src/AppName/Config.hs index c16d3c8..a610b53 100644 --- a/src/AppName/Config.hs +++ b/src/AppName/Config.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveAnyClass #-} + module AppName.Config ( Config, C.require, @@ -7,6 +9,8 @@ module AppName.Config getPort, getPoolLimit, getLoggerConfig, + AppConfig (..), + loadConfig, ) where @@ -14,10 +18,53 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.Configurator as C import qualified Data.Configurator.Types as C import Data.Maybe (fromMaybe) -import Ext.Logger.Colog (Severity (Debug)) -import Ext.Logger.Config (LoggerConfig (..)) +import Data.Text (Text) +import qualified Dhall +import qualified Ext.Logger.Colog as Log (Severity (Debug)) +import qualified Ext.Logger.Config as Log (LoggerConfig (..)) +import GHC.Generics (Generic) import Text.Read (readMaybe) +data DbConfig = DbConfig + { host :: Text, + port :: Int, + database :: Text, + user :: Text, + password :: Text, + poolLimit :: Int + } + deriving (Generic, Dhall.FromDhall, Show) + +data LogLevel = Debug | Info | Warning | Error + deriving (Generic, Dhall.FromDhall, Show) + +newtype AuthConfig = AuthConfig {pathToKey :: Text} + deriving (Generic, Dhall.FromDhall, Show) + +data LogToFile = NoLogToFile | AllowLogToFile Text + deriving (Generic, Dhall.FromDhall, Show) + +data LogConfig = LogConfig + { appName :: Text, + logToStdout :: Bool, + logLevel :: LogLevel, + logRawSql :: Bool, + logToFile :: LogToFile + } + deriving (Generic, Dhall.FromDhall, Show) + +data AppConfig = AppConfig + { authConfig :: AuthConfig, + logConfig :: LogConfig, + dbConfig :: DbConfig + } + deriving (Generic, Dhall.FromDhall, Show) + +-- TODO load path to config file from ENV VAR +-- TODO use default dev config if it was not provided. Warn about using default config. +loadConfig :: MonadIO m => m AppConfig +loadConfig = liftIO $ Dhall.inputFile Dhall.auto "./config/dev.dhall" + type Config = C.Config retrieveConfig :: MonadIO m => m C.Config @@ -34,14 +81,14 @@ getPort config = liftIO $ C.require config "web_server.port" getPoolLimit :: MonadIO m => C.Config -> m Int getPoolLimit config = liftIO $ C.require config "database.pool_limit" -getLoggerConfig :: MonadIO m => C.Config -> m LoggerConfig +getLoggerConfig :: MonadIO m => C.Config -> m Log.LoggerConfig getLoggerConfig config = liftIO $ do appInstanceName <- C.require config "log.app_instance_name" logToStdout <- C.require config "log.log_to_stdout" logLevelRaw <- C.require config "log.log_level" pure $ - LoggerConfig + Log.LoggerConfig { appInstanceName = appInstanceName, logToStdout = logToStdout, - logLevel = fromMaybe Debug (readMaybe logLevelRaw) + logLevel = fromMaybe Log.Debug (readMaybe logLevelRaw) } From 5c942e90da63d9dbd5bfbd50ee7101806f598253 Mon Sep 17 00:00:00 2001 From: Kirill Elizarov Date: Wed, 12 May 2021 15:54:34 +0700 Subject: [PATCH 2/4] Added first version of dhall dev config. --- config/dev.dhall | 3 ++- src/AppName/AppHandle.hs | 5 +++-- src/AppName/Config.hs | 38 +++++++++++++------------------------- src/Ext/Logger/Config.hs | 18 ++++++++++++++++++ 4 files changed, 36 insertions(+), 28 deletions(-) diff --git a/config/dev.dhall b/config/dev.dhall index d98a928..38889f2 100644 --- a/config/dev.dhall +++ b/config/dev.dhall @@ -26,5 +26,6 @@ in { dbConfig = dbConfig, logConfig = logConfig, - authConfig = authConfig + authConfig = authConfig, + appPort = +8080 } \ No newline at end of file diff --git a/src/AppName/AppHandle.hs b/src/AppName/AppHandle.hs index 428a029..7f09011 100644 --- a/src/AppName/AppHandle.hs +++ b/src/AppName/AppHandle.hs @@ -18,7 +18,7 @@ import Control.Monad.Logger (NoLoggingT) import Data.Pool (Pool) import Database.Persist.Sql (SqlBackend) import qualified Ext.Logger.Colog as Log -import Ext.Logger.Config (LoggerConfig) +import Ext.Logger.Config (LoggerConfig, fromAppConfig) data AppHandle = AppHandle { appHandleDbPool :: Pool SqlBackend, @@ -32,7 +32,8 @@ type MonadHandler m = (MonadIO m, Log.WithLog (Log.LogAction m Log.Message) Log. withAppHandle :: (AppHandle -> NoLoggingT IO b) -> IO b withAppHandle action = do config <- C.retrieveConfig - loggerConfig <- C.getLoggerConfig config + appConfig <- C.loadConfig "./config/dev.dhall" + let loggerConfig = fromAppConfig $ C.logConfig appConfig randomGen <- CryptoRandomGen.newRef liftIO . withDbPool config $ \pool -> action $ AppHandle pool config loggerConfig randomGen diff --git a/src/AppName/Config.hs b/src/AppName/Config.hs index a610b53..1c71cc4 100644 --- a/src/AppName/Config.hs +++ b/src/AppName/Config.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedLabels #-} module AppName.Config ( Config, @@ -8,8 +9,12 @@ module AppName.Config getKeysFilePath, getPort, getPoolLimit, - getLoggerConfig, AppConfig (..), + DbConfig (..), + AuthConfig (..), + LogLevel (..), + LogToFile (..), + LogConfig (..), loadConfig, ) where @@ -17,13 +22,9 @@ where import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.Configurator as C import qualified Data.Configurator.Types as C -import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Dhall -import qualified Ext.Logger.Colog as Log (Severity (Debug)) -import qualified Ext.Logger.Config as Log (LoggerConfig (..)) import GHC.Generics (Generic) -import Text.Read (readMaybe) data DbConfig = DbConfig { host :: Text, @@ -35,13 +36,13 @@ data DbConfig = DbConfig } deriving (Generic, Dhall.FromDhall, Show) -data LogLevel = Debug | Info | Warning | Error +newtype AuthConfig = AuthConfig {pathToKey :: Text} deriving (Generic, Dhall.FromDhall, Show) -newtype AuthConfig = AuthConfig {pathToKey :: Text} +data LogLevel = Debug | Info | Warning | Error deriving (Generic, Dhall.FromDhall, Show) -data LogToFile = NoLogToFile | AllowLogToFile Text +data LogToFile = NoLogToFile | AllowLogToFile Text deriving (Generic, Dhall.FromDhall, Show) data LogConfig = LogConfig @@ -56,14 +57,13 @@ data LogConfig = LogConfig data AppConfig = AppConfig { authConfig :: AuthConfig, logConfig :: LogConfig, - dbConfig :: DbConfig + dbConfig :: DbConfig, + appPort :: Int } deriving (Generic, Dhall.FromDhall, Show) --- TODO load path to config file from ENV VAR --- TODO use default dev config if it was not provided. Warn about using default config. -loadConfig :: MonadIO m => m AppConfig -loadConfig = liftIO $ Dhall.inputFile Dhall.auto "./config/dev.dhall" +loadConfig :: MonadIO m => FilePath -> m AppConfig +loadConfig = liftIO . Dhall.inputFile Dhall.auto type Config = C.Config @@ -80,15 +80,3 @@ getPort config = liftIO $ C.require config "web_server.port" getPoolLimit :: MonadIO m => C.Config -> m Int getPoolLimit config = liftIO $ C.require config "database.pool_limit" - -getLoggerConfig :: MonadIO m => C.Config -> m Log.LoggerConfig -getLoggerConfig config = liftIO $ do - appInstanceName <- C.require config "log.app_instance_name" - logToStdout <- C.require config "log.log_to_stdout" - logLevelRaw <- C.require config "log.log_level" - pure $ - Log.LoggerConfig - { appInstanceName = appInstanceName, - logToStdout = logToStdout, - logLevel = fromMaybe Log.Debug (readMaybe logLevelRaw) - } diff --git a/src/Ext/Logger/Config.hs b/src/Ext/Logger/Config.hs index a4c1212..de79622 100644 --- a/src/Ext/Logger/Config.hs +++ b/src/Ext/Logger/Config.hs @@ -1,8 +1,12 @@ +{-# LANGUAGE OverloadedLabels #-} + module Ext.Logger.Config ( LoggerConfig (..), + fromAppConfig, ) where +import qualified AppName.Config as C import qualified Colog as Log import qualified Data.Text as T @@ -12,3 +16,17 @@ data LoggerConfig = LoggerConfig logLevel :: Log.Severity } deriving (Show, Eq) + +transformLogLevel :: C.LogLevel -> Log.Severity +transformLogLevel C.Debug = Log.Debug +transformLogLevel C.Info = Log.Info +transformLogLevel C.Warning = Log.Warning +transformLogLevel C.Error = Log.Error + +fromAppConfig :: C.LogConfig -> LoggerConfig +fromAppConfig C.LogConfig {..} = + LoggerConfig + { appInstanceName = appName, + logToStdout = logToStdout, + logLevel = transformLogLevel logLevel + } From 36d1cc1e716236b6b69853c1c6e680af7f67a4cf Mon Sep 17 00:00:00 2001 From: Kirill Elizarov Date: Mon, 13 Sep 2021 18:37:02 +0700 Subject: [PATCH 3/4] First version of implementing Dhall for config --- config/dev.dhall | 16 ++-- config/template.conf | 26 ------- hie.yaml | 13 ++++ package.yaml | 1 - src/AppName/AppHandle.hs | 15 ++-- src/AppName/Auth/Commands.hs | 5 +- src/AppName/Config.hs | 82 +++------------------ src/AppName/Gateways/Database.hs | 2 +- src/AppName/Gateways/Database/Connection.hs | 18 ++--- src/AppName/Gateways/Database/Setup.hs | 10 +-- src/AppName/Server.hs | 9 ++- src/Ext/Logger.hs | 8 +- src/Ext/Logger/Colog.hs | 20 ++--- src/Ext/Logger/Config.hs | 47 ++++++------ src/Lib.hs | 11 +-- test/PhoneVerification.hs | 4 +- 16 files changed, 105 insertions(+), 182 deletions(-) delete mode 100644 config/template.conf create mode 100644 hie.yaml diff --git a/config/dev.dhall b/config/dev.dhall index 38889f2..ba15a16 100644 --- a/config/dev.dhall +++ b/config/dev.dhall @@ -1,19 +1,19 @@ -let LogLevel = +let LogSeverity = let LogToFile = let dbConfig = { host = "localhost", port = +5431, - database = "placid_db", - user = "placid_user", - password = "placid_pass", + database = "haskell_starter-kit-db", + user = "haskell_starter-kit-user", + password = "haskell_starter-kit-pass", poolLimit = +10 } -let logConfig = { - appName = "AppName", +let loggerConfig = { + appName = "Haskell Starter Kit", logToStdout = True, - logLevel = LogLevel.Debug, + logLevel = LogSeverity.Debug, logRawSql = True, logToFile = LogToFile.AllowLogToFile "/tmp/haskell-starter-kit.log" } @@ -25,7 +25,7 @@ let authConfig = { in { dbConfig = dbConfig, - logConfig = logConfig, + loggerConfig = loggerConfig, authConfig = authConfig, appPort = +8080 } \ No newline at end of file diff --git a/config/template.conf b/config/template.conf deleted file mode 100644 index 368e19e..0000000 --- a/config/template.conf +++ /dev/null @@ -1,26 +0,0 @@ -database { - host = "$(DB_HOST)" - port = "$(DB_PORT)" - name = "$(POSTGRES_DB)" - user = "$(POSTGRES_USER)" - pass = "$(POSTGRES_PASSWORD)" - pool_limit = 10 -} - -web_server { - port = 8080 -} - -auth { - key_path = "./keys/auth-key" -} - -log { - app_instance_name = "AppName" - log_to_stdout = on - log_level = "Debug" -} - -app { - domain_specific = "SOME_DOMAIN_SPECIFIC_PARAM" -} diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000..18b3a6e --- /dev/null +++ b/hie.yaml @@ -0,0 +1,13 @@ +cradle: + stack: + - path: "./src" + component: "haskell-starter-kit:lib" + + - path: "./app/Main.hs" + component: "haskell-starter-kit:exe:haskell-starter-kit-exe" + + - path: "./app/Paths_haskell_starter_kit.hs" + component: "haskell-starter-kit:exe:haskell-starter-kit-exe" + + - path: "./test" + component: "haskell-starter-kit:test:haskell-starter-kit-test" diff --git a/package.yaml b/package.yaml index 6b8ab50..0d0a243 100644 --- a/package.yaml +++ b/package.yaml @@ -37,7 +37,6 @@ dependencies: - memory - basement -- configurator - dhall - resourcet - resource-pool diff --git a/src/AppName/AppHandle.hs b/src/AppName/AppHandle.hs index 29cfa0a..8b27ad8 100644 --- a/src/AppName/AppHandle.hs +++ b/src/AppName/AppHandle.hs @@ -22,7 +22,7 @@ import Ext.Logger.Config (LoggerConfig) data AppHandle = AppHandle { appHandleDbPool :: Pool SqlBackend, - appHandleConfig :: C.Config, + appHandleAppConfig :: C.AppConfig, appHandleLogger :: LoggerConfig, appHandleRandomGen :: CryptoRandomGen.Ref } @@ -31,9 +31,14 @@ type MonadHandler m = (MonadIO m, Log.WithLog m) withAppHandle :: (AppHandle -> NoLoggingT IO b) -> IO b withAppHandle action = do - config <- C.retrieveConfig appConfig <- C.loadConfig "./config/dev.dhall" - let loggerConfig = fromAppConfig $ C.logConfig appConfig + let loggerConfig = C.loggerConfig appConfig randomGen <- CryptoRandomGen.newRef - liftIO . withDbPool config $ \pool -> - action $ AppHandle pool config loggerConfig randomGen + liftIO . withDbPool appConfig $ \pool -> + action $ + AppHandle + { appHandleDbPool = pool, + appHandleAppConfig = appConfig, + appHandleLogger = loggerConfig, + appHandleRandomGen = randomGen + } diff --git a/src/AppName/Auth/Commands.hs b/src/AppName/Auth/Commands.hs index bc33bda..c716b1e 100644 --- a/src/AppName/Auth/Commands.hs +++ b/src/AppName/Auth/Commands.hs @@ -3,6 +3,7 @@ module AppName.Auth.Commands where import qualified AppName.Config as C import Servant.Auth.Server (writeKey) import qualified System.Directory as FS +import Data.Text (unpack) createKey :: FilePath -> IO () createKey filePath = do @@ -11,8 +12,8 @@ createKey filePath = do checkAuthKey :: IO () checkAuthKey = do - config <- C.retrieveConfig - authKeyPath <- C.getKeysFilePath config + config <- C.loadConfig "./config/dev.dhall" + let authKeyPath = unpack $ C.pathToKey $ C.authConfig config isExist <- FS.doesFileExist authKeyPath if isExist then notifyExists authKeyPath else createKey authKeyPath where diff --git a/src/AppName/Config.hs b/src/AppName/Config.hs index 05efcc4..7b04f48 100644 --- a/src/AppName/Config.hs +++ b/src/AppName/Config.hs @@ -1,34 +1,21 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedLabels #-} -module AppName.Config - ( Config, - C.require, - C.lookup, - retrieveConfig, - getKeysFilePath, - getPort, - getPoolLimit, - AppConfig (..), - DbConfig (..), - AuthConfig (..), - LogLevel (..), - LogToFile (..), - LogConfig (..), - loadConfig, - ) -where +module AppName.Config where import Control.Monad.IO.Class (MonadIO, liftIO) -import qualified Data.Configurator as C -import qualified Data.Configurator.Types as C import Data.Text (Text) import qualified Dhall import GHC.Generics (Generic) -import Data.Maybe (fromMaybe) -import qualified Ext.Logger as Log import Ext.Logger.Config (LoggerConfig (..)) -import Text.Read (readMaybe) + +data AppConfig = AppConfig + { authConfig :: AuthConfig, + loggerConfig :: LoggerConfig, + dbConfig :: DbConfig, + appPort :: Int + } + deriving (Generic, Dhall.FromDhall, Show) data DbConfig = DbConfig { host :: Text, @@ -43,56 +30,5 @@ data DbConfig = DbConfig newtype AuthConfig = AuthConfig {pathToKey :: Text} deriving (Generic, Dhall.FromDhall, Show) -data LogLevel = Debug | Info | Warning | Error - deriving (Generic, Dhall.FromDhall, Show) - -data LogToFile = NoLogToFile | AllowLogToFile Text - deriving (Generic, Dhall.FromDhall, Show) - -data LogConfig = LogConfig - { appName :: Text, - logToStdout :: Bool, - logLevel :: LogLevel, - logRawSql :: Bool, - logToFile :: LogToFile - } - deriving (Generic, Dhall.FromDhall, Show) - -data AppConfig = AppConfig - { authConfig :: AuthConfig, - logConfig :: LogConfig, - dbConfig :: DbConfig, - appPort :: Int - } - deriving (Generic, Dhall.FromDhall, Show) - loadConfig :: MonadIO m => FilePath -> m AppConfig loadConfig = liftIO . Dhall.inputFile Dhall.auto - -type Config = C.Config - -retrieveConfig :: MonadIO m => m C.Config -retrieveConfig = do - let configPath = "./config/local.conf" - liftIO $ C.load [C.Required configPath] - -getKeysFilePath :: MonadIO m => C.Config -> m FilePath -getKeysFilePath config = liftIO $ C.require config "auth.key_path" - -getPort :: MonadIO m => C.Config -> m Int -getPort config = liftIO $ C.require config "web_server.port" - -getPoolLimit :: MonadIO m => C.Config -> m Int -getPoolLimit config = liftIO $ C.require config "database.pool_limit" - -getLoggerConfig :: MonadIO m => C.Config -> m LoggerConfig -getLoggerConfig config = liftIO $ do - appInstanceName <- C.require config "log.app_instance_name" - logToStdout <- C.require config "log.log_to_stdout" - logLevelRaw <- C.require config "log.log_level" - pure $ - LoggerConfig - { appInstanceName = appInstanceName, - logToStdout = logToStdout, - logLevel = fromMaybe Log.Debug (readMaybe logLevelRaw) - } diff --git a/src/AppName/Gateways/Database.hs b/src/AppName/Gateways/Database.hs index 0e2d239..7f4e63b 100644 --- a/src/AppName/Gateways/Database.hs +++ b/src/AppName/Gateways/Database.hs @@ -20,5 +20,5 @@ allMigrations = runAllMigrations :: IO () runAllMigrations = do - conf <- C.retrieveConfig + conf <- C.loadConfig "./config/dev.dhall" withDbPoolDebug conf $ liftIO . runSqlPersistMPool migrateAll diff --git a/src/AppName/Gateways/Database/Connection.hs b/src/AppName/Gateways/Database/Connection.hs index d93f20c..c1aa823 100644 --- a/src/AppName/Gateways/Database/Connection.hs +++ b/src/AppName/Gateways/Database/Connection.hs @@ -3,17 +3,13 @@ module AppName.Gateways.Database.Connection ) where -import AppName.Config (Config) -import qualified Data.Configurator as C +import qualified AppName.Config as Config +import Data.Text (pack) +import Data.Text.Encoding (encodeUtf8) import Database.Persist.Postgresql (ConnectionString) -createPgConnString :: Config -> IO ConnectionString +createPgConnString :: Config.AppConfig -> ConnectionString createPgConnString config = do - host <- C.require config "database.host" - name <- C.require config "database.name" - user <- C.require config "database.user" - pass <- C.require config "database.pass" - port <- C.require config "database.port" - let proto = "postgresql://" - pure $ - proto <> user <> ":" <> pass <> "@" <> host <> ":" <> port <> "/" <> name + let Config.DbConfig {..} = Config.dbConfig config + in encodeUtf8 $ + "postgresql://" <> user <> ":" <> password <> "@" <> host <> ":" <> pack (show port) <> "/" <> database diff --git a/src/AppName/Gateways/Database/Setup.hs b/src/AppName/Gateways/Database/Setup.hs index 7294fa1..c74528a 100644 --- a/src/AppName/Gateways/Database/Setup.hs +++ b/src/AppName/Gateways/Database/Setup.hs @@ -22,21 +22,21 @@ import Data.Pool (Pool, destroyAllResources) import Database.Persist.Postgresql (SqlBackend, createPostgresqlPoolModified) import Database.PostgreSQL.Simple (execute_) -withDbPoolDebug :: C.Config -> (Pool SqlBackend -> LoggingT IO a) -> IO a +withDbPoolDebug :: C.AppConfig -> (Pool SqlBackend -> LoggingT IO a) -> IO a withDbPoolDebug = withLoggedDbPool runStdoutLoggingT -withDbPool :: C.Config -> (Pool SqlBackend -> NoLoggingT IO a) -> IO a +withDbPool :: C.AppConfig -> (Pool SqlBackend -> NoLoggingT IO a) -> IO a withDbPool = withLoggedDbPool runNoLoggingT withLoggedDbPool :: (MonadUnliftIO m, MonadLogger m, MonadMask m) => (m a -> IO a) -> - C.Config -> + C.AppConfig -> (Pool SqlBackend -> m a) -> IO a withLoggedDbPool runLogging config action = do - poolLimit <- C.getPoolLimit config - connStr <- createPgConnString config + let poolLimit = C.poolLimit $ C.dbConfig config + let connStr = createPgConnString config liftIO $ runLogging $ bracket diff --git a/src/AppName/Server.hs b/src/AppName/Server.hs index 7bbaa4e..d1d8288 100644 --- a/src/AppName/Server.hs +++ b/src/AppName/Server.hs @@ -25,6 +25,7 @@ import Control.Exception.Safe (try) import Control.Monad.Except (ExceptT (ExceptT)) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Proxy (Proxy (Proxy)) +import Data.Text (unpack) import qualified Ext.Logger.Colog as CologAdapter import Network.Wai.Handler.Warp ( Settings, @@ -80,12 +81,12 @@ hoistServerHandler env = (Proxy :: ProtectedServantJWTCtx) (Handler . ExceptT . try . CologAdapter.runWithAction env) -runServer :: C.Config -> IO () +runServer :: C.AppConfig -> IO () runServer config = do checkAuthKey - filePath <- C.getKeysFilePath config + let filePath = unpack $ C.pathToKey $ C.authConfig config authKey <- SAS.readKey filePath - port <- C.getPort config + let port = C.appPort config let serverSettings = setPort port $ setBeforeMainLoop @@ -108,5 +109,5 @@ runServer config = do runDevServer :: IO () runDevServer = do - config <- C.retrieveConfig + config <- C.loadConfig "./config/dev.dhall" runServer config diff --git a/src/Ext/Logger.hs b/src/Ext/Logger.hs index 25cef2d..8a928d9 100644 --- a/src/Ext/Logger.hs +++ b/src/Ext/Logger.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} -- The application logger interface module. This should be minimal -- possible and independent of a particular logging library or @@ -7,7 +8,8 @@ -- The module is intended to be imported qualified with an alias like -- @Log@. module Ext.Logger - ( WithLog, + ( module Exports, + WithLog, MonadLogger (..), Severity (..), CallStack (..), @@ -19,6 +21,7 @@ module Ext.Logger where import qualified Data.Text as T +import Ext.Logger.Config as Exports import qualified GHC.Stack as GHC import Prelude hiding (error) @@ -30,9 +33,6 @@ type WithLog m = (GHC.HasCallStack, MonadLogger m) class Monad m => MonadLogger m where logMessage :: Severity -> CallStack -> T.Text -> m () -data Severity = Debug | Info | Warning | Error - deriving (Eq, Show, Read) - newtype CallStack = CallStack {unCallStack :: GHC.CallStack} logDebug, logInfo, logWarn, logError :: (GHC.HasCallStack, MonadLogger m) => T.Text -> m () diff --git a/src/Ext/Logger/Colog.hs b/src/Ext/Logger/Colog.hs index bb54488..dcdf9f2 100644 --- a/src/Ext/Logger/Colog.hs +++ b/src/Ext/Logger/Colog.hs @@ -24,7 +24,7 @@ import qualified Data.Text as T import qualified Data.Time as Time import qualified Data.TypeRepMap as TM import qualified Ext.Data.Time as Clock -import qualified Ext.Logger as Log +import qualified Ext.Logger as Logger import qualified Ext.Logger.Config as Conf import System.IO ( BufferMode (LineBuffering), @@ -36,28 +36,28 @@ import System.IO newtype LoggerT m a = LoggerT {runLoggerT :: Colog.LoggerT Colog.Message m a} deriving (Functor, Applicative, Monad) -instance MonadIO m => Log.MonadLogger (LoggerT m) where +instance MonadIO m => Logger.MonadLogger (LoggerT m) where logMessage = cologLogMessage instance MonadIO m => MonadIO (LoggerT m) where liftIO = LoggerT . liftIO -cologLogMessage :: MonadIO m => Log.Severity -> Log.CallStack -> T.Text -> LoggerT m () +cologLogMessage :: MonadIO m => Logger.Severity -> Logger.CallStack -> T.Text -> LoggerT m () cologLogMessage severity callSite messageText = LoggerT $ Colog.logMsg cologMsg where cologMsg = Colog.Msg { msgSeverity = cologSeverityFromSeverity severity, msgText = messageText, - msgStack = Log.unCallStack callSite + msgStack = Logger.unCallStack callSite } -cologSeverityFromSeverity :: Log.Severity -> Colog.Severity +cologSeverityFromSeverity :: Logger.Severity -> Colog.Severity cologSeverityFromSeverity = \case - Log.Debug -> Colog.Debug - Log.Info -> Colog.Info - Log.Warning -> Colog.Warning - Log.Error -> Colog.Error + Logger.Debug -> Colog.Debug + Logger.Info -> Colog.Info + Logger.Warning -> Colog.Warning + Logger.Error -> Colog.Error runWithAction :: Monad m => Colog.LogAction m Colog.Message -> LoggerT m a -> m a runWithAction action = Colog.usingLoggerT action . runLoggerT @@ -76,7 +76,7 @@ timestampedFieldMapIO :: timestampedFieldMapIO = [#timestamp Clock.now] fieldMap :: Monad m => Conf.LoggerConfig -> Colog.FieldMap m -fieldMap Conf.LoggerConfig {..} = [#appInstanceName (pure appInstanceName)] +fieldMap Conf.LoggerConfig {..} = [#appInstanceName (pure appName)] fmtRichMessage :: Monad m => Colog.RichMsg m Colog.Message -> m BS.ByteString fmtRichMessage Colog.RichMsg {richMsgMsg = Colog.Msg {..}, ..} = do diff --git a/src/Ext/Logger/Config.hs b/src/Ext/Logger/Config.hs index a5eb26f..1cb5d87 100644 --- a/src/Ext/Logger/Config.hs +++ b/src/Ext/Logger/Config.hs @@ -1,33 +1,30 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedLabels #-} -module Ext.Logger.Config - ( LoggerConfig (..), - fromAppConfig, - ) -where +module Ext.Logger.Config where -import qualified AppName.Config as C -import qualified Colog as Log -import qualified Data.Text as T -import qualified Ext.Logger as Log +import qualified Colog +import Data.Text (Text) +import qualified Dhall +import GHC.Generics (Generic) + +data Severity = Debug | Info | Warning | Error + deriving (Eq, Show, Read, Generic, Dhall.FromDhall) + +data LogToFile = NoLogToFile | AllowLogToFile Text + deriving (Generic, Dhall.FromDhall, Show) data LoggerConfig = LoggerConfig - { appInstanceName :: T.Text, + { appName :: Text, logToStdout :: Bool, - logLevel :: Log.Severity + logLevel :: Severity, + logRawSql :: Bool, + logToFile :: LogToFile } - deriving (Show, Eq) - -transformLogLevel :: C.LogLevel -> Log.Severity -transformLogLevel C.Debug = Log.Debug -transformLogLevel C.Info = Log.Info -transformLogLevel C.Warning = Log.Warning -transformLogLevel C.Error = Log.Error + deriving (Generic, Dhall.FromDhall, Show) -fromAppConfig :: C.LogConfig -> LoggerConfig -fromAppConfig C.LogConfig {..} = - LoggerConfig - { appInstanceName = appName, - logToStdout = logToStdout, - logLevel = transformLogLevel logLevel - } +transformLogLevel :: Severity -> Colog.Severity +transformLogLevel Debug = Colog.Debug +transformLogLevel Info = Colog.Info +transformLogLevel Warning = Colog.Warning +transformLogLevel Error = Colog.Error \ No newline at end of file diff --git a/src/Lib.hs b/src/Lib.hs index eb13b4b..502c578 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -13,12 +13,11 @@ import Control.Monad.IO.Unlift (MonadIO, liftIO) import Database.Persist.Postgresql import qualified Ext.Logger as Log import qualified Ext.Logger.Colog as CologAdapter -import qualified Ext.Logger.Config as Log runDefaultExample :: IO () runDefaultExample = CologAdapter.runWithAction (CologAdapter.mkLogActionIO logConf) $ do - config <- liftIO C.retrieveConfig + config <- liftIO $ C.loadConfig "./config/dev.dhall" runLogExample runDBExample config liftIO runDevServer @@ -33,12 +32,14 @@ runServer = logConf :: Log.LoggerConfig logConf = Log.LoggerConfig - { appInstanceName = "AppName", + { appName = "AppName", logToStdout = True, - logLevel = Log.Debug + logLevel = Log.Debug, + logRawSql = False, + logToFile = Log.NoLogToFile } -runDBExample :: MonadIO m => C.Config -> m () +runDBExample :: MonadIO m => C.AppConfig -> m () runDBExample config = liftIO . withDbPoolDebug config diff --git a/test/PhoneVerification.hs b/test/PhoneVerification.hs index a38ff7d..fc55767 100644 --- a/test/PhoneVerification.hs +++ b/test/PhoneVerification.hs @@ -78,8 +78,8 @@ newtype MockUser mkApp :: (Phone -> Code -> IO ()) -> MockUser -> IO Application mkApp onSendCode (MockUser userId) = do - config <- C.retrieveConfig - authKeyPath <- C.getKeysFilePath config + config <- C.loadConfig "./config/dev.dhall" + let authKeyPath = T.unpack $ C.pathToKey $ C.authConfig config authKey <- SAS.readKey authKeyPath randomGen <- CryptoRandomGen.newRef let mockExternals = From 0c97529a9cd3bd6e275f360dfeb4a187d3efe998 Mon Sep 17 00:00:00 2001 From: Kirill Elizarov Date: Tue, 14 Sep 2021 14:42:53 +0700 Subject: [PATCH 4/4] Fixes ormolu code format --- src/AppName/Auth/Commands.hs | 2 +- src/AppName/Config.hs | 2 +- src/AppName/Gateways/Database/Connection.hs | 4 ++-- src/Ext/Logger/Config.hs | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/AppName/Auth/Commands.hs b/src/AppName/Auth/Commands.hs index c716b1e..08e6c62 100644 --- a/src/AppName/Auth/Commands.hs +++ b/src/AppName/Auth/Commands.hs @@ -1,9 +1,9 @@ module AppName.Auth.Commands where import qualified AppName.Config as C +import Data.Text (unpack) import Servant.Auth.Server (writeKey) import qualified System.Directory as FS -import Data.Text (unpack) createKey :: FilePath -> IO () createKey filePath = do diff --git a/src/AppName/Config.hs b/src/AppName/Config.hs index 7b04f48..0c35b5e 100644 --- a/src/AppName/Config.hs +++ b/src/AppName/Config.hs @@ -6,8 +6,8 @@ module AppName.Config where import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Text (Text) import qualified Dhall -import GHC.Generics (Generic) import Ext.Logger.Config (LoggerConfig (..)) +import GHC.Generics (Generic) data AppConfig = AppConfig { authConfig :: AuthConfig, diff --git a/src/AppName/Gateways/Database/Connection.hs b/src/AppName/Gateways/Database/Connection.hs index c1aa823..eb0d74f 100644 --- a/src/AppName/Gateways/Database/Connection.hs +++ b/src/AppName/Gateways/Database/Connection.hs @@ -11,5 +11,5 @@ import Database.Persist.Postgresql (ConnectionString) createPgConnString :: Config.AppConfig -> ConnectionString createPgConnString config = do let Config.DbConfig {..} = Config.dbConfig config - in encodeUtf8 $ - "postgresql://" <> user <> ":" <> password <> "@" <> host <> ":" <> pack (show port) <> "/" <> database + in encodeUtf8 $ + "postgresql://" <> user <> ":" <> password <> "@" <> host <> ":" <> pack (show port) <> "/" <> database diff --git a/src/Ext/Logger/Config.hs b/src/Ext/Logger/Config.hs index 1cb5d87..595d3b7 100644 --- a/src/Ext/Logger/Config.hs +++ b/src/Ext/Logger/Config.hs @@ -27,4 +27,4 @@ transformLogLevel :: Severity -> Colog.Severity transformLogLevel Debug = Colog.Debug transformLogLevel Info = Colog.Info transformLogLevel Warning = Colog.Warning -transformLogLevel Error = Colog.Error \ No newline at end of file +transformLogLevel Error = Colog.Error