Skip to content

Commit

Permalink
Removed putContextRouter from router
Browse files Browse the repository at this point in the history 
This simplifies the routing logic quite abit. We can use the request vault for that logic instead
  • Loading branch information
@mpscholten
mpscholten committed May 9, 2024
1 parent 550ad1a commit 01dc3e5
Show file tree
Hide file tree
Showing 3 changed files with 32 additions and 67 deletions.
18 changes: 3 additions & 15 deletions IHP/ControllerSupport.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -86,17 +86,6 @@ runAction controller = do

doRunAction `catches` [ Handler handleResponseException, Handler (\exception -> ErrorController.displayException exception controller "")]

applyContextSetter :: (TypeMap.TMap -> TypeMap.TMap) -> ControllerContext -> IO ControllerContext
applyContextSetter setter ctx@ControllerContext { customFieldsRef } = do
modifyIORef' customFieldsRef (applySetter setter)
pure $ ctx { customFieldsRef }
where
fromSetter :: (TypeMap.TMap -> TypeMap.TMap) -> TypeMap.TMap
fromSetter f = f TypeMap.empty

applySetter :: (TypeMap.TMap -> TypeMap.TMap) -> TypeMap.TMap -> TypeMap.TMap
applySetter f map = TypeMap.union (fromSetter f) map

{-# INLINE newContextForAction #-}
newContextForAction
:: forall application controller
Expand All @@ -108,15 +97,14 @@ newContextForAction
, Typeable application
, Typeable controller
)
=> (TypeMap.TMap -> TypeMap.TMap) -> controller -> IO (Either (IO ResponseReceived) ControllerContext)
newContextForAction contextSetter controller = do
=> controller -> IO (Either (IO ResponseReceived) ControllerContext)
newContextForAction controller = do
let ?modelContext = ?applicationContext.modelContext
let ?requestContext = ?context
controllerContext <- Context.newControllerContext
let ?context = controllerContext
Context.putContext ?application
Context.putContext (Context.ActionType (Typeable.typeOf controller))
applyContextSetter contextSetter controllerContext

try (initContext @application) >>= \case
Left (exception :: SomeException) -> do
Expand All @@ -130,7 +118,7 @@ newContextForAction contextSetter controller = do
{-# 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 = do
contextOrResponse <- newContextForAction (\t -> t) controller
contextOrResponse <- newContextForAction controller
case contextOrResponse of
Left response -> response
Right context -> do
Expand Down
77 changes: 26 additions & 51 deletions IHP/RouterSupport.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -28,8 +28,6 @@ CanRoute (..)
, onlyAllowMethods
, getMethod
, routeParam
, putContextRouter
, RouteParser
) where

import qualified Prelude
Expand Down Expand Up @@ -74,12 +72,6 @@ import qualified Data.TMap as TMap
import qualified IHP.ApplicationContext as ApplicationContext
import Data.Kind

putContextRouter :: forall value. (Typeable value) => value -> RouteParser -> RouteParser
putContextRouter value parser = do
ioRouteResult <- parser
let ioRouteResult' = fmap (\(routeSetters, action) -> (routeSetters . TMap.insert value, action)) ioRouteResult
pure ioRouteResult'

runAction'
:: forall application controller
. ( Controller controller
Expand All @@ -89,48 +81,32 @@ runAction'
, Typeable application
, Typeable controller
)
=> controller -> (TMap.TMap -> TMap.TMap) -> Application
runAction' controller contextSetter request respond = do
=> controller -> Application
runAction' controller request respond = do
let ?modelContext = ApplicationContext.modelContext ?applicationContext
requestContext <- createRequestContext ?applicationContext request respond
let ?context = requestContext
let ?requestContext = requestContext
contextOrErrorResponse <- newContextForAction contextSetter controller
contextOrErrorResponse <- newContextForAction controller
case contextOrErrorResponse of
Left res -> res
Right context -> let ?context = context in runAction controller
{-# INLINABLE runAction' #-}

type RouteParseResult = IO (TMap.TMap -> TMap.TMap, (TMap.TMap -> TMap.TMap) -> Application)
type RouteParser = Parser (RouteParseResult)

toRouteParser :: Parser Application -> RouteParser
toRouteParser parser = do
controller <- parser
pure $ pure (\t -> t, \_ -> controller)

toRouteParser' :: Parser ((TMap.TMap -> TMap.TMap) -> Application) -> RouteParser
toRouteParser' parser = do
controller <- parser
pure $ pure (\t -> t, controller)

toRouteParseResult :: Application -> RouteParseResult
toRouteParseResult application = pure (\t -> t, \_ -> application)

class FrontController application where
controllers
:: (?applicationContext :: ApplicationContext, ?application :: application, ?context :: RequestContext)
=> [RouteParser]
=> [Parser Application]

router
:: (?applicationContext :: ApplicationContext, ?application :: application, ?context :: RequestContext)
=> [RouteParser] -> RouteParser
=> [Parser Application] -> Parser Application
router = defaultRouter
{-# INLINABLE router #-}

defaultRouter
:: (?applicationContext :: ApplicationContext, ?application :: application, ?context :: RequestContext, FrontController application)
=> [RouteParser] -> RouteParser
=> [Parser Application] -> Parser Application
defaultRouter additionalControllers = do
let allControllers = controllers <> additionalControllers
applications <- choice $ map (\r -> r <* endOfInput) allControllers
Expand Down Expand Up @@ -669,8 +645,8 @@ get :: (Controller action
, ?context :: RequestContext
, Typeable application
, Typeable action
) => ByteString -> action -> RouteParser
get path action = toRouteParser' do
) => ByteString -> action -> Parser Application
get path action = do
method <- getMethod
case method of
GET -> do
Expand Down Expand Up @@ -698,8 +674,8 @@ post :: (Controller action
, ?context :: RequestContext
, Typeable application
, Typeable action
) => ByteString -> action -> RouteParser
post path action = toRouteParser' do
) => ByteString -> action -> Parser Application
post path action = do
method <- getMethod
case method of
POST -> do
Expand Down Expand Up @@ -758,7 +734,7 @@ webSocketApp :: forall webSocketApp application.
, ?context :: RequestContext
, Typeable application
, Typeable webSocketApp
) => RouteParser
) => Parser Application
webSocketApp = webSocketAppWithCustomPath @webSocketApp typeName
where
typeName :: ByteString
Expand All @@ -776,7 +752,7 @@ webSocketAppWithHTTPFallback :: forall webSocketApp application.
, Typeable application
, Typeable webSocketApp
, Controller webSocketApp
) => RouteParser
) => Parser Application
webSocketAppWithHTTPFallback = webSocketAppWithCustomPathAndHTTPFallback @webSocketApp @application typeName
where
typeName :: ByteString
Expand Down Expand Up @@ -804,8 +780,8 @@ webSocketAppWithCustomPath :: forall webSocketApp application.
, ?context :: RequestContext
, Typeable application
, Typeable webSocketApp
) => ByteString -> RouteParser
webSocketAppWithCustomPath path = toRouteParser $ do
) => ByteString -> Parser Application
webSocketAppWithCustomPath path = do
Attoparsec.char '/'
string path
pure (startWebSocketAppAndFailOnHTTP @webSocketApp)
Expand All @@ -820,16 +796,16 @@ webSocketAppWithCustomPathAndHTTPFallback :: forall webSocketApp application.
, Typeable application
, Typeable webSocketApp
, Controller webSocketApp
) => ByteString -> RouteParser
webSocketAppWithCustomPathAndHTTPFallback path = toRouteParser do
) => ByteString -> Parser Application
webSocketAppWithCustomPathAndHTTPFallback path = do
Attoparsec.char '/'
string path
pure (startWebSocketApp @webSocketApp (runActionWithNewContext (WS.initialState @webSocketApp)))
{-# INLINABLE webSocketAppWithCustomPathAndHTTPFallback #-}


-- | Defines the start page for a router (when @\/@ is requested).
startPage :: forall action application. (Controller action, InitControllerContext application, ?application::application, ?applicationContext::ApplicationContext, ?context::RequestContext, Typeable application, Typeable action) => action -> RouteParser
startPage :: forall action application. (Controller action, InitControllerContext application, ?application::application, ?applicationContext::ApplicationContext, ?context::RequestContext, Typeable application, Typeable action) => action -> Parser Application
startPage action = get (ByteString.pack (actionPrefix @action)) action
{-# INLINABLE startPage #-}

Expand All @@ -854,22 +830,21 @@ frontControllerToWAIApp middleware application notFoundAction request respond =
res <- evaluate $ parseOnly (routes <* endOfInput) path
case res of
Left s -> pure $ Left s
Right io -> do
(tmapSetter, controllerFn) <- io
pure $ Right $ controllerFn $ tmapSetter
Right action -> do
pure $ Right action
)
`Exception.catch` handleException
case routedAction of
Left message -> notFoundAction request respond
Right action -> (middleware action) request respond
{-# INLINABLE frontControllerToWAIApp #-}

mountFrontController :: forall frontController. (?applicationContext :: ApplicationContext, ?context :: RequestContext, FrontController frontController) => frontController -> RouteParser
mountFrontController :: forall frontController. (?applicationContext :: ApplicationContext, ?context :: RequestContext, FrontController frontController) => frontController -> Parser Application
mountFrontController application = let ?application = application in router []
{-# INLINABLE mountFrontController #-}

parseRoute :: forall controller application. (?applicationContext :: ApplicationContext, ?context :: RequestContext, Controller controller, CanRoute controller, InitControllerContext application, ?application :: application, Typeable application, Typeable controller) => RouteParser
parseRoute = toRouteParser' $ do
parseRoute :: forall controller application. (?applicationContext :: ApplicationContext, ?context :: RequestContext, Controller controller, CanRoute controller, InitControllerContext application, ?application :: application, Typeable application, Typeable controller) => Parser Application
parseRoute = do
action <- parseRoute' @controller
pure $ runAction' @application action
{-# INLINABLE parseRoute #-}
Expand All @@ -891,13 +866,13 @@ parseRouteWithId
?application :: application,
Typeable application,
Data controller)
=> RouteParser
parseRouteWithId = toRouteParser' do
=> Parser Application
parseRouteWithId = do
action <- parseRoute' @controller
pure (runAction' @application action)

catchAll :: forall action application. (?applicationContext :: ApplicationContext, ?context :: RequestContext, Controller action, InitControllerContext application, Typeable action, ?application :: application, Typeable application, Data action) => action -> RouteParser
catchAll action = toRouteParser' do
catchAll :: forall action application. (?applicationContext :: ApplicationContext, ?context :: RequestContext, Controller action, InitControllerContext application, Typeable action, ?application :: application, Typeable application, Data action) => action -> Parser Application
catchAll action = do
string (ByteString.pack (actionPrefix @action))
_ <- takeByteString
pure (runAction' @application action)
Expand Down
4 changes: 3 additions & 1 deletion IHP/ServerSideComponent/RouterFunctions.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -15,6 +15,8 @@ import IHP.ServerSideComponent.Controller.ComponentsController ()
import Data.Aeson
import IHP.ControllerSupport
import IHP.ApplicationContext
import Network.Wai
import Data.Attoparsec.ByteString.Char8 (Parser)

routeComponent :: forall component controller application.
( Typeable component
Expand All @@ -25,7 +27,7 @@ routeComponent :: forall component controller application.
, ?application :: application
, ?applicationContext :: IHP.ApplicationContext.ApplicationContext
, ?context :: RequestContext
) => RouteParser
) => Parser Application
routeComponent = webSocketAppWithCustomPath @(ComponentsController component) @application ("SSC/" <> typeName)
where
typeName :: ByteString
Expand Down

0 comments on commit 01dc3e5

Please sign in to comment.