diff --git a/config/dev.dhall b/config/dev.dhall new file mode 100644 index 0000000..ba15a16 --- /dev/null +++ b/config/dev.dhall @@ -0,0 +1,31 @@ +let LogSeverity = +let LogToFile = + +let dbConfig = { + host = "localhost", + port = +5431, + database = "haskell_starter-kit-db", + user = "haskell_starter-kit-user", + password = "haskell_starter-kit-pass", + poolLimit = +10 +} + +let loggerConfig = { + appName = "Haskell Starter Kit", + logToStdout = True, + logLevel = LogSeverity.Debug, + logRawSql = True, + logToFile = LogToFile.AllowLogToFile "/tmp/haskell-starter-kit.log" +} + +let authConfig = { + pathToKey = "./keys/auth-key" +} + +in +{ + dbConfig = dbConfig, + 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 5368236..0d0a243 100644 --- a/package.yaml +++ b/package.yaml @@ -37,7 +37,7 @@ dependencies: - memory - basement -- configurator +- dhall - resourcet - resource-pool diff --git a/src/AppName/AppHandle.hs b/src/AppName/AppHandle.hs index f5673ee..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,8 +31,14 @@ type MonadHandler m = (MonadIO m, Log.WithLog m) 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 = 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..08e6c62 100644 --- a/src/AppName/Auth/Commands.hs +++ b/src/AppName/Auth/Commands.hs @@ -1,6 +1,7 @@ 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 @@ -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 8d10406..0c35b5e 100644 --- a/src/AppName/Config.hs +++ b/src/AppName/Config.hs @@ -1,47 +1,34 @@ -module AppName.Config - ( Config, - C.require, - C.lookup, - retrieveConfig, - getKeysFilePath, - getPort, - getPoolLimit, - getLoggerConfig, - ) -where +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedLabels #-} + +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.Maybe (fromMaybe) -import qualified Ext.Logger as Log +import Data.Text (Text) +import qualified Dhall import Ext.Logger.Config (LoggerConfig (..)) -import Text.Read (readMaybe) - -type Config = C.Config - -retrieveConfig :: MonadIO m => m C.Config -retrieveConfig = do - let configPath = "./config/local.conf" - liftIO $ C.load [C.Required configPath] +import GHC.Generics (Generic) -getKeysFilePath :: MonadIO m => C.Config -> m FilePath -getKeysFilePath config = liftIO $ C.require config "auth.key_path" +data AppConfig = AppConfig + { authConfig :: AuthConfig, + loggerConfig :: LoggerConfig, + dbConfig :: DbConfig, + appPort :: Int + } + deriving (Generic, Dhall.FromDhall, Show) -getPort :: MonadIO m => C.Config -> m Int -getPort config = liftIO $ C.require config "web_server.port" +data DbConfig = DbConfig + { host :: Text, + port :: Int, + database :: Text, + user :: Text, + password :: Text, + poolLimit :: Int + } + deriving (Generic, Dhall.FromDhall, Show) -getPoolLimit :: MonadIO m => C.Config -> m Int -getPoolLimit config = liftIO $ C.require config "database.pool_limit" +newtype AuthConfig = AuthConfig {pathToKey :: Text} + deriving (Generic, Dhall.FromDhall, Show) -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) - } +loadConfig :: MonadIO m => FilePath -> m AppConfig +loadConfig = liftIO . Dhall.inputFile Dhall.auto 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..eb0d74f 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 0407ac2..595d3b7 100644 --- a/src/Ext/Logger/Config.hs +++ b/src/Ext/Logger/Config.hs @@ -1,14 +1,30 @@ -module Ext.Logger.Config - ( LoggerConfig (..), - ) -where +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedLabels #-} -import qualified Data.Text as T -import qualified Ext.Logger as Log +module Ext.Logger.Config where + +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) + deriving (Generic, Dhall.FromDhall, Show) + +transformLogLevel :: Severity -> Colog.Severity +transformLogLevel Debug = Colog.Debug +transformLogLevel Info = Colog.Info +transformLogLevel Warning = Colog.Warning +transformLogLevel Error = Colog.Error 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 =