module IHP.Controller.Response
( respondAndExit
, respondAndExitWithHeaders
, addResponseHeaders
, addResponseHeadersFromContext
, ResponseException (..)
, responseHeadersVaultKey
)
where

import ClassyPrelude
import Network.HTTP.Types.Header
import qualified Network.Wai
import Network.Wai (Response, Request)
import qualified Control.Exception as Exception
import qualified Data.Vault.Lazy as Vault
import System.IO.Unsafe (unsafePerformIO)
import IHP.RequestVault.Helper (lookupRequestVault)

-- | Simple version - just throws the response, no context needed
respondAndExit :: Response -> IO ()
respondAndExit :: Response -> IO ()
respondAndExit Response
response = ResponseException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
Exception.throwIO (Response -> ResponseException
ResponseException Response
response)
{-# INLINE respondAndExit #-}

-- | Version that adds headers from context (for render, etc.)
respondAndExitWithHeaders :: (?request :: Request) => Response -> IO ()
respondAndExitWithHeaders :: (?request::Request) => Response -> IO ()
respondAndExitWithHeaders Response
response = do
    responseWithHeaders <- (?request::Request) => Response -> IO Response
Response -> IO Response
addResponseHeadersFromContext Response
response
    Exception.throwIO (ResponseException responseWithHeaders)
{-# INLINE respondAndExitWithHeaders #-}

-- | Add headers to current response
-- | Returns a Response with headers
--
-- > addResponseHeaders [("Content-Type", "text/html")] response
--
addResponseHeaders :: [Header] -> Response -> Response
addResponseHeaders :: ResponseHeaders -> Response -> Response
addResponseHeaders ResponseHeaders
headers = (ResponseHeaders -> ResponseHeaders) -> Response -> Response
Network.Wai.mapResponseHeaders (\ResponseHeaders
hs -> ResponseHeaders
headers ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. Semigroup a => a -> a -> a
<> ResponseHeaders
hs)
{-# INLINE addResponseHeaders #-}

-- | Add headers to current response, getting the headers from the request vault
-- | Returns a Response with headers
--
-- > addResponseHeadersFromContext response
-- You probabaly want `setHeader`
--
addResponseHeadersFromContext :: (?request :: Request) => Response -> IO Response
addResponseHeadersFromContext :: (?request::Request) => Response -> IO Response
addResponseHeadersFromContext Response
response = do
    headers <- IORef ResponseHeaders -> IO ResponseHeaders
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef (Key (IORef ResponseHeaders) -> Request -> IORef ResponseHeaders
forall value. Typeable value => Key value -> Request -> value
lookupRequestVault Key (IORef ResponseHeaders)
responseHeadersVaultKey ?request::Request
Request
?request)
    let responseWithHeaders = ResponseHeaders -> Response -> Response
addResponseHeaders ResponseHeaders
headers Response
response
    pure responseWithHeaders
{-# INLINE addResponseHeadersFromContext #-}

-- Can be thrown from inside the action to abort the current action execution.
-- Does not indicates a runtime error. It's just used for control flow management.
newtype ResponseException = ResponseException Response

instance Show ResponseException where show :: ResponseException -> String
show ResponseException
_ = String
"ResponseException { .. }"

instance Exception ResponseException

responseHeadersVaultKey :: Vault.Key (IORef [Header])
responseHeadersVaultKey :: Key (IORef ResponseHeaders)
responseHeadersVaultKey = IO (Key (IORef ResponseHeaders)) -> Key (IORef ResponseHeaders)
forall a. IO a -> a
unsafePerformIO IO (Key (IORef ResponseHeaders))
forall a. IO (Key a)
Vault.newKey
{-# NOINLINE responseHeadersVaultKey #-}