{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, TypeFamilies, ConstrainedClassMethods, ScopedTypeVariables, FunctionalDependencies, AllowAmbiguousTypes #-}

module IHP.ControllerSupport
( Action'
, (|>)
, getRequestBody
, getRequestPath
, getRequestPathAndQuery
, getHeader
, RequestContext (RequestContext)
, request
, requestHeaders
, getFiles
, Controller (..)
, runAction
, createRequestContext
, ControllerContext
, InitControllerContext (..)
, runActionWithNewContext
, respondAndExit
, ResponseException (..)
, jumpToAction
, requestBodyJSON
, startWebSocketApp
) where

import ClassyPrelude
import IHP.HaskellSupport
import Data.String.Conversions (cs)
import Network.Wai (Response, Request, ResponseReceived, responseLBS, requestBody, queryString, requestHeaders)
import qualified Network.Wai
import IHP.ModelSupport
import IHP.ApplicationContext (ApplicationContext (..))
import qualified IHP.ApplicationContext as ApplicationContext
import Network.Wai.Parse as WaiParse
import qualified Data.ByteString.Lazy
import qualified IHP.Controller.RequestContext as RequestContext
import IHP.Controller.RequestContext (RequestContext, Respond)
import qualified Data.CaseInsensitive
import Control.Monad.Reader
import qualified Data.TMap as TypeMap
import qualified Control.Exception as Exception
import qualified IHP.ErrorController as ErrorController
import qualified Data.Typeable as Typeable
import IHP.FrameworkConfig (FrameworkConfig)
import qualified IHP.Controller.Context as Context
import IHP.Controller.Context (ControllerContext)
import IHP.FlashMessages.ControllerFunctions
import Network.HTTP.Types.Header
import qualified Data.Aeson as Aeson
import qualified Network.Wai.Handler.WebSockets as WebSockets
import qualified Network.WebSockets as WebSockets
import qualified IHP.WebSocket as WebSockets

type Action' = IO ResponseReceived

class (Show controller, Eq controller) => Controller controller where
    beforeAction :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?theAction :: controller) => IO ()
    beforeAction = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    {-# INLINABLE beforeAction #-}
    action :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?theAction :: controller) => controller -> IO ()

class InitControllerContext application where
    initContext :: (?modelContext :: ModelContext, ?requestContext :: RequestContext, ?applicationContext :: ApplicationContext, ?context :: ControllerContext) => IO ()
    initContext = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    {-# INLINABLE initContext #-}

{-# INLINE runAction #-}
runAction :: forall controller. (Controller controller, ?context :: ControllerContext, ?modelContext :: ModelContext) => controller -> IO ResponseReceived
runAction :: controller -> IO ResponseReceived
runAction controller
controller = do
    let ?theAction = controller
    let respond :: Response -> IO ResponseReceived
respond = ?context::ControllerContext
ControllerContext
?context ControllerContext
-> (ControllerContext -> RequestContext) -> RequestContext
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> 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 RequestContext
-> (RequestContext -> Response -> IO ResponseReceived)
-> Response
-> IO ResponseReceived
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "respond"
-> RequestContext -> Response -> IO ResponseReceived
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "respond" (Proxy "respond")
Proxy "respond"
#respond

    let doRunAction :: IO ResponseReceived
doRunAction = do
            IO ()
forall controller.
(Controller controller, ?context::ControllerContext,
 ?modelContext::ModelContext, ?theAction::controller) =>
IO ()
beforeAction
            (controller -> IO ()
forall controller.
(Controller controller, ?context::ControllerContext,
 ?modelContext::ModelContext, ?theAction::controller) =>
controller -> IO ()
action controller
controller)
            controller -> IO ResponseReceived
forall controller.
(Show controller, ?context::ControllerContext) =>
controller -> IO ResponseReceived
ErrorController.handleNoResponseReturned controller
controller

    let handleResponseException :: ResponseException -> IO ResponseReceived
handleResponseException  (ResponseException Response
response) = Response -> IO ResponseReceived
respond Response
response

    IO ResponseReceived
doRunAction IO ResponseReceived
-> [Handler IO ResponseReceived] -> IO ResponseReceived
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> [Handler m a] -> m a
`catches` [ (ResponseException -> IO ResponseReceived)
-> Handler IO ResponseReceived
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ResponseException -> IO ResponseReceived
handleResponseException, (SomeException -> IO ResponseReceived)
-> Handler IO ResponseReceived
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\SomeException
exception -> SomeException -> controller -> Text -> IO ResponseReceived
forall action.
(Show action, ?context::ControllerContext) =>
SomeException -> action -> Text -> IO ResponseReceived
ErrorController.displayException SomeException
exception controller
controller Text
"")]

{-# INLINE runActionWithNewContext #-}
runActionWithNewContext :: forall application controller. (Controller controller, ?applicationContext :: ApplicationContext, ?context :: RequestContext, InitControllerContext application, ?application :: application, Typeable application, Typeable controller) => controller -> IO ResponseReceived
runActionWithNewContext :: controller -> IO ResponseReceived
runActionWithNewContext controller
controller = do
    let ?modelContext = ApplicationContext.modelContext ?applicationContext
    let ?requestContext = ?context
    ControllerContext
controllerContext <- IO ControllerContext
(?requestContext::RequestContext) => IO ControllerContext
Context.newControllerContext
    let ?context = controllerContext
    application -> IO ()
forall value.
(?context::ControllerContext, Typeable value) =>
value -> IO ()
Context.putContext application
?application::application
?application
    ActionType -> IO ()
forall value.
(?context::ControllerContext, Typeable value) =>
value -> IO ()
Context.putContext (TypeRep -> ActionType
Context.ActionType (controller -> TypeRep
forall a. Typeable a => a -> TypeRep
Typeable.typeOf controller
controller))
    IO ()
(?context::ControllerContext) => IO ()
initFlashMessages

    IO () -> IO (Either SomeException ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try ((InitControllerContext application, ?modelContext::ModelContext,
 ?requestContext::RequestContext,
 ?applicationContext::ApplicationContext,
 ?context::ControllerContext) =>
IO ()
forall application.
(InitControllerContext application, ?modelContext::ModelContext,
 ?requestContext::RequestContext,
 ?applicationContext::ApplicationContext,
 ?context::ControllerContext) =>
IO ()
initContext @application) IO (Either SomeException ())
-> (Either SomeException () -> IO ResponseReceived)
-> IO ResponseReceived
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left SomeException
exception -> do
            -- Calling `initContext` might fail, so we provide a bit better error messages here
            SomeException -> controller -> Text -> IO ResponseReceived
forall action.
(Show action, ?context::ControllerContext) =>
SomeException -> action -> Text -> IO ResponseReceived
ErrorController.displayException SomeException
exception controller
controller Text
" while calling initContext"
        Right ()
context -> do
            controller -> IO ResponseReceived
forall controller.
(Controller controller, ?context::ControllerContext,
 ?modelContext::ModelContext) =>
controller -> IO ResponseReceived
runAction controller
controller

{-# INLINE startWebSocketApp #-}
startWebSocketApp :: forall webSocketApp application. (?applicationContext :: ApplicationContext, ?context :: RequestContext, InitControllerContext application, ?application :: application, Typeable application, WebSockets.WSApp webSocketApp) => IO ResponseReceived
startWebSocketApp :: IO ResponseReceived
startWebSocketApp = do
    let ?modelContext = ApplicationContext.modelContext ?applicationContext
    let ?requestContext = ?context
    let respond :: Response -> IO ResponseReceived
respond = ?context::RequestContext
RequestContext
?context RequestContext
-> (RequestContext -> Response -> IO ResponseReceived)
-> Response
-> IO ResponseReceived
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "respond"
-> RequestContext -> Response -> IO ResponseReceived
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "respond" (Proxy "respond")
Proxy "respond"
#respond
    let request :: Request
request = ?context::RequestContext
RequestContext
?context RequestContext -> (RequestContext -> Request) -> Request
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "request" -> RequestContext -> Request
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "request" (Proxy "request")
Proxy "request"
#request

    let handleConnection :: PendingConnection -> IO ()
handleConnection PendingConnection
pendingConnection = do
            Connection
connection <- PendingConnection -> IO Connection
WebSockets.acceptRequest PendingConnection
pendingConnection

            ControllerContext
controllerContext <- IO ControllerContext
(?requestContext::RequestContext) => IO ControllerContext
Context.newControllerContext
            let ?context = controllerContext

            application -> IO ()
forall value.
(?context::ControllerContext, Typeable value) =>
value -> IO ()
Context.putContext application
?application::application
?application

            IO () -> IO (Either SomeException ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try ((InitControllerContext application, ?modelContext::ModelContext,
 ?requestContext::RequestContext,
 ?applicationContext::ApplicationContext,
 ?context::ControllerContext) =>
IO ()
forall application.
(InitControllerContext application, ?modelContext::ModelContext,
 ?requestContext::RequestContext,
 ?applicationContext::ApplicationContext,
 ?context::ControllerContext) =>
IO ()
initContext @application) IO (Either SomeException ())
-> (Either SomeException () -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Left (SomeException
exception :: SomeException) -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Unexpected exception in initContext, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall a. Show a => a -> Text
tshow SomeException
exception
                Right ()
context -> do
                    Connection -> IO ()
forall state.
(WSApp state, ?applicationContext::ApplicationContext,
 ?requestContext::RequestContext, ?context::ControllerContext) =>
Connection -> IO ()
WebSockets.startWSApp @webSocketApp Connection
connection

    Request
request
        Request -> (Request -> Maybe Response) -> Maybe Response
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> ConnectionOptions
-> (PendingConnection -> IO ()) -> Request -> Maybe Response
WebSockets.websocketsApp ConnectionOptions
WebSockets.defaultConnectionOptions PendingConnection -> IO ()
handleConnection
        Maybe Response
-> (Maybe Response -> IO ResponseReceived) -> IO ResponseReceived
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> \case
            Just Response
response -> Response -> IO ResponseReceived
respond Response
response
            Maybe Response
Nothing -> String -> IO ResponseReceived
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected websocket request"


jumpToAction :: forall action. (Controller action, ?context :: ControllerContext, ?modelContext :: ModelContext) => action -> IO ()
jumpToAction :: action -> IO ()
jumpToAction action
theAction = do
    let ?theAction = theAction
    (Controller action, ?context::ControllerContext,
 ?modelContext::ModelContext, ?theAction::action) =>
IO ()
forall controller.
(Controller controller, ?context::ControllerContext,
 ?modelContext::ModelContext, ?theAction::controller) =>
IO ()
beforeAction @action
    action -> IO ()
forall controller.
(Controller controller, ?context::ControllerContext,
 ?modelContext::ModelContext, ?theAction::controller) =>
controller -> IO ()
action action
theAction

{-# INLINE getRequestBody #-}
getRequestBody :: (?context :: ControllerContext) => IO LByteString
getRequestBody :: IO LByteString
getRequestBody = 
    ?context::ControllerContext
ControllerContext
?context
    ControllerContext
-> (ControllerContext -> RequestContext) -> RequestContext
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> 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
    RequestContext -> (RequestContext -> RequestBody) -> RequestBody
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "requestBody" -> RequestContext -> RequestBody
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "requestBody" (Proxy "requestBody")
Proxy "requestBody"
#requestBody
    RequestBody -> (RequestBody -> IO LByteString) -> IO LByteString
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> \case
        RequestContext.JSONBody { LByteString
$sel:rawPayload:FormBody :: RequestBody -> LByteString
rawPayload :: LByteString
rawPayload } -> LByteString -> IO LByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure LByteString
rawPayload
        RequestBody
_ -> Request -> IO LByteString
Network.Wai.lazyRequestBody Request
(?context::ControllerContext) => Request
request

-- | Returns the request path, e.g. @/Users@ or @/CreateUser@
getRequestPath :: (?context :: ControllerContext) => ByteString
getRequestPath :: ByteString
getRequestPath = Request -> ByteString
Network.Wai.rawPathInfo Request
(?context::ControllerContext) => Request
request
{-# INLINABLE getRequestPath #-}

-- | Returns the request path and the query params, e.g. @/ShowUser?userId=9bd6b37b-2e53-40a4-bb7b-fdba67d6af42@
getRequestPathAndQuery :: (?context :: ControllerContext) => ByteString
getRequestPathAndQuery :: ByteString
getRequestPathAndQuery = Request -> ByteString
Network.Wai.rawPathInfo Request
(?context::ControllerContext) => Request
request ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
Network.Wai.rawQueryString Request
(?context::ControllerContext) => Request
request
{-# INLINABLE getRequestPathAndQuery #-}

-- | Returns a header value for a given header name. Returns Nothing if not found
--
-- The header is looked up in a case insensitive way.
--
-- >>> getHeader "Content-Type"
-- Just "text/html"
--
-- >>> getHeader "X-My-Custom-Header"
-- Nothing
--
getHeader :: (?context :: ControllerContext) => ByteString -> Maybe ByteString
getHeader :: ByteString -> Maybe ByteString
getHeader ByteString
name = ContainerKey RequestHeaders
-> RequestHeaders -> Maybe (MapValue RequestHeaders)
forall map.
IsMap map =>
ContainerKey map -> map -> Maybe (MapValue map)
lookup (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
Data.CaseInsensitive.mk ByteString
name) (Request -> RequestHeaders
Network.Wai.requestHeaders Request
(?context::ControllerContext) => Request
request)
{-# INLINABLE getHeader #-}

-- | Returns the current HTTP request.
--
-- See https://hackage.haskell.org/package/wai-3.2.2.1/docs/Network-Wai.html#t:Request
request :: (?context :: ControllerContext) => Network.Wai.Request
request :: Request
request = RequestContext
(?context::ControllerContext) => RequestContext
requestContext RequestContext -> (RequestContext -> Request) -> Request
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "request" -> RequestContext -> Request
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "request" (Proxy "request")
Proxy "request"
#request
{-# INLINE request #-}

{-# INLINE getFiles #-}
getFiles :: (?context :: ControllerContext) => [File Data.ByteString.Lazy.ByteString]
getFiles :: [File LByteString]
getFiles = RequestContext
(?context::ControllerContext) => RequestContext
requestContext
        RequestContext -> (RequestContext -> RequestBody) -> RequestBody
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "requestBody" -> RequestContext -> RequestBody
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "requestBody" (Proxy "requestBody")
Proxy "requestBody"
#requestBody
        RequestBody
-> (RequestBody -> [File LByteString]) -> [File LByteString]
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> \case
            RequestContext.FormBody { [File LByteString]
$sel:files:FormBody :: RequestBody -> [File LByteString]
files :: [File LByteString]
files } -> [File LByteString]
files
            RequestBody
_ -> []

requestContext :: (?context :: ControllerContext) => RequestContext
requestContext :: RequestContext
requestContext = 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 ?context::ControllerContext
ControllerContext
?context
{-# INLINE requestContext #-}

requestBodyJSON :: (?context :: ControllerContext) => Aeson.Value
requestBodyJSON :: Value
requestBodyJSON =
    ?context::ControllerContext
ControllerContext
?context
    ControllerContext
-> (ControllerContext -> RequestContext) -> RequestContext
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> 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
    RequestContext -> (RequestContext -> RequestBody) -> RequestBody
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "requestBody" -> RequestContext -> RequestBody
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "requestBody" (Proxy "requestBody")
Proxy "requestBody"
#requestBody
    RequestBody -> (RequestBody -> Value) -> Value
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> \case
        RequestContext.JSONBody { $sel:jsonPayload:FormBody :: RequestBody -> Maybe Value
jsonPayload = Just Value
value } -> Value
value
        RequestBody
_ -> String -> Value
forall a. HasCallStack => String -> a
error String
"Expected JSON body"

{-# INLINE createRequestContext #-}
createRequestContext :: ApplicationContext -> Request -> Respond -> IO RequestContext
createRequestContext :: ApplicationContext
-> Request
-> (Response -> IO ResponseReceived)
-> IO RequestContext
createRequestContext ApplicationContext { Key (Session IO String String)
$sel:session:ApplicationContext :: ApplicationContext -> Key (Session IO String String)
session :: Key (Session IO String String)
session, FrameworkConfig
$sel:frameworkConfig:ApplicationContext :: ApplicationContext -> FrameworkConfig
frameworkConfig :: FrameworkConfig
frameworkConfig } Request
request Response -> IO ResponseReceived
respond = do
    let contentType :: Maybe (MapValue RequestHeaders)
contentType = ContainerKey RequestHeaders
-> RequestHeaders -> Maybe (MapValue RequestHeaders)
forall map.
IsMap map =>
ContainerKey map -> map -> Maybe (MapValue map)
lookup ContainerKey RequestHeaders
CI ByteString
hContentType (Request -> RequestHeaders
requestHeaders Request
request)
    RequestBody
requestBody <- case Maybe (MapValue RequestHeaders)
contentType of
        Maybe (MapValue RequestHeaders)
"application/json" -> do
            LByteString
rawPayload <- Request -> IO LByteString
Network.Wai.lazyRequestBody Request
request
            let jsonPayload :: Maybe Value
jsonPayload = LByteString -> Maybe Value
forall a. FromJSON a => LByteString -> Maybe a
Aeson.decode LByteString
rawPayload
            RequestBody -> IO RequestBody
forall (f :: * -> *) a. Applicative f => a -> f a
pure JSONBody :: Maybe Value -> LByteString -> RequestBody
RequestContext.JSONBody { Maybe Value
jsonPayload :: Maybe Value
$sel:jsonPayload:FormBody :: Maybe Value
jsonPayload, LByteString
rawPayload :: LByteString
$sel:rawPayload:FormBody :: LByteString
rawPayload }
        Maybe (MapValue RequestHeaders)
_ -> do
            ([Param]
params, [File LByteString]
files) <- ParseRequestBodyOptions
-> BackEnd LByteString
-> Request
-> IO ([Param], [File LByteString])
forall y.
ParseRequestBodyOptions
-> BackEnd y -> Request -> IO ([Param], [File y])
WaiParse.parseRequestBodyEx ParseRequestBodyOptions
WaiParse.defaultParseRequestBodyOptions BackEnd LByteString
forall (m :: * -> *) ignored1 ignored2.
Monad m =>
ignored1 -> ignored2 -> m ByteString -> m LByteString
WaiParse.lbsBackEnd Request
request
            RequestBody -> IO RequestBody
forall (f :: * -> *) a. Applicative f => a -> f a
pure FormBody :: [Param] -> [File LByteString] -> RequestBody
RequestContext.FormBody { [Param]
[File LByteString]
$sel:params:FormBody :: [Param]
files :: [File LByteString]
params :: [Param]
$sel:files:FormBody :: [File LByteString]
.. }

    RequestContext -> IO RequestContext
forall (f :: * -> *) a. Applicative f => a -> f a
pure RequestContext :: Request
-> (Response -> IO ResponseReceived)
-> RequestBody
-> Key (Session IO String String)
-> FrameworkConfig
-> RequestContext
RequestContext.RequestContext { Request
$sel:request:RequestContext :: Request
request :: Request
request, Response -> IO ResponseReceived
$sel:respond:RequestContext :: Response -> IO ResponseReceived
respond :: Response -> IO ResponseReceived
respond, RequestBody
$sel:requestBody:RequestContext :: RequestBody
requestBody :: RequestBody
requestBody, $sel:vault:RequestContext :: Key (Session IO String String)
vault = Key (Session IO String String)
session, FrameworkConfig
$sel:frameworkConfig:RequestContext :: FrameworkConfig
frameworkConfig :: FrameworkConfig
frameworkConfig }

-- 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


respondAndExit :: Response -> IO ()
respondAndExit :: Response -> IO ()
respondAndExit Response
response = ResponseException -> IO ()
forall e a. Exception e => e -> IO a
Exception.throwIO (Response -> ResponseException
ResponseException Response
response)
{-# INLINE respondAndExit #-}