Добавляет поддержку Dhall для управления конфигами

config/dev.dhall

@@ -0,0 +1,31 @@
+let LogSeverity = <Debug | Info | Warning | Error>
+let LogToFile = <NoLogToFile | AllowLogToFile : Text>
+
+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
+}

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"

package.yaml

@@ -37,7 +37,7 @@ dependencies:
 - memory
 - basement
 
-- configurator
+- dhall
 - resourcet
 - resource-pool
 

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
+        }

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

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

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

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

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

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

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 ()

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