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

Re-exports from ihp-context and adds IHP-specific HasField instances
for accessing the WAI Request and FrameworkConfig.
-}
module IHP.Controller.Context
    ( ControllerContext(..)
    , newControllerContext
    , freeze
    , unfreeze
    , putContext
    , fromContext
    , maybeFromContext
    , fromFrozenContext
    , maybeFromFrozenContext
    , ActionType(..)
    ) where

import Prelude
import Data.IORef (newIORef, readIORef)
import GHC.Records (HasField(..))
import qualified Data.TMap as TypeMap
import IHP.FrameworkConfig.Types (FrameworkConfig(..))
import IHP.Log.Types
import System.IO.Unsafe (unsafePerformIO)
import Network.Wai (Request)
import IHP.RequestVault (requestFrameworkConfig, requestLogger)
import IHP.ActionType (ActionType(..))

-- Re-export from ihp-context, but we shadow newControllerContext
import IHP.ControllerContext (ControllerContext(..), freeze, unfreeze, putContext, fromContext, maybeFromContext, fromFrozenContext, maybeFromFrozenContext)

-- | Creates a new controller context with the WAI Request stored in the TMap
--
-- This version stores the Request in the TMap so it can be retrieved
-- via the HasField instance.
newControllerContext :: (?request :: Request) => IO ControllerContext
newControllerContext :: (?request::Request) => IO ControllerContext
newControllerContext = do
    customFieldsRef <- TMap -> IO (IORef TMap)
forall a. a -> IO (IORef a)
newIORef (Request -> TMap -> TMap
forall a. Typeable a => a -> TMap -> TMap
TypeMap.insert ?request::Request
Request
?request TMap
TypeMap.empty)
    pure ControllerContext { customFieldsRef }
{-# INLINE newControllerContext #-}

-- | Access request from the TMap
--
-- This allows @controllerContext.request@ to work by retrieving
-- the WAI Request stored in the TMap.
instance HasField "request" ControllerContext Request where
    getField :: ControllerContext -> Request
getField (FrozenControllerContext { TMap
customFields :: TMap
customFields :: ControllerContext -> TMap
customFields }) =
        case forall a. Typeable a => TMap -> Maybe a
TypeMap.lookup @Request TMap
customFields of
            Just Request
req -> Request
req
            Maybe Request
Nothing -> [Char] -> Request
forall a. HasCallStack => [Char] -> a
error [Char]
"request: Request not found in controller context. Did you forget to call newControllerContext?"
    getField (ControllerContext { IORef TMap
customFieldsRef :: ControllerContext -> IORef TMap
customFieldsRef :: IORef TMap
customFieldsRef }) =
        -- Hacky but necessary - we need to read the IORef in a pure context
        IO Request -> Request
forall a. IO a -> a
unsafePerformIO (IO Request -> Request) -> IO Request -> Request
forall a b. (a -> b) -> a -> b
$ do
            customFields <- IORef TMap -> IO TMap
forall a. IORef a -> IO a
readIORef IORef TMap
customFieldsRef
            case TypeMap.lookup @Request customFields of
                Just Request
req -> Request -> IO Request
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
req
                Maybe Request
Nothing -> [Char] -> IO Request
forall a. HasCallStack => [Char] -> a
error [Char]
"request: Request not found in controller context. Did you forget to call newControllerContext?"
    {-# INLINABLE getField #-}

-- | Access frameworkConfig via the request vault
instance HasField "frameworkConfig" ControllerContext FrameworkConfig where
    getField :: ControllerContext -> FrameworkConfig
getField ControllerContext
controllerContext = Request -> FrameworkConfig
requestFrameworkConfig ControllerContext
controllerContext.request
    {-# INLINABLE getField #-}

-- | Access logger from the request vault
instance HasField "logger" ControllerContext Logger where
    getField :: ControllerContext -> Logger
getField ControllerContext
context = Request -> Logger
requestLogger ControllerContext
context.request
    {-# INLINABLE getField #-}