|
| 1 | +{-| |
| 2 | +Module: IHP.ControllerContext |
| 3 | +Description: Typed key-value context container with minimal dependencies |
| 4 | +Copyright: (c) digitally induced GmbH, 2020 |
| 5 | +
|
| 6 | +This module provides a typed key-value container where the key is the type of the value. |
| 7 | +It only depends on base and typerep-map, making it suitable for packages that need |
| 8 | +context storage without pulling in the full IHP dependency tree. |
| 9 | +
|
| 10 | +The main IHP framework has heavy transitive dependencies (database, mail, logging, etc.) |
| 11 | +through FrameworkConfig. By extracting ControllerContext into this minimal package, |
| 12 | +other IHP packages like ihp-pagehead can have a much smaller dependency footprint. |
| 13 | +-} |
| 14 | +module IHP.ControllerContext |
| 15 | + ( ControllerContext(..) |
| 16 | + , newControllerContext |
| 17 | + , freeze |
| 18 | + , unfreeze |
| 19 | + , putContext |
| 20 | + , fromContext |
| 21 | + , maybeFromContext |
| 22 | + , fromFrozenContext |
| 23 | + , maybeFromFrozenContext |
| 24 | + ) where |
| 25 | + |
| 26 | +import Prelude |
| 27 | +import Data.IORef |
| 28 | +import qualified Data.TMap as TypeMap |
| 29 | +import qualified Data.Typeable as Typeable |
| 30 | +import Data.Typeable (Typeable) |
| 31 | + |
| 32 | +-- | A container storing useful data along the request lifecycle, such as the request, the current user, set current view layout, flash messages, ... |
| 33 | +-- |
| 34 | +-- The controller context is usually accessed via the @?context@ variable. It's available inside the action and the view. Think of it as a key-value-map where the key is the type of the value. |
| 35 | +-- |
| 36 | +-- You can store information inside the context using 'putContext': |
| 37 | +-- |
| 38 | +-- >>> newtype CurrentLayout = CurrentLayout Html |
| 39 | +-- >>> |
| 40 | +-- >>> ?context <- newControllerContext |
| 41 | +-- >>> putContext (CurrentLayout layout) |
| 42 | +-- |
| 43 | +-- Inside an action you can access the values using 'fromContext': |
| 44 | +-- |
| 45 | +-- >>> (CurrentLayout layout) <- fromContext |
| 46 | +-- |
| 47 | +-- You can freeze the context and then access values without being inside an IO context (like inside views which are pure): |
| 48 | +-- |
| 49 | +-- Call 'freeze' inside an IO part: |
| 50 | +-- |
| 51 | +-- >>> ?context <- freeze ?context |
| 52 | +-- |
| 53 | +-- ('freeze' is automatically called by IHP before rendering a view, so usually you don't need to call it manually) |
| 54 | +-- |
| 55 | +-- Then use the frozen context from your pure code like this: |
| 56 | +-- |
| 57 | +-- >>> let (CurrentLayout layout) = fromFrozenContext in ... |
| 58 | +-- |
| 59 | +-- The context is initially created before a action is going to be executed. Its life cycle looks like this: |
| 60 | +-- |
| 61 | +-- - @newControllerContext@: The new controller context is created |
| 62 | +-- - The 'IHP.ControllerSupport.runActionWithNewContext' fills in a few default values: The current @?application@ and also the Flash Messages to be rendered in the to-be-generated response. |
| 63 | +-- - @initContext@: The initContext function of the @InitControllerContext WebApplication@ (inside your FrontController.hs) is called. There application-specific context can be provided. Usually this is the current user and the default layout. |
| 64 | +-- - @beforeAction@: Here the context could also be modified. E.g. the layout could be overriden here for the whole controller. |
| 65 | +-- - @action ..@: The action itself. |
| 66 | +-- - Freezing: Before rendering the response, the container is frozen. Frozen means that all previously mutable fields become immutable. |
| 67 | +-- - View Rendering: The frozen container is now used inside the view and layout to display information such as the current user or flash messages |
| 68 | +data ControllerContext |
| 69 | + = ControllerContext { customFieldsRef :: IORef TypeMap.TMap } |
| 70 | + | FrozenControllerContext { customFields :: TypeMap.TMap } |
| 71 | + |
| 72 | +-- | Creates a new empty controller context |
| 73 | +newControllerContext :: IO ControllerContext |
| 74 | +newControllerContext = do |
| 75 | + customFieldsRef <- newIORef TypeMap.empty |
| 76 | + pure ControllerContext { customFieldsRef } |
| 77 | +{-# INLINABLE newControllerContext #-} |
| 78 | + |
| 79 | +-- | After freezing a container you can access its values from pure non-IO code by using 'fromFrozenContext' |
| 80 | +-- |
| 81 | +-- Calls to 'putContext' will throw an exception after it's frozen. |
| 82 | +freeze :: ControllerContext -> IO ControllerContext |
| 83 | +freeze ControllerContext { customFieldsRef } = FrozenControllerContext <$> readIORef customFieldsRef |
| 84 | +freeze frozen = pure frozen |
| 85 | +{-# INLINABLE freeze #-} |
| 86 | + |
| 87 | +-- | Returns an unfrozen version of the controller context that can be modified again |
| 88 | +-- |
| 89 | +-- This is used together with 'freeze' by e.g. AutoRefresh to make an immutable copy of the current controller context state |
| 90 | +unfreeze :: ControllerContext -> IO ControllerContext |
| 91 | +unfreeze FrozenControllerContext { customFields } = do |
| 92 | + customFieldsRef <- newIORef customFields |
| 93 | + pure ControllerContext { customFieldsRef } |
| 94 | +unfreeze ControllerContext {} = error "Cannot call unfreeze on a controller context that is not frozen" |
| 95 | +{-# INLINABLE unfreeze #-} |
| 96 | + |
| 97 | +-- | Returns a value from the current controller context |
| 98 | +-- |
| 99 | +-- Throws an exception if there is no value with the type inside the context |
| 100 | +-- |
| 101 | +-- __Example:__ Read the current user from the context |
| 102 | +-- |
| 103 | +-- >>> user <- fromContext @User |
| 104 | +fromContext :: forall value. (?context :: ControllerContext, Typeable value) => IO value |
| 105 | +fromContext = maybeFromContext @value >>= \case |
| 106 | + Just value -> pure value |
| 107 | + Nothing -> do |
| 108 | + let ControllerContext { customFieldsRef } = ?context |
| 109 | + customFields <- readIORef customFieldsRef |
| 110 | + let notFoundMessage = "Unable to find " <> show (Typeable.typeRep (Typeable.Proxy @value)) <> " in controller context: " <> show customFields |
| 111 | + error notFoundMessage |
| 112 | +{-# INLINABLE fromContext #-} |
| 113 | + |
| 114 | +-- | Returns a value from the current controller context. Requires the context to be frozen. |
| 115 | +-- |
| 116 | +-- __Example:__ Read the current user from the context |
| 117 | +-- |
| 118 | +-- >>> let user = fromFrozenContext @User |
| 119 | +fromFrozenContext :: forall value. (?context :: ControllerContext, Typeable value) => value |
| 120 | +fromFrozenContext = case maybeFromFrozenContext @value of |
| 121 | + Just value -> value |
| 122 | + Nothing -> do |
| 123 | + let FrozenControllerContext { customFields } = ?context |
| 124 | + let notFoundMessage = "Unable to find " <> show (Typeable.typeRep (Typeable.Proxy @value)) <> " in controller context: " <> show customFields |
| 125 | + error notFoundMessage |
| 126 | +{-# INLINABLE fromFrozenContext #-} |
| 127 | + |
| 128 | +-- | Returns a value from the current controller context, or Nothing if not found |
| 129 | +maybeFromContext :: forall value. (?context :: ControllerContext, Typeable value) => IO (Maybe value) |
| 130 | +maybeFromContext = do |
| 131 | + frozen <- freeze ?context |
| 132 | + let ?context = frozen |
| 133 | + pure (maybeFromFrozenContext @value) |
| 134 | +{-# INLINABLE maybeFromContext #-} |
| 135 | + |
| 136 | +-- | Returns a value from a frozen controller context, or Nothing if not found |
| 137 | +maybeFromFrozenContext :: forall value. (?context :: ControllerContext, Typeable value) => Maybe value |
| 138 | +maybeFromFrozenContext = case ?context of |
| 139 | + FrozenControllerContext { customFields } -> TypeMap.lookup @value customFields |
| 140 | + ControllerContext {} -> error ("maybeFromFrozenContext called on a non frozen context while trying to access " <> show (Typeable.typeRep (Typeable.Proxy @value))) |
| 141 | +{-# INLINABLE maybeFromFrozenContext #-} |
| 142 | + |
| 143 | +-- | Puts a value into the context |
| 144 | +-- |
| 145 | +-- Throws an exception if the context is already frozen. |
| 146 | +putContext :: forall value. (?context :: ControllerContext, Typeable value) => value -> IO () |
| 147 | +putContext value = do |
| 148 | + let ControllerContext { customFieldsRef } = ?context |
| 149 | + modifyIORef customFieldsRef (TypeMap.insert value) |
| 150 | +{-# INLINABLE putContext #-} |
0 commit comments