{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, TypeFamilies, ConstrainedClassMethods, ScopedTypeVariables, FunctionalDependencies, AllowAmbiguousTypes #-}
module IHP.ControllerSupport
( Action'
, (|>)
, getRequestBody
, getRequestPath
, getRequestPathAndQuery
, getHeader
, request
, requestHeaders
, getFiles
, Controller (..)
, runAction
, Context.ControllerContext
, InitControllerContext (..)
, runActionWithNewContext
, newContextForAction
, respondAndExit
, respondAndExitWithHeaders
, jumpToAction
, requestBodyJSON
, startWebSocketApp
, startWebSocketAppAndFailOnHTTP
, setHeader
, getAppConfig
, Respond
, Request
, rlsContextVaultKey
, setupActionContext
) where
import Prelude
import Data.IORef (IORef, modifyIORef', readIORef)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LBS
import Data.Maybe (fromMaybe)
import Control.Exception.Safe (SomeException, fromException, try, catches, Handler(..))
import Data.Typeable (Typeable)
import IHP.HaskellSupport
import Network.Wai
import qualified Network.HTTP.Types as HTTP
import IHP.ModelSupport
import Network.Wai.Parse as WaiParse
import qualified Data.ByteString.Lazy
import Wai.Request.Params.Middleware (Respond)
import qualified Data.CaseInsensitive
import qualified IHP.ErrorController as ErrorController
import qualified Data.Typeable as Typeable
import IHP.FrameworkConfig.Types (FrameworkConfig (..), ConfigProvider)
import qualified IHP.Controller.Context as Context
import IHP.Controller.Response
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
import qualified Data.TMap as TypeMap
import IHP.RequestVault.ModelContext
import IHP.ActionType (setActionType, actionTypeVaultKey, ActionType(..))
import IHP.RequestVault.Helper (lookupRequestVault)
import qualified Data.Vault.Lazy as Vault
import System.IO.Unsafe (unsafePerformIO)
type Action' = IO ResponseReceived
class (Show controller, Eq controller) => Controller controller where
beforeAction :: (?context :: Context.ControllerContext, ?modelContext :: ModelContext, ?theAction :: controller, ?respond :: Respond, ?request :: Request) => IO ()
beforeAction = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINABLE beforeAction #-}
action :: (?context :: Context.ControllerContext, ?modelContext :: ModelContext, ?theAction :: controller, ?respond :: Respond, ?request :: Request) => controller -> IO ()
class InitControllerContext application where
initContext :: (?modelContext :: ModelContext, ?request :: Request, ?respond :: Respond, ?context :: Context.ControllerContext) => IO ()
initContext = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINABLE initContext #-}
instance InitControllerContext () where
initContext :: (?modelContext::ModelContext, ?request::Request, ?respond::Respond,
?context::ControllerContext) =>
IO ()
initContext = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINE runAction #-}
runAction :: forall controller. (Controller controller, ?context :: Context.ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond) => controller -> IO ResponseReceived
runAction :: forall controller.
(Controller controller, ?context::ControllerContext,
?modelContext::ModelContext, ?respond::Respond) =>
controller -> IO ResponseReceived
runAction controller
controller = do
let ?theAction = controller
?theAction::controller
controller
let ?request = ?context::ControllerContext
ControllerContext
?context.request
let doRunAction :: IO ResponseReceived
doRunAction = do
authenticatedModelContext <- (?request::Request) => ModelContext -> IO ModelContext
ModelContext -> IO ModelContext
prepareRLSIfNeeded ?modelContext::ModelContext
ModelContext
?modelContext
let ?modelContext = authenticatedModelContext
beforeAction
(action controller)
ErrorController.handleNoResponseReturned controller
let handleResponseException :: ResponseException -> t
handleResponseException (ResponseException Response
response) = ?respond::Response -> t
Response -> t
?respond Response
response
IO ResponseReceived
doRunAction IO ResponseReceived
-> [Handler IO ResponseReceived] -> IO ResponseReceived
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m, MonadThrow 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
forall {t}. (?respond::Response -> t) => ResponseException -> t
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, ?request::Request,
?respond::Respond) =>
SomeException -> action -> Text -> IO ResponseReceived
ErrorController.displayException SomeException
exception controller
controller Text
"")]
{-# INLINE newContextForAction #-}
newContextForAction
:: forall application controller
. ( Controller controller
, ?request :: Request
, ?respond :: Respond
, InitControllerContext application
, ?application :: application
, Typeable application
, Typeable controller
)
=> controller -> IO (Either (IO ResponseReceived) Context.ControllerContext)
newContextForAction :: forall application controller.
(Controller controller, ?request::Request, ?respond::Respond,
InitControllerContext application, ?application::application,
Typeable application, Typeable controller) =>
controller -> IO (Either (IO ResponseReceived) ControllerContext)
newContextForAction controller
controller = do
let ?modelContext = ?request::Request
Request
?request.modelContext
controllerContext <- IO ControllerContext
(?request::Request) => IO ControllerContext
Context.newControllerContext
let ?context = controllerContext
Context.putContext ?application
try (initContext @application) >>= \case
Left (SomeException
exception :: SomeException) -> do
Either (IO ResponseReceived) ControllerContext
-> IO (Either (IO ResponseReceived) ControllerContext)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (IO ResponseReceived) ControllerContext
-> IO (Either (IO ResponseReceived) ControllerContext))
-> Either (IO ResponseReceived) ControllerContext
-> IO (Either (IO ResponseReceived) ControllerContext)
forall a b. (a -> b) -> a -> b
$ IO ResponseReceived
-> Either (IO ResponseReceived) ControllerContext
forall a b. a -> Either a b
Left (IO ResponseReceived
-> Either (IO ResponseReceived) ControllerContext)
-> IO ResponseReceived
-> Either (IO ResponseReceived) ControllerContext
forall a b. (a -> b) -> a -> b
$ case SomeException -> Maybe ResponseException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
Just (ResponseException Response
response) -> ?respond::Respond
Respond
?respond Response
response
Maybe ResponseException
Nothing -> SomeException -> controller -> Text -> IO ResponseReceived
forall action.
(Show action, ?context::ControllerContext, ?request::Request,
?respond::Respond) =>
SomeException -> action -> Text -> IO ResponseReceived
ErrorController.displayException SomeException
exception controller
controller Text
" while calling initContext"
Right ()
_ -> Either (IO ResponseReceived) ControllerContext
-> IO (Either (IO ResponseReceived) ControllerContext)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (IO ResponseReceived) ControllerContext
-> IO (Either (IO ResponseReceived) ControllerContext))
-> Either (IO ResponseReceived) ControllerContext
-> IO (Either (IO ResponseReceived) ControllerContext)
forall a b. (a -> b) -> a -> b
$ ControllerContext -> Either (IO ResponseReceived) ControllerContext
forall a b. b -> Either a b
Right ?context::ControllerContext
ControllerContext
?context
{-# NOINLINE setupActionContext #-}
setupActionContext
:: forall application
. ( InitControllerContext application
, ?application :: application
, Typeable application
)
=> Typeable.TypeRep -> Request -> Respond
-> IO (Context.ControllerContext, Maybe SomeException)
setupActionContext :: forall application.
(InitControllerContext application, ?application::application,
Typeable application) =>
TypeRep
-> Request
-> Respond
-> IO (ControllerContext, Maybe SomeException)
setupActionContext TypeRep
controllerTypeRep Request
waiRequest Respond
waiRespond = do
let !request' :: Request
request' = Request
waiRequest { vault = Vault.insert actionTypeVaultKey (ActionType controllerTypeRep) waiRequest.vault }
let ?request = ?request::Request
Request
request'
let ?respond = ?respond::Respond
Respond
waiRespond
let ?modelContext = Request
request'.modelContext
controllerContext <- IO ControllerContext
(?request::Request) => IO ControllerContext
Context.newControllerContext
let ?context = controllerContext
Context.putContext ?application
try (initContext @application) >>= \case
Left SomeException
exception -> (ControllerContext, Maybe SomeException)
-> IO (ControllerContext, Maybe SomeException)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (?context::ControllerContext
ControllerContext
?context, SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
exception)
Right ()
_ -> (ControllerContext, Maybe SomeException)
-> IO (ControllerContext, Maybe SomeException)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (?context::ControllerContext
ControllerContext
?context, Maybe SomeException
forall a. Maybe a
Nothing)
{-# INLINE runActionWithNewContext #-}
runActionWithNewContext :: forall application controller. (Controller controller, ?request :: Request, ?respond :: Respond, InitControllerContext application, ?application :: application, Typeable application, Typeable controller) => controller -> IO ResponseReceived
runActionWithNewContext :: forall application controller.
(Controller controller, ?request::Request, ?respond::Respond,
InitControllerContext application, ?application::application,
Typeable application, Typeable controller) =>
controller -> IO ResponseReceived
runActionWithNewContext controller
controller = do
let request' :: Request
request' = controller -> Request -> Request
forall controller.
Typeable controller =>
controller -> Request -> Request
setActionType controller
controller ?request::Request
Request
?request
let ?request = ?request::Request
Request
request'
contextOrResponse <- controller -> IO (Either (IO ResponseReceived) ControllerContext)
forall application controller.
(Controller controller, ?request::Request, ?respond::Respond,
InitControllerContext application, ?application::application,
Typeable application, Typeable controller) =>
controller -> IO (Either (IO ResponseReceived) ControllerContext)
newContextForAction controller
controller
case contextOrResponse of
Left IO ResponseReceived
response -> IO ResponseReceived
response
Right ControllerContext
context -> do
let ?modelContext = Request -> ModelContext
requestModelContext ?request::Request
Request
?request
let ?context = ?context::ControllerContext
ControllerContext
context
controller -> IO ResponseReceived
forall controller.
(Controller controller, ?context::ControllerContext,
?modelContext::ModelContext, ?respond::Respond) =>
controller -> IO ResponseReceived
runAction controller
controller
prepareRLSIfNeeded :: (?request :: Request) => ModelContext -> IO ModelContext
prepareRLSIfNeeded :: (?request::Request) => ModelContext -> IO ModelContext
prepareRLSIfNeeded ModelContext
modelContext = do
rowLevelSecurityContext <- IORef (Maybe RowLevelSecurityContext)
-> IO (Maybe RowLevelSecurityContext)
forall a. IORef a -> IO a
readIORef (Key (IORef (Maybe RowLevelSecurityContext))
-> Request -> IORef (Maybe RowLevelSecurityContext)
forall value. Typeable value => Key value -> Request -> value
lookupRequestVault Key (IORef (Maybe RowLevelSecurityContext))
rlsContextVaultKey ?request::Request
Request
?request)
case rowLevelSecurityContext of
Just RowLevelSecurityContext
context -> ModelContext -> IO ModelContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModelContext
modelContext { rowLevelSecurity = Just context }
Maybe RowLevelSecurityContext
Nothing -> ModelContext -> IO ModelContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModelContext
modelContext
rlsContextVaultKey :: Vault.Key (IORef (Maybe RowLevelSecurityContext))
rlsContextVaultKey :: Key (IORef (Maybe RowLevelSecurityContext))
rlsContextVaultKey = IO (Key (IORef (Maybe RowLevelSecurityContext)))
-> Key (IORef (Maybe RowLevelSecurityContext))
forall a. IO a -> a
unsafePerformIO IO (Key (IORef (Maybe RowLevelSecurityContext)))
forall a. IO (Key a)
Vault.newKey
{-# NOINLINE rlsContextVaultKey #-}
{-# INLINE startWebSocketApp #-}
startWebSocketApp :: forall webSocketApp application. (?request :: Request, ?respond :: Respond, InitControllerContext application, ?application :: application, Typeable application, WebSockets.WSApp webSocketApp) => webSocketApp -> IO ResponseReceived -> Application
startWebSocketApp :: forall webSocketApp application.
(?request::Request, ?respond::Respond,
InitControllerContext application, ?application::application,
Typeable application, WSApp webSocketApp) =>
webSocketApp -> IO ResponseReceived -> Application
startWebSocketApp webSocketApp
initialState IO ResponseReceived
onHTTP Request
waiRequest Respond
waiRespond = do
let ?modelContext = Request -> ModelContext
requestModelContext ?request::Request
Request
?request
let ?request = ?request::Request
Request
waiRequest
let ?respond = ?respond::Respond
Respond
waiRespond
let handleConnection :: PendingConnection -> IO ()
handleConnection PendingConnection
pendingConnection = do
connection <- PendingConnection -> IO Connection
WebSockets.acceptRequest PendingConnection
pendingConnection
controllerContext <- Context.newControllerContext
let ?context = controllerContext
Context.putContext ?application
try (initContext @application) >>= \case
Left (SomeException
exception :: SomeException) -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Unexpected exception in initContext, " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
exception
Right ()
context -> do
webSocketApp -> Connection -> IO ()
forall state.
(WSApp state, ?context::ControllerContext,
?modelContext::ModelContext) =>
state -> Connection -> IO ()
WebSockets.startWSApp webSocketApp
initialState Connection
connection
let connectionOptions :: ConnectionOptions
connectionOptions = forall state. WSApp state => ConnectionOptions
WebSockets.connectionOptions @webSocketApp
Request
waiRequest
Request -> (Request -> Maybe Response) -> Maybe Response
forall a b. a -> (a -> b) -> b
|> ConnectionOptions
-> (PendingConnection -> IO ()) -> Request -> Maybe Response
WebSockets.websocketsApp ConnectionOptions
connectionOptions PendingConnection -> IO ()
handleConnection
Maybe Response
-> (Maybe Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. a -> (a -> b) -> b
|> \case
Just Response
response -> Respond
waiRespond Response
response
Maybe Response
Nothing -> IO ResponseReceived
onHTTP
{-# INLINE startWebSocketAppAndFailOnHTTP #-}
startWebSocketAppAndFailOnHTTP :: forall webSocketApp application. (?request :: Request, ?respond :: Respond, InitControllerContext application, ?application :: application, Typeable application, WebSockets.WSApp webSocketApp) => webSocketApp -> Application
startWebSocketAppAndFailOnHTTP :: forall webSocketApp application.
(?request::Request, ?respond::Respond,
InitControllerContext application, ?application::application,
Typeable application, WSApp webSocketApp) =>
webSocketApp -> Application
startWebSocketAppAndFailOnHTTP webSocketApp
initialState = forall webSocketApp application.
(?request::Request, ?respond::Respond,
InitControllerContext application, ?application::application,
Typeable application, WSApp webSocketApp) =>
webSocketApp -> IO ResponseReceived -> Application
startWebSocketApp @webSocketApp @application webSocketApp
initialState (?respond::Respond
Respond
?respond Respond -> Respond
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
HTTP.status400 [(HeaderName
hContentType, ByteString
"text/plain")] ByteString
"This endpoint is only available via a WebSocket")
jumpToAction :: forall action. (Controller action, ?context :: Context.ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => action -> IO ()
jumpToAction :: forall action.
(Controller action, ?context::ControllerContext,
?modelContext::ModelContext, ?respond::Respond,
?request::Request) =>
action -> IO ()
jumpToAction action
theAction = do
let ?theAction = action
?theAction::action
theAction
forall controller.
(Controller controller, ?context::ControllerContext,
?modelContext::ModelContext, ?theAction::controller,
?respond::Respond, ?request::Request) =>
IO ()
beforeAction @action
action -> IO ()
forall controller.
(Controller controller, ?context::ControllerContext,
?modelContext::ModelContext, ?theAction::controller,
?respond::Respond, ?request::Request) =>
controller -> IO ()
action action
theAction
getRequestBody :: (?request :: Request) => IO LBS.ByteString
getRequestBody :: (?request::Request) => IO ByteString
getRequestBody =
ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ?request::Request
Request
?request.parsedBody.rawPayload
getRequestPath :: (?request :: Request) => ByteString
getRequestPath :: (?request::Request) => ByteString
getRequestPath = ?request::Request
Request
?request.rawPathInfo
{-# INLINABLE getRequestPath #-}
getRequestPathAndQuery :: (?request :: Request) => ByteString
getRequestPathAndQuery :: (?request::Request) => ByteString
getRequestPathAndQuery = ?request::Request
Request
?request.rawPathInfo ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ?request::Request
Request
?request.rawQueryString
{-# INLINABLE getRequestPathAndQuery #-}
getHeader :: (?request :: Request) => ByteString -> Maybe ByteString
ByteString
name = HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
Data.CaseInsensitive.mk ByteString
name) ?request::Request
Request
?request.requestHeaders
{-# INLINABLE getHeader #-}
setHeader :: (?request :: Request) => Header -> IO ()
Header
header = do
let headersRef :: IORef ResponseHeaders
headersRef = Key (IORef ResponseHeaders) -> Request -> IORef ResponseHeaders
forall value. Typeable value => Key value -> Request -> value
lookupRequestVault Key (IORef ResponseHeaders)
responseHeadersVaultKey ?request::Request
Request
?request
IORef ResponseHeaders
-> (ResponseHeaders -> ResponseHeaders) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef ResponseHeaders
headersRef (Header
header Header -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
:)
{-# INLINABLE setHeader #-}
request :: (?request :: Request) => Request
request :: (?request::Request) => Request
request = ?request::Request
Request
?request
{-# INLINE request #-}
{-# INLINE getFiles #-}
getFiles :: (?request :: Request) => [File Data.ByteString.Lazy.ByteString]
getFiles :: (?request::Request) => [File ByteString]
getFiles =
case ?request::Request
Request
?request.parsedBody of
FormBody { [File ByteString]
files :: [File ByteString]
files :: RequestBody -> [File ByteString]
files } -> [File ByteString]
files
RequestBody
_ -> []
requestBodyJSON :: (?request :: Request) => Aeson.Value
requestBodyJSON :: (?request::Request) => Value
requestBodyJSON =
case ?request::Request
Request
?request.parsedBody of
JSONBody { jsonPayload :: RequestBody -> Maybe Value
jsonPayload = Just Value
value } -> Value
value
RequestBody
_ -> String -> Value
forall a. HasCallStack => String -> a
error String
"Expected JSON body"
getAppConfig :: forall configParameter context. (?context :: context, ConfigProvider context, Typeable configParameter) => configParameter
getAppConfig :: forall configParameter context.
(?context::context, ConfigProvider context,
Typeable configParameter) =>
configParameter
getAppConfig = context
?context::context
?context.frameworkConfig.appConfig
TMap -> (TMap -> Maybe configParameter) -> Maybe configParameter
forall a b. a -> (a -> b) -> b
|> forall a. Typeable a => TMap -> Maybe a
TypeMap.lookup @configParameter
Maybe configParameter
-> (Maybe configParameter -> configParameter) -> configParameter
forall a b. a -> (a -> b) -> b
|> configParameter -> Maybe configParameter -> configParameter
forall a. a -> Maybe a -> a
fromMaybe (String -> configParameter
forall a. HasCallStack => String -> a
error (String
"Could not find " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (TypeRep -> String
forall a. Show a => a -> String
show (Proxy configParameter -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
Typeable.typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Typeable.Proxy @configParameter))) String -> String -> String
forall a. Semigroup a => a -> a -> a
<>String
" in config"))
{-# INLINE getAppConfig #-}