{-|
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 Data.Maybe (fromMaybe)
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)
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 #-}

-- The following hack is bad, but allows us to override the logger using 'putContext'
-- The alternative would be https://github.com/digitallyinduced/ihp/pull/1921 which is also not very nice
--
-- This can be useful to customize the log formatter for all actions of an app:
--
-- > -- Web/FrontController.hs
-- >
-- > import IHP.Log.Types as Log
-- > import IHP.Controller.Context
-- >
-- > instance InitControllerContext WebApplication where
-- >     initContext = do
-- >     -- ... your other initContext code
-- >
-- >     putContext userIdLogger
-- >
-- > userIdLogger :: (?context :: ControllerContext) => Logger
-- > userIdLogger =
-- >     defaultLogger { Log.formatter = userIdFormatter defaultLogger.formatter }
-- >     where
-- >         defaultLogger = ?context.frameworkConfig.logger
-- >
-- >
-- > userIdFormatter :: (?context :: ControllerContext) => Log.LogFormatter -> Log.LogFormatter
-- > userIdFormatter existingFormatter time level string =
-- >     existingFormatter time level (prependUserId string)
-- >
-- > prependUserId :: (?context :: ControllerContext) => LogStr -> LogStr
-- > prependUserId string =
-- >     toLogStr $ userInfo <> show string
-- >     where
-- >         userInfo =
-- >             case currentUserOrNothing of
-- >                 Just currentUser -> "Authenticated user ID: " <> show currentUser.id <> " "
-- >                 Nothing -> "Anonymous user: "
--
-- This design mistake should be fixed in IHP v2
instance HasField "logger" ControllerContext Logger where
    getField :: ControllerContext -> Logger
getField context :: ControllerContext
context@(FrozenControllerContext { TMap
customFields :: ControllerContext -> TMap
customFields :: TMap
customFields }) = Logger -> Maybe Logger -> Logger
forall a. a -> Maybe a -> a
fromMaybe ControllerContext
context.frameworkConfig.logger (forall a. Typeable a => TMap -> Maybe a
TypeMap.lookup @Logger TMap
customFields)
    getField ControllerContext
context = (IO ControllerContext -> ControllerContext
forall a. IO a -> a
unsafePerformIO (ControllerContext -> IO ControllerContext
freeze ControllerContext
context)).logger -- Hacky, but there's no better way. The only way to retrieve the logger here, is by reading from the IORef in an unsafe way