{-|
Module: IHP.Controller.Layout
Copyright: (c) digitally induced GmbH, 2020
-}
module IHP.Controller.Layout
( setLayout
, getLayout
, ViewLayout (..)
, viewLayoutVaultKey
, viewLayoutMiddleware
) where

import Prelude
import IHP.ViewSupport
import IHP.Controller.Context
import Network.Wai (Request, Middleware, vault)
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.Vault.Lazy as Vault
import Data.IORef

-- | Wrapper for a layout function that will be applied to views
newtype ViewLayout = ViewLayout ((?context :: ControllerContext, ?request :: Request) => Layout)

-- | Vault key for storing the mutable layout IORef in each request
viewLayoutVaultKey :: Vault.Key (IORef ViewLayout)
viewLayoutVaultKey :: Key (IORef ViewLayout)
viewLayoutVaultKey = IO (Key (IORef ViewLayout)) -> Key (IORef ViewLayout)
forall a. IO a -> a
unsafePerformIO IO (Key (IORef ViewLayout))
forall a. IO (Key a)
Vault.newKey
{-# NOINLINE viewLayoutVaultKey #-}

-- | Middleware that initializes the layout IORef with the identity layout.
-- This must be installed in the middleware stack for setLayout/getLayout to work.
{-# INLINE viewLayoutMiddleware #-}
viewLayoutMiddleware :: Middleware
viewLayoutMiddleware :: Middleware
viewLayoutMiddleware Application
app Request
request Response -> IO ResponseReceived
respond = do
    ref <- ViewLayout -> IO (IORef ViewLayout)
forall a. a -> IO (IORef a)
newIORef (((?context::ControllerContext, ?request::Request) => Layout)
-> ViewLayout
ViewLayout (?context::ControllerContext, ?request::Request) => Layout
Layout
forall a. a -> a
id)
    let request' = Request
request { vault = Vault.insert viewLayoutVaultKey ref (vault request) }
    app request' respond

-- | Set the layout to be used when rendering views.
--
-- Example:
--
-- > instance InitControllerContext WebApplication where
-- >     initContext = do
-- >         setLayout defaultLayout
--
setLayout :: (?context :: ControllerContext, ?request :: Request) => ((?context :: ControllerContext, ?request :: Request) => Layout) -> IO ()
setLayout :: (?context::ControllerContext, ?request::Request) =>
((?context::ControllerContext, ?request::Request) => Layout)
-> IO ()
setLayout (?context::ControllerContext, ?request::Request) => Layout
layout =
    case Key (IORef ViewLayout) -> Vault -> Maybe (IORef ViewLayout)
forall a. Key a -> Vault -> Maybe a
Vault.lookup Key (IORef ViewLayout)
viewLayoutVaultKey (Request -> Vault
vault ?request::Request
Request
?request) of
        Just IORef ViewLayout
ref -> IORef ViewLayout -> ViewLayout -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ViewLayout
ref (((?context::ControllerContext, ?request::Request) => Layout)
-> ViewLayout
ViewLayout (?context::ControllerContext, ?request::Request) => Layout
Layout
layout)
        Maybe (IORef ViewLayout)
Nothing -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"viewLayoutMiddleware not installed. Add it to your middleware stack in Server.hs"
{-# INLINE setLayout #-}

-- | Get the current layout. Returns the identity layout if none was set.
{-# INLINE getLayout #-}
getLayout :: (?request :: Request) => IO ViewLayout
getLayout :: (?request::Request) => IO ViewLayout
getLayout =
    case Key (IORef ViewLayout) -> Vault -> Maybe (IORef ViewLayout)
forall a. Key a -> Vault -> Maybe a
Vault.lookup Key (IORef ViewLayout)
viewLayoutVaultKey (Request -> Vault
vault ?request::Request
Request
?request) of
        Just IORef ViewLayout
ref -> IORef ViewLayout -> IO ViewLayout
forall a. IORef a -> IO a
readIORef IORef ViewLayout
ref
        Maybe (IORef ViewLayout)
Nothing -> [Char] -> IO ViewLayout
forall a. HasCallStack => [Char] -> a
error [Char]
"viewLayoutMiddleware not installed. Add it to your middleware stack in Server.hs"