{-|
Module: IHP.Controller.Context
Copyright: (c) digitally induced GmbH, 2020
-}
module IHP.Controller.Context where

import IHP.Prelude
import qualified Data.TMap as TypeMap
import qualified Data.Typeable as Typeable
import IHP.Controller.RequestContext
import IHP.FrameworkConfig
import IHP.Log.Types

-- | A container storing useful data along the request lifecycle, such as the request, the current user, set current view layout, flash messages, ...
--
-- The controller context is usually accessed via the @?context@ variable. It's availble inside the action and the view. Think of it as a key-value-map where the key is the type of the value.
--
-- You can store information inside the context using 'putContext':
--
-- >>> newtype CurrentLayout = CurrentLayout Html
-- >>>
-- >>> ?context <- newControllerContext
-- >>> putContext (CurrentLayout layout)
--
-- Inside an action you can access the values using 'fromContext':
--
-- >>> (CurrentLayout layout) <- fromContext
--
-- You can freeze the context and then access values without being inside an IO context (like inside views which are pure):
--
-- Call 'freeze' inside an IO part:
--
-- >>> ?context <- freeze ?context
--
-- ('freeze' is automatically called by IHP before rendering a view, so usually you don't need to call it manually)
--
-- Then use the frozen context from your pure code like this:
--
-- >>> let (CurrentLayout layout) = fromFrozenContext in ...
--
-- The context is initially created before a action is going to be executed. It's life cycle looks like this:
--
-- - @newControllerContext@: The new controller context is created
-- - 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.
-- - @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.
-- - @beforeAction@: Here the context could also be modified. E.g. the layout could be overriden here for the whole controller.
-- - @action ..@: The action itself.
-- - Freezing: Before rendering the response, the container is frozen. Frozen means that all previously mutable fields become immutable.
-- - View Rendering: The frozen container is now used inside the view and layout to display information such as the current user or flash messages
data ControllerContext = ControllerContext { ControllerContext -> RequestContext
requestContext :: RequestContext, ControllerContext -> IORef TMap
customFieldsRef :: IORef TypeMap.TMap }
                       | FrozenControllerContext { requestContext :: RequestContext, ControllerContext -> TMap
customFields :: TypeMap.TMap }

newControllerContext :: (?requestContext :: RequestContext) => IO ControllerContext
newControllerContext :: IO ControllerContext
newControllerContext = do
    IORef TMap
customFieldsRef <- TMap -> IO (IORef TMap)
forall a. a -> IO (IORef a)
newIORef TMap
TypeMap.empty
    ControllerContext -> IO ControllerContext
forall (f :: * -> *) a. Applicative f => a -> f a
pure ControllerContext :: RequestContext -> IORef TMap -> ControllerContext
ControllerContext { $sel:requestContext:ControllerContext :: RequestContext
requestContext = ?requestContext::RequestContext
RequestContext
?requestContext, IORef TMap
customFieldsRef :: IORef TMap
$sel:customFieldsRef:ControllerContext :: IORef TMap
customFieldsRef }
{-# INLINABLE newControllerContext #-}

-- | After freezing a container you can access it's values from pure non-IO code by using 'fromFronzenContext'
--
-- Calls to 'putContext' will throw an exception after it's frozen.
freeze :: ControllerContext -> IO ControllerContext
freeze :: ControllerContext -> IO ControllerContext
freeze ControllerContext { RequestContext
requestContext :: RequestContext
$sel:requestContext:ControllerContext :: ControllerContext -> RequestContext
requestContext, IORef TMap
customFieldsRef :: IORef TMap
$sel:customFieldsRef:ControllerContext :: ControllerContext -> IORef TMap
customFieldsRef } = RequestContext -> TMap -> ControllerContext
FrozenControllerContext RequestContext
requestContext (TMap -> ControllerContext) -> IO TMap -> IO ControllerContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef TMap -> IO TMap
forall a. IORef a -> IO a
readIORef IORef TMap
customFieldsRef
freeze ControllerContext
frozen = ControllerContext -> IO ControllerContext
forall (f :: * -> *) a. Applicative f => a -> f a
pure ControllerContext
frozen
{-# INLINABLE freeze #-}

-- | Returns a unfrozen version of the controller context that can be modified again
--
-- This is used together with 'freeze' by e.g. AutoRefresh to make a immutable copy of the current controller context state
unfreeze :: ControllerContext -> IO ControllerContext
unfreeze :: ControllerContext -> IO ControllerContext
unfreeze FrozenControllerContext { RequestContext
requestContext :: RequestContext
$sel:requestContext:ControllerContext :: ControllerContext -> RequestContext
requestContext, TMap
customFields :: TMap
$sel:customFields:ControllerContext :: ControllerContext -> TMap
customFields } = do
    IORef TMap
customFieldsRef <- TMap -> IO (IORef TMap)
forall a. a -> IO (IORef a)
newIORef TMap
customFields
    ControllerContext -> IO ControllerContext
forall (f :: * -> *) a. Applicative f => a -> f a
pure ControllerContext :: RequestContext -> IORef TMap -> ControllerContext
ControllerContext { IORef TMap
RequestContext
customFieldsRef :: IORef TMap
requestContext :: RequestContext
$sel:customFieldsRef:ControllerContext :: IORef TMap
$sel:requestContext:ControllerContext :: RequestContext
.. }
unfreeze ControllerContext {} = Text -> IO ControllerContext
forall a. Text -> a
error Text
"Cannot call unfreeze on a controller context that is not frozen"
{-# INLINABLE unfreeze #-}


-- | Returns a value from the current controller context
--
-- Throws an exception if the there is no value with the type inside the context
--
-- __Example:__ Read the current user from the context
--
-- >>> user <- fromContext @User
fromContext :: forall value. (?context :: ControllerContext, Typeable value) => IO value
fromContext :: IO value
fromContext = (?context::ControllerContext, Typeable value) => IO (Maybe value)
forall value.
(?context::ControllerContext, Typeable value) =>
IO (Maybe value)
maybeFromContext @value IO (Maybe value) -> (Maybe value -> IO value) -> IO value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just value
value -> value -> IO value
forall (f :: * -> *) a. Applicative f => a -> f a
pure value
value
        Maybe value
Nothing -> do
            let ControllerContext { IORef TMap
customFieldsRef :: IORef TMap
$sel:customFieldsRef:ControllerContext :: ControllerContext -> IORef TMap
customFieldsRef } = ?context::ControllerContext
ControllerContext
?context
            TMap
customFields <- IORef TMap -> IO TMap
forall a. IORef a -> IO a
readIORef IORef TMap
customFieldsRef
            let notFoundMessage :: Text
notFoundMessage = (Text
"Unable to find " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (TypeRep -> Text
forall a. Show a => a -> Text
show (Proxy value -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
Typeable.typeRep (Proxy value
forall k (t :: k). Proxy t
Typeable.Proxy @value))) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in controller context: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TMap -> Text
forall a. Show a => a -> Text
show TMap
customFields)

            Text -> IO value
forall a. Text -> a
error Text
notFoundMessage
{-# INLINABLE fromContext #-}

-- | Returns a value from the current controller context. Requires the context to be frozen.
--
-- __Example:__ Read the current user from the context
--
-- >>> let user = fromFrozenContext @User
fromFrozenContext :: forall value. (?context :: ControllerContext, Typeable value) => value
fromFrozenContext :: value
fromFrozenContext = case (?context::ControllerContext, Typeable value) => Maybe value
forall value.
(?context::ControllerContext, Typeable value) =>
Maybe value
maybeFromFrozenContext @value of
        Just value
value -> value
value
        Maybe value
Nothing -> do
            let FrozenControllerContext { TMap
customFields :: TMap
$sel:customFields:ControllerContext :: ControllerContext -> TMap
customFields } = ?context::ControllerContext
ControllerContext
?context
            let notFoundMessage :: Text
notFoundMessage = (Text
"Unable to find " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (TypeRep -> Text
forall a. Show a => a -> Text
show (Proxy value -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
Typeable.typeRep (Proxy value
forall k (t :: k). Proxy t
Typeable.Proxy @value))) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in controller context: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TMap -> Text
forall a. Show a => a -> Text
show TMap
customFields)

            Text -> value
forall a. Text -> a
error Text
notFoundMessage
{-# INLINABLE fromFrozenContext #-}

maybeFromContext :: forall value. (?context :: ControllerContext, Typeable value) => IO (Maybe value)
maybeFromContext :: IO (Maybe value)
maybeFromContext = do
    ControllerContext
frozen <- ControllerContext -> IO ControllerContext
freeze ?context::ControllerContext
ControllerContext
?context
    let ?context = frozen
    Maybe value -> IO (Maybe value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((?context::ControllerContext, Typeable value) => Maybe value
forall value.
(?context::ControllerContext, Typeable value) =>
Maybe value
maybeFromFrozenContext @value)
{-# INLINABLE maybeFromContext #-}

maybeFromFrozenContext :: forall value. (?context :: ControllerContext, Typeable value) => Maybe value
maybeFromFrozenContext :: Maybe value
maybeFromFrozenContext = case ?context::ControllerContext
ControllerContext
?context of
        FrozenControllerContext { TMap
customFields :: TMap
$sel:customFields:ControllerContext :: ControllerContext -> TMap
customFields } -> TMap -> Maybe value
forall a. Typeable a => TMap -> Maybe a
TypeMap.lookup @value TMap
customFields
        ControllerContext {} -> Text -> Maybe value
forall a. Text -> a
error (Text
"maybeFromFrozenContext called on a non frozen context while trying to access " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (TypeRep -> Text
forall a. Show a => a -> Text
show (Proxy value -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
Typeable.typeRep (Proxy value
forall k (t :: k). Proxy t
Typeable.Proxy @value))))
{-# INLINABLE maybeFromFrozenContext #-}

-- | Puts a value into the context
--
-- Throws an exception if the context is already frozen.
putContext :: forall value. (?context :: ControllerContext, Typeable value) => value -> IO ()
putContext :: value -> IO ()
putContext value
value = do
    let ControllerContext { IORef TMap
customFieldsRef :: IORef TMap
$sel:customFieldsRef:ControllerContext :: ControllerContext -> IORef TMap
customFieldsRef } = ?context::ControllerContext
ControllerContext
?context
    IORef TMap -> (TMap -> TMap) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef TMap
customFieldsRef (value -> TMap -> TMap
forall a. Typeable a => a -> TMap -> TMap
TypeMap.insert value
value)
    () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINABLE putContext #-}

newtype ActionType = ActionType Typeable.TypeRep

instance ConfigProvider ControllerContext where
    getFrameworkConfig :: ControllerContext -> FrameworkConfig
getFrameworkConfig ControllerContext
context = RequestContext -> FrameworkConfig
forall a. ConfigProvider a => a -> FrameworkConfig
getFrameworkConfig (Proxy "requestContext" -> ControllerContext -> RequestContext
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "requestContext" (Proxy "requestContext")
Proxy "requestContext"
#requestContext ControllerContext
context)
    {-# INLINABLE getFrameworkConfig #-}

instance LoggingProvider ControllerContext where
    getLogger :: ControllerContext -> Logger
getLogger = FrameworkConfig -> Logger
forall a. LoggingProvider a => a -> Logger
getLogger (FrameworkConfig -> Logger)
-> (ControllerContext -> FrameworkConfig)
-> ControllerContext
-> Logger
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ControllerContext -> FrameworkConfig
forall a. ConfigProvider a => a -> FrameworkConfig
getFrameworkConfig