diff --git a/Guide/controller.markdown b/Guide/controller.markdown index 0ac9c1412..bbb57a32f 100644 --- a/Guide/controller.markdown +++ b/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) diff --git a/IHP/Assets/ViewFunctions.hs b/IHP/Assets/ViewFunctions.hs index 99a6a60c9..6ab29dc46 100644 --- a/IHP/Assets/ViewFunctions.hs +++ b/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 #-} \ No newline at end of file diff --git a/IHP/Controller/Context.hs b/IHP/Controller/Context.hs index 8712f1944..61a8cd3bc 100644 --- a/IHP/Controller/Context.hs +++ b/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 diff --git a/IHP/Controller/Redirect.hs b/IHP/Controller/Redirect.hs index 8d8754f45..28d213856 100644 --- a/IHP/Controller/Redirect.hs +++ b/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) diff --git a/IHP/Controller/RequestContext.hs b/IHP/Controller/RequestContext.hs index f78338304..bf6a46ddf 100644 --- a/IHP/Controller/RequestContext.hs +++ b/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 diff --git a/IHP/ControllerSupport.hs b/IHP/ControllerSupport.hs index aa4a40f95..99a0dbc3c 100644 --- a/IHP/ControllerSupport.hs +++ b/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 #-} diff --git a/IHP/DataSync/Role.hs b/IHP/DataSync/Role.hs index fcfc4ce27..5856a3044 100644 --- a/IHP/DataSync/Role.hs +++ b/IHP/DataSync/Role.hs @@ -70,6 +70,4 @@ grantPermissions role = do pure () authenticatedRole :: (?context :: context, ConfigProvider context) => Text -authenticatedRole = ?context - |> getFrameworkConfig - |> get #rlsAuthenticatedRole \ No newline at end of file +authenticatedRole = ?context.frameworkConfig.rlsAuthenticatedRole \ No newline at end of file diff --git a/IHP/ErrorController.hs b/IHP/ErrorController.hs index 0daabd896..d8b08b582 100644 --- a/IHP/ErrorController.hs +++ b/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|

Possible Solutions

@@ -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|

While running the following Query:

@@ -585,7 +581,7 @@ renderError errorTitle view = H.docTypeHtml ! A.lang "en" $ [hsx| |] where - shouldShowHelpFooter = (fromConfig environment) == Environment.Development + shouldShowHelpFooter = ?context.frameworkConfig.environment == Environment.Development helpFooter = [hsx|
Ask the IHP Community on StackOverflow diff --git a/IHP/FileStorage/ControllerFunctions.hs b/IHP/FileStorage/ControllerFunctions.hs index 2a7c1dd6a..c6e4c6cbb 100644 --- a/IHP/FileStorage/ControllerFunctions.hs +++ b/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?") diff --git a/IHP/FrameworkConfig.hs b/IHP/FrameworkConfig.hs index 283a543ad..2bfff0bbe 100644 --- a/IHP/FrameworkConfig.hs +++ b/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 diff --git a/IHP/IDE/Data/Controller.hs b/IHP/IDE/Data/Controller.hs index 758f4532b..99c82265d 100644 --- a/IHP/IDE/Data/Controller.hs +++ b/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 diff --git a/IHP/IDE/Types.hs b/IHP/IDE/Types.hs index bb2e5420f..873cb1a75 100644 --- a/IHP/IDE/Types.hs +++ b/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 \ No newline at end of file +dispatch = let Context { .. } = ?context in putMVar actionVar \ No newline at end of file diff --git a/IHP/Log.hs b/IHP/Log.hs index c1614ef71..f852df2ed 100644 --- a/IHP/Log.hs +++ b/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. -- diff --git a/IHP/Log/Types.hs b/IHP/Log/Types.hs index 6f36b2428..b920b394f 100644 --- a/IHP/Log/Types.hs +++ b/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: diff --git a/IHP/LoginSupport/Helper/Controller.hs b/IHP/LoginSupport/Helper/Controller.hs index 397cd6d85..e0128c51d 100644 --- a/IHP/LoginSupport/Helper/Controller.hs +++ b/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 () \ No newline at end of file diff --git a/IHP/Mail.hs b/IHP/Mail.hs index 0d9069a08..2cc97c223 100644 --- a/IHP/Mail.hs +++ b/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 diff --git a/IHP/ModelSupport.hs b/IHP/ModelSupport.hs index 003b21210..9aed09fca 100644 --- a/IHP/ModelSupport.hs +++ b/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 diff --git a/IHP/RouterSupport.hs b/IHP/RouterSupport.hs index c6aa80add..62601807f 100644 --- a/IHP/RouterSupport.hs +++ b/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 diff --git a/IHP/Test/Mocking.hs b/IHP/Test/Mocking.hs index ef30372db..696caf073 100644 --- a/IHP/Test/Mocking.hs +++ b/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 diff --git a/IHP/ViewSupport.hs b/IHP/ViewSupport.hs index 35b11eb8a..b71b0f83e 100644 --- a/IHP/ViewSupport.hs +++ b/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 @
@ tag. Useful for displaying preformatted text. -- @@ -258,17 +256,10 @@ nl2br content = content |> map (\line -> [hsx|{line}
|]) |> 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://"