Merge pull request #1553 from digitallyinduced/remove-providers

Replace ConfigProvider and LoggingProvider with dot notation

Guide/controller.markdown

@@ -159,7 +159,12 @@ This will render `Hello World, Unnamed!` when the `ExampleAction` is called with
 
 ### Accessing the FrameworkConfig inside Controllers and Views.
 
-The config defined in `Config/Config.hs` is available through the implicit parameter `context`, a [`ConfigProvider`](https://ihp.digitallyinduced.com/api-docs/IHP-FrameworkConfig.html#t:ConfigProvider) that is available in controllers.
+The config defined in `Config/Config.hs` is available through the implicit parameter `?context` that is available in controllers:
+
+```haskell
+action MyAction = do
+    let config = ?context.frameworkConfig
+```
 
 There are helpers that use this implicit parameter, e.g. [`isDevelopment`](https://ihp.digitallyinduced.com/api-docs/IHP-FrameworkConfig.html#v:isDevelopment)/[`isProduction`](https://ihp.digitallyinduced.com/api-docs/IHP-FrameworkConfig.html#v:isProduction):
 
@@ -168,8 +173,6 @@ action MyAction = do
     when isDevelopment (putStrLn "Running in dev mode")
 ```
 
-or you can use the function [`getFrameworkConfig`](https://ihp.digitallyinduced.com/api-docs/IHP-FrameworkConfig.html#v:getFrameworkConfig) if you need to access the config yourself.
-
 ### Advanced: Working with Custom Types
 
 Rarely you might want to work with a custom scalar value which is not yet supported with [`param`](https://ihp.digitallyinduced.com/api-docs/IHP-Controller-Param.html#v:param). Define a custom [`ParamReader`](https://ihp.digitallyinduced.com/api-docs/IHP-Controller-Param.html#t:ParamReader) instance to be able to use the [`param`](https://ihp.digitallyinduced.com/api-docs/IHP-Controller-Param.html#v:param) functions with your custom value type. [For that, take a look at the existing instances of `ParamReader`.](https://ihp.digitallyinduced.com/api-docs/IHP-Controller-Param.html#t:ParamReader)

IHP/Assets/ViewFunctions.hs

@@ -32,7 +32,5 @@ assetPath assetPath = assetPath <> "?v=" <> assetVersion
 -- The asset version can be configured using the
 -- @IHP_ASSET_VERSION@ environment variable.
 assetVersion :: (?context :: ControllerContext) => Text
-assetVersion = ?context
-    |> Config.getFrameworkConfig
-    |> get #assetVersion
+assetVersion = ?context.frameworkConfig.assetVersion
 {-# INLINABLE assetVersion #-}

IHP/Controller/Context.hs

@@ -133,9 +133,9 @@ putContext value = do
 
 newtype ActionType = ActionType Typeable.TypeRep
 
-instance ConfigProvider ControllerContext where
-    getFrameworkConfig context = getFrameworkConfig (get #requestContext context)
-    {-# INLINABLE getFrameworkConfig #-}
+instance HasField "frameworkConfig" ControllerContext FrameworkConfig where
+    getField controllerContext = controllerContext.requestContext.frameworkConfig
+    {-# INLINABLE getField #-}
 
-instance LoggingProvider ControllerContext where
-    getLogger = getLogger . getFrameworkConfig
+instance HasField "logger" ControllerContext Logger where
+    getField controllerContext = controllerContext.frameworkConfig.logger

IHP/Controller/Redirect.hs

@@ -43,7 +43,7 @@ redirectTo action = redirectToPath (pathTo action)
 --
 -- Use 'redirectTo' if you want to redirect to a controller action.
 redirectToPath :: (?context :: ControllerContext) => Text -> IO ()
-redirectToPath path = redirectToUrl (fromConfig baseUrl <> path)
+redirectToPath path = redirectToUrl (?context.frameworkConfig.baseUrl <> path)
 {-# INLINABLE redirectToPath #-}
 
 -- | Redirects to a url (given as a string)

IHP/Controller/RequestContext.hs

@@ -1,7 +1,6 @@
 module IHP.Controller.RequestContext
 ( RequestContext (..)
 , Respond
-, getConfig
 , RequestBody (..)
 ) where
 
@@ -28,6 +27,3 @@ data RequestContext = RequestContext
     , vault :: (Vault.Key (Session IO ByteString ByteString))
     , frameworkConfig :: FrameworkConfig
     }
-
-instance ConfigProvider RequestContext where
-    getFrameworkConfig = frameworkConfig

IHP/ControllerSupport.hs

@@ -342,9 +342,7 @@ respondAndExit response = do
 -- >     putStrLn ("Stripe public key: " <> stripePublicKey)
 --
 getAppConfig :: forall configParameter context. (?context :: context, ConfigProvider context, Typeable configParameter) => configParameter
-getAppConfig = ?context
-        |> getFrameworkConfig
-        |> get #appConfig
+getAppConfig = ?context.frameworkConfig.appConfig
         |> TypeMap.lookup @configParameter
         |> fromMaybe (error ("Could not find " <> (show (Typeable.typeRep (Typeable.Proxy @configParameter))) <>" in config"))
 {-# INLINE getAppConfig #-}

IHP/DataSync/Role.hs

@@ -70,6 +70,4 @@ grantPermissions role = do
     pure ()
 
 authenticatedRole :: (?context :: context, ConfigProvider context) => Text
-authenticatedRole = ?context
-        |> getFrameworkConfig
-        |> get #rlsAuthenticatedRole
+authenticatedRole = ?context.frameworkConfig.rlsAuthenticatedRole

IHP/ErrorController.hs

@@ -161,7 +161,7 @@ displayException exception action additionalInfo = do
             [ recordNotFoundExceptionHandlerProd
             ]
 
-    let allHandlers = if fromConfig environment == Environment.Development
+    let allHandlers = if ?context.frameworkConfig.environment == Environment.Development
             then devHandlers
             else prodHandlers
 
@@ -199,7 +199,7 @@ genericHandler exception controller additionalInfo = do
     let prodErrorMessage = [hsx|An exception was raised while running the action|]
     let prodTitle = [hsx|An error happened|]
 
-    let (errorMessage, errorTitle) = if fromConfig environment == Environment.Development
+    let (errorMessage, errorTitle) = if ?context.frameworkConfig.environment == Environment.Development
             then (devErrorMessage, devTitle)
             else (prodErrorMessage, prodTitle)
     let RequestContext { respond } = get #requestContext ?context
@@ -211,9 +211,7 @@ postgresHandler exception controller additionalInfo = do
     let
         handlePostgresOutdatedError :: Show exception => exception -> H.Html -> IO ResponseReceived
         handlePostgresOutdatedError exception errorText = do
-            let ihpIdeBaseUrl = ?context
-                    |> getFrameworkConfig
-                    |> get #ideBaseUrl
+            let ihpIdeBaseUrl = ?context.frameworkConfig.ideBaseUrl
             let title = [hsx|Database looks outdated. {errorText}|]
             let errorMessage = [hsx|
                         <h2>Possible Solutions</h2>
@@ -234,10 +232,8 @@ postgresHandler exception controller additionalInfo = do
 
         handleSqlError :: ModelSupport.EnhancedSqlError -> IO ResponseReceived
         handleSqlError exception = do
-            let ihpIdeBaseUrl = ?context
-                    |> getFrameworkConfig
-                    |> get #ideBaseUrl
-            let sqlError = get #sqlError exception
+            let ihpIdeBaseUrl = ?context.frameworkConfig.ideBaseUrl
+            let sqlError = exception.sqlError
             let title = [hsx|{get #sqlErrorMsg sqlError}|]
             let errorMessage = [hsx|
                         <h2>While running the following Query:</h2>
@@ -585,7 +581,7 @@ renderError errorTitle view = H.docTypeHtml ! A.lang "en" $ [hsx|
 </body>
     |]
         where
-            shouldShowHelpFooter = (fromConfig environment) == Environment.Development
+            shouldShowHelpFooter = ?context.frameworkConfig.environment == Environment.Development
             helpFooter = [hsx|
                 <div class="ihp-error-other-solutions">
                     <a href="https://stackoverflow.com/questions/tagged/ihp" target="_blank">Ask the IHP Community on StackOverflow</a>

IHP/FileStorage/ControllerFunctions.hs

@@ -106,8 +106,8 @@ storeFileWithOptions fileInfo options = do
                 |> get #fileContent
                 |> LBS.writeFile (cs destPath)
 
-            let frameworkConfig = getFrameworkConfig ?context
-            pure $ (get #baseUrl frameworkConfig) <> "/" <> objectPath
+            let frameworkConfig = ?context.frameworkConfig
+            pure $ frameworkConfig.baseUrl <> "/" <> objectPath
         S3Storage { connectInfo, bucket, baseUrl } -> do
             let payload = fileInfo
                     |> get #fileContent
@@ -220,8 +220,8 @@ createTemporaryDownloadUrlFromPathWithExpiredAt validInSeconds objectPath = do
     publicUrlExpiredAt <- addUTCTime (fromIntegral validInSeconds) <$> getCurrentTime
     case storage of
         StaticDirStorage -> do
-            let frameworkConfig = getFrameworkConfig ?context
-            let url = (get #baseUrl frameworkConfig) <> "/" <> objectPath
+            let frameworkConfig = ?context.frameworkConfig
+            let url = frameworkConfig.baseUrl <> "/" <> objectPath
 
             pure TemporaryDownloadUrl { url = cs url, expiredAt = publicUrlExpiredAt }
         S3Storage { connectInfo, bucket} -> do
@@ -361,7 +361,6 @@ removeFileFromStorage StoredFile { path, url } = do
 
 -- | Returns the current storage configured in Config.hs
 storage :: (?context :: context, ConfigProvider context) => FileStorage
-storage = getFrameworkConfig ?context
-        |> get #appConfig
+storage = ?context.frameworkConfig.appConfig
         |> TMap.lookup @FileStorage
         |> fromMaybe (error "Could not find FileStorage in config. Did you call initS3Storage from your Config.hs?")

IHP/FrameworkConfig.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds #-}
 module IHP.FrameworkConfig where
 
 import IHP.Prelude
@@ -374,7 +375,7 @@ data FrameworkConfig = FrameworkConfig
     -- > import Config -- For accessing the RedisUrl data type
     -- > 
     -- > action MyAction = do
-    -- >     let appConfig = ?context |> getFrameworkConfig |> get #appConfig
+    -- >     let appConfig = ?context.frameworkConfig.appConfig
     -- >     let (RedisUrl redisUrl) = appConfig
     -- >                |> TMap.lookup @RedisUrl
     -- >                |> fromMaybe (error "Could not find RedisUrl in config")
@@ -457,25 +458,10 @@ data FrameworkConfig = FrameworkConfig
     , customMiddleware :: !CustomMiddleware
 }
 
-class ConfigProvider a where
-    getFrameworkConfig :: a -> FrameworkConfig
+instance HasField "frameworkConfig" FrameworkConfig FrameworkConfig where
+    getField frameworkConfig = frameworkConfig
 
-instance ConfigProvider FrameworkConfig where
-    getFrameworkConfig = id
-
-instance LoggingProvider FrameworkConfig where
-    getLogger = get #logger
-
-
--- | Proxies FrameworkConfig fields contained in some context that can provider a FrameworkConfig
-fromConfig :: (?context :: context, ConfigProvider context) => (FrameworkConfig -> a) -> a
-fromConfig selector = (selector . getFrameworkConfig) ?context
-{-# INLINE fromConfig #-}
-
--- | Get the current frameworkConfig
-getConfig :: (?context :: context, ConfigProvider context) => FrameworkConfig
-getConfig = fromConfig id
-{-# INLINE getConfig #-}
+type ConfigProvider context = HasField "frameworkConfig" context FrameworkConfig
 
 -- | Returns the default IHP session cookie configuration. Useful when you want to override the default settings in 'sessionCookie'
 defaultIHPSessionCookie :: Text -> Cookie.SetCookie
@@ -506,7 +492,7 @@ defaultLoggerForEnv = \case
 
 -- Returns 'True' when the application is running in a given environment
 isEnvironment :: (?context :: context, ConfigProvider context) => Environment -> Bool
-isEnvironment environment = (getFrameworkConfig ?context |> get #environment) == environment
+isEnvironment environment = ?context.frameworkConfig.environment == environment
 {-# INLINABLE isEnvironment #-}
 
 -- | Returns 'True'  when the application is running in Development mode

IHP/IDE/Data/Controller.hs

@@ -199,7 +199,7 @@ instance Controller DataController where
             Nothing -> renderNotFound
 
 connectToAppDb :: (?context :: ControllerContext) => IO PG.Connection
-connectToAppDb = PG.connectPostgreSQL $ fromConfig databaseUrl
+connectToAppDb = PG.connectPostgreSQL ?context.frameworkConfig.databaseUrl
 
 fetchTableNames :: PG.Connection -> IO [Text]
 fetchTableNames connection = do

IHP/IDE/Types.hs

@@ -130,7 +130,4 @@ data Context = Context
     }
 
 dispatch :: (?context :: Context) => Action -> IO ()
-dispatch = let Context { .. } = ?context in putMVar actionVar
-
-instance Log.LoggingProvider Context where
-    getLogger Context { logger } = logger
+dispatch = let Context { .. } = ?context in putMVar actionVar

IHP/Log.hs

@@ -36,8 +36,7 @@ import qualified System.Log.FastLogger as FastLogger
 -- function corresponding to the desired log level.
 log :: (?context :: context, LoggingProvider context, FastLogger.ToLogStr string) => LogLevel -> string -> IO ()
 log level text = do
-    let logger = getLogger ?context
-    writeLog level logger text
+    writeLog level ?context.logger text
 
 -- | Log a debug level message.
 --

IHP/Log/Types.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds #-}
 {-|
 Module: IHP.Log.Types
 Description:  Types for the IHP logging system
@@ -52,6 +53,7 @@ import System.Log.FastLogger (
     )
 
 import qualified System.Log.FastLogger as FastLogger (FormattedTime)
+import GHC.Records
 
 
 -- some functions brought over from IHP.Prelude
@@ -200,13 +202,12 @@ defaultDestination :: LogDestination
 defaultDestination = Stdout defaultBufSize
 
 -- | Used to get the logger for a given environment.
-class LoggingProvider a where
-    -- | Call in any instance of 'LoggingProvider' get the the environment's current logger.
-    -- Useful in controller and model actions, which both have logging contexts.
-    getLogger :: a -> Logger
+-- | Call in any instance of 'LoggingProvider' get the the environment's current logger.
+-- Useful in controller and model actions, which both have logging contexts.
+type LoggingProvider context = HasField "logger" context Logger
 
-instance {-# OVERLAPS #-} LoggingProvider Logger where
-    getLogger = id
+instance HasField "logger" Logger Logger where
+    getField logger = logger
 
 -- | Create a new 'FastLogger' and wrap it in an IHP 'Logger'.
 -- Use with the default logger settings and record update syntax for nice configuration:

IHP/LoginSupport/Helper/Controller.hs

@@ -165,10 +165,8 @@ enableRowLevelSecurityIfLoggedIn ::
 enableRowLevelSecurityIfLoggedIn = do
     case currentUserOrNothing of
         Just user -> do
-            let rlsAuthenticatedRole = ?context
-                    |> FrameworkConfig.getFrameworkConfig
-                    |> get #rlsAuthenticatedRole
-            let rlsUserId = PG.toField (get #id user)
+            let rlsAuthenticatedRole = ?context.frameworkConfig.rlsAuthenticatedRole
+            let rlsUserId = PG.toField user.id
             let rlsContext = ModelSupport.RowLevelSecurityContext { rlsAuthenticatedRole, rlsUserId}
             putContext rlsContext
         Nothing -> pure ()

IHP/Mail.hs

@@ -47,7 +47,7 @@ buildMail mail =
 --
 -- Uses the mail server provided in the controller context, configured in Config/Config.hs
 sendMail :: (BuildMail mail, ?context :: context, ConfigProvider context) => mail -> IO ()
-sendMail mail = sendWithMailServer (fromConfig mailServer) (buildMail mail)
+sendMail mail = sendWithMailServer ?context.frameworkConfig.mailServer (buildMail mail)
 
 sendWithMailServer :: MailServer -> Mail -> IO ()
 sendWithMailServer SES { .. } mail = do

IHP/ModelSupport.hs

@@ -92,9 +92,6 @@ createModelContext idleTime maxConnections databaseUrl logger = do
     let rowLevelSecurity = Nothing
     pure ModelContext { .. }
 
-instance LoggingProvider ModelContext where
-    getLogger ModelContext { .. } = logger
-
 type family GetModelById id :: Type where
     GetModelById (Maybe (Id' tableName)) = Maybe (GetModelByTableName tableName)
     GetModelById (Id' tableName) = GetModelByTableName tableName

IHP/RouterSupport.hs

@@ -157,7 +157,7 @@ class HasPath controller where
 -- >>> urlTo ShowUserAction { userId = "a32913dd-ef80-4f3e-9a91-7879e17b2ece" }
 -- "http://localhost:8000/ShowUser?userId=a32913dd-ef80-4f3e-9a91-7879e17b2ece"
 urlTo :: (?context :: context, ConfigProvider context, HasPath action) => action -> Text
-urlTo action = (fromConfig baseUrl) <> pathTo action
+urlTo action = ?context.frameworkConfig.baseUrl <> pathTo action
 {-# INLINE urlTo #-}
 
 class HasPath controller => CanRoute controller where

IHP/Test/Mocking.hs

@@ -22,7 +22,7 @@ import qualified IHP.AutoRefresh.Types                     as AutoRefresh
 import qualified IHP.Controller.Context                    as Context
 import           IHP.Controller.RequestContext             (RequestBody (..), RequestContext (..))
 import           IHP.ControllerSupport                     (InitControllerContext, Controller, runActionWithNewContext)
-import           IHP.FrameworkConfig                       (ConfigBuilder (..), FrameworkConfig (..), getFrameworkConfig)
+import           IHP.FrameworkConfig                       (ConfigBuilder (..), FrameworkConfig (..))
 import qualified IHP.FrameworkConfig                       as FrameworkConfig
 import           IHP.ModelSupport                          (createModelContext, Id')
 import           IHP.Prelude
@@ -153,7 +153,7 @@ callActionWithParams controller params = do
 --
 callJob :: forall application job. (ContextParameters application, Typeable application, Job job) => job -> IO ()
 callJob job = do
-    let frameworkConfig = getFrameworkConfig ?context
+    let frameworkConfig = ?context.frameworkConfig
     let ?context = frameworkConfig
     perform job
 

IHP/ViewSupport.hs

@@ -244,9 +244,7 @@ fromCSSFramework :: (?context :: ControllerContext, KnownSymbol field, HasField
 fromCSSFramework field = let cssFramework = theCSSFramework in (get field cssFramework) cssFramework
 
 theCSSFramework :: (?context :: ControllerContext) => CSSFramework
-theCSSFramework = ?context
-        |> FrameworkConfig.getFrameworkConfig
-        |> get #cssFramework
+theCSSFramework = ?context.frameworkConfig.cssFramework
 
 -- | Replaces all newline characters with a @<br>@ tag. Useful for displaying preformatted text.
 --
@@ -258,17 +256,10 @@ nl2br content = content
     |> map (\line -> [hsx|{line}<br/>|])
     |> mconcat
 
-instance {-# OVERLAPPABLE #-} HasField "requestContext" viewContext RequestContext => FrameworkConfig.ConfigProvider viewContext where
-    getFrameworkConfig viewContext = viewContext
-            |> get #requestContext
-            |> get #frameworkConfig
-
 type Html = HtmlWithContext ControllerContext
 
 -- | The URL for the dev-mode live reload server. Typically "ws://localhost:8001"
 liveReloadWebsocketUrl :: (?context :: ControllerContext) => Text
-liveReloadWebsocketUrl = ?context
-    |> FrameworkConfig.getFrameworkConfig
-    |> get #ideBaseUrl
+liveReloadWebsocketUrl = ?context.frameworkConfig.ideBaseUrl
     |> Text.replace "http://" "ws://"
     |> Text.replace "https://" "wss://"