From 889ebe60bfd8458c6be9207938bdff1b5f11471e Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Sat, 2 Mar 2024 22:11:02 +0100 Subject: [PATCH] Made request logger less verbose by not logging requests to static files This was the existing behaviour until we switched out the static middleware a while ago --- IHP/ControllerSupport.hs | 14 ++++++----- IHP/ErrorController.hs | 13 ++++------ IHP/IDE/ToolServer.hs | 5 ++-- IHP/RouterSupport.hs | 51 ++++++++++++++++++++-------------------- IHP/Server.hs | 23 +++++------------- 5 files changed, 47 insertions(+), 59 deletions(-) diff --git a/IHP/ControllerSupport.hs b/IHP/ControllerSupport.hs index a5468b0ef..b32988fde 100644 --- a/IHP/ControllerSupport.hs +++ b/IHP/ControllerSupport.hs @@ -66,6 +66,9 @@ class InitControllerContext application where initContext = pure () {-# INLINABLE initContext #-} +instance InitControllerContext () where + initContext = pure () + {-# INLINE runAction #-} runAction :: forall controller. (Controller controller, ?context :: ControllerContext, ?modelContext :: ModelContext, ?applicationContext :: ApplicationContext, ?requestContext :: RequestContext) => controller -> IO ResponseReceived runAction controller = do @@ -149,12 +152,11 @@ prepareRLSIfNeeded modelContext = do Nothing -> pure modelContext {-# INLINE startWebSocketApp #-} -startWebSocketApp :: forall webSocketApp application. (?applicationContext :: ApplicationContext, ?context :: RequestContext, InitControllerContext application, ?application :: application, Typeable application, WebSockets.WSApp webSocketApp) => IO ResponseReceived -> IO ResponseReceived -startWebSocketApp onHTTP = do +startWebSocketApp :: forall webSocketApp application. (?applicationContext :: ApplicationContext, ?context :: RequestContext, InitControllerContext application, ?application :: application, Typeable application, WebSockets.WSApp webSocketApp) => IO ResponseReceived -> Network.Wai.Application +startWebSocketApp onHTTP request respond = do let ?modelContext = ?applicationContext.modelContext - let ?requestContext = ?context - let respond = ?context.respond - let request = ?context.request + requestContext <- createRequestContext ?applicationContext request respond + let ?requestContext = requestContext let handleConnection pendingConnection = do connection <- WebSockets.acceptRequest pendingConnection @@ -177,7 +179,7 @@ startWebSocketApp onHTTP = do Just response -> respond response Nothing -> onHTTP {-# INLINE startWebSocketAppAndFailOnHTTP #-} -startWebSocketAppAndFailOnHTTP :: forall webSocketApp application. (?applicationContext :: ApplicationContext, ?context :: RequestContext, InitControllerContext application, ?application :: application, Typeable application, WebSockets.WSApp webSocketApp) => IO ResponseReceived +startWebSocketAppAndFailOnHTTP :: forall webSocketApp application. (?applicationContext :: ApplicationContext, ?context :: RequestContext, InitControllerContext application, ?application :: application, Typeable application, WebSockets.WSApp webSocketApp) => Network.Wai.Application startWebSocketAppAndFailOnHTTP = startWebSocketApp @webSocketApp @application (respond $ responseLBS HTTP.status400 [(hContentType, "text/plain")] "This endpoint is only available via a WebSocket") where respond = ?context.respond diff --git a/IHP/ErrorController.hs b/IHP/ErrorController.hs index 29b84d9b8..a468d0bcc 100644 --- a/IHP/ErrorController.hs +++ b/IHP/ErrorController.hs @@ -316,9 +316,10 @@ recordNotFoundExceptionHandlerProd exception controller additionalInfo = in Just (handleNotFound ?context.request ?context.respond) Nothing -> Nothing -handleRouterException :: (?context :: RequestContext) => SomeException -> IO ResponseReceived -handleRouterException exception = - case fromException exception of +handleRouterException :: (?applicationContext :: ApplicationContext) => SomeException -> Application +handleRouterException exception request respond = + let ?context = ?applicationContext + in case fromException exception of Just Router.NoConstructorMatched { expectedType, value, field } -> do let errorMessage = [hsx|

Routing failed with: {tshow exception}

@@ -329,14 +330,12 @@ handleRouterException exception = let title = case value of Just value -> [hsx|Expected {expectedType} for field {field} but got {value}|] Nothing -> [hsx|The action was called without the required {field} parameter|] - let RequestContext { respond } = ?context respond $ responseBuilder status400 [(hContentType, "text/html")] (Blaze.renderHtmlBuilder (renderError title errorMessage)) Just Router.BadType { expectedType, value = Just value, field } -> do let errorMessage = [hsx|

Routing failed with: {tshow exception}

|] let title = [hsx|Query parameter {field} needs to be a {expectedType} but got {value}|] - let RequestContext { respond } = ?context respond $ responseBuilder status400 [(hContentType, "text/html")] (Blaze.renderHtmlBuilder (renderError title errorMessage)) _ -> case fromException exception of Just Router.UnexpectedMethodException { allowedMethods = [Router.DELETE], method = Router.GET } -> do @@ -371,7 +370,6 @@ handleRouterException exception =

|] let title = [hsx|Action was called from a GET request, but needs to be called as a DELETE request|] - let RequestContext { respond } = ?context respond $ responseBuilder status400 [(hContentType, "text/html")] (Blaze.renderHtmlBuilder (renderError title errorMessage)) Just Router.UnexpectedMethodException { allowedMethods = [Router.POST], method = Router.GET } -> do let errorMessage = [hsx| @@ -386,7 +384,6 @@ handleRouterException exception =

|] let title = [hsx|Action was called from a GET request, but needs to be called as a POST request|] - let RequestContext { respond } = ?context respond $ responseBuilder status400 [(hContentType, "text/html")] (Blaze.renderHtmlBuilder (renderError title errorMessage)) Just Router.UnexpectedMethodException { allowedMethods, method } -> do let errorMessage = [hsx| @@ -397,7 +394,6 @@ handleRouterException exception =

|] let title = [hsx|Action was called with a {method} request, but needs to be called with one of these request methods: {allowedMethods}|] - let RequestContext { respond } = ?context respond $ responseBuilder status400 [(hContentType, "text/html")] (Blaze.renderHtmlBuilder (renderError title errorMessage)) _ -> do let errorMessage = [hsx| @@ -407,7 +403,6 @@ handleRouterException exception =

Are you trying to do a DELETE action, but your link is missing class="js-delete"?

|] let title = H.text "Routing failed" - let RequestContext { respond } = ?context respond $ responseBuilder status500 [(hContentType, "text/html")] (Blaze.renderHtmlBuilder (renderError title errorMessage)) diff --git a/IHP/IDE/ToolServer.hs b/IHP/IDE/ToolServer.hs index 722d58478..dae1e7dfa 100644 --- a/IHP/IDE/ToolServer.hs +++ b/IHP/IDE/ToolServer.hs @@ -37,6 +37,7 @@ import qualified System.Process as Process import System.Info import qualified IHP.EnvVar as EnvVar import qualified IHP.AutoRefresh.Types as AutoRefresh +import qualified IHP.AutoRefresh as AutoRefresh import IHP.Controller.Context import qualified IHP.IDE.ToolServer.Layout as Layout import IHP.Controller.Layout @@ -85,7 +86,7 @@ startToolServer' port isDebugMode = do let ?applicationContext = applicationContext requestContext <- ControllerSupport.createRequestContext applicationContext request respond let ?context = requestContext - frontControllerToWAIApp toolServerApplication [] (staticApp request respond) + frontControllerToWAIApp @ToolServerApplication @AutoRefresh.AutoRefreshWSApp (\app -> app) toolServerApplication staticApp request respond let openAppUrl = openUrl ("http://localhost:" <> tshow port <> "/") let warpSettings = Warp.defaultSettings @@ -157,4 +158,4 @@ readDatabaseNeedsMigration :: (?context :: ControllerContext) => IO Bool readDatabaseNeedsMigration = do context <- theDevServerContext state <- readIORef (context.appStateRef) - readIORef (state.databaseNeedsMigration) + readIORef (state.databaseNeedsMigration) \ No newline at end of file diff --git a/IHP/RouterSupport.hs b/IHP/RouterSupport.hs index 2e88ea0be..addf6f42d 100644 --- a/IHP/RouterSupport.hs +++ b/IHP/RouterSupport.hs @@ -84,37 +84,38 @@ runAction' :: forall application controller . ( Controller controller , ?applicationContext :: ApplicationContext - , ?context :: RequestContext , InitControllerContext application , ?application :: application , Typeable application , Typeable controller ) - => controller -> (TMap.TMap -> TMap.TMap) -> IO ResponseReceived -runAction' controller contextSetter = do + => controller -> (TMap.TMap -> TMap.TMap) -> Application +runAction' controller contextSetter request respond = do let ?modelContext = ApplicationContext.modelContext ?applicationContext - let ?requestContext = ?context + requestContext <- createRequestContext ?applicationContext request respond + let ?context = requestContext + let ?requestContext = requestContext contextOrErrorResponse <- newContextForAction contextSetter 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) -> IO ResponseReceived) +type RouteParseResult = IO (TMap.TMap -> TMap.TMap, (TMap.TMap -> TMap.TMap) -> Application) type RouteParser = Parser (RouteParseResult) -toRouteParser :: Parser (IO ResponseReceived) -> RouteParser +toRouteParser :: Parser Application -> RouteParser toRouteParser parser = do controller <- parser pure $ pure (\t -> t, \_ -> controller) -toRouteParser' :: Parser ((TMap.TMap -> TMap.TMap) -> IO ResponseReceived) -> RouteParser +toRouteParser' :: Parser ((TMap.TMap -> TMap.TMap) -> Application) -> RouteParser toRouteParser' parser = do controller <- parser pure $ pure (\t -> t, controller) -toRouteParseResult :: IO ResponseReceived -> RouteParseResult -toRouteParseResult ioResponseReceived = pure (\t -> t, \_ -> ioResponseReceived) +toRouteParseResult :: Application -> RouteParseResult +toRouteParseResult application = pure (\t -> t, \_ -> application) class FrontController application where controllers @@ -132,8 +133,8 @@ defaultRouter => [RouteParser] -> RouteParser defaultRouter additionalControllers = do let allControllers = controllers <> additionalControllers - ioResponseReceived <- choice $ map (\r -> r <* endOfInput) allControllers - pure ioResponseReceived + applications <- choice $ map (\r -> r <* endOfInput) allControllers + pure applications {-# INLINABLE defaultRouter #-} class HasPath controller where @@ -835,13 +836,20 @@ startPage action = get (ByteString.pack (actionPrefix @action)) action withPrefix prefix routes = string prefix >> choice (map (\r -> r <* endOfInput) routes) {-# INLINABLE withPrefix #-} -runApp :: (?applicationContext :: ApplicationContext, ?context :: RequestContext) => RouteParser -> IO ResponseReceived -> IO ResponseReceived -runApp routes notFoundAction = do - let path = ?context.request.rawPathInfo - handleException :: SomeException -> IO (Either String (IO ResponseReceived)) +frontControllerToWAIApp :: forall app (autoRefreshApp :: Type). (?applicationContext :: ApplicationContext, FrontController app, WSApp autoRefreshApp, Typeable autoRefreshApp, InitControllerContext ()) => Middleware -> app -> Application -> Application +frontControllerToWAIApp middleware application notFoundAction request respond = do + let requestContext = RequestContext { request, respond, requestBody = FormBody { params = [], files = [] }, vault = ?applicationContext.session, frameworkConfig = ?applicationContext.frameworkConfig } + + let ?context = requestContext + + let + path = request.rawPathInfo + handleException :: SomeException -> IO (Either String Application) handleException exception = pure $ Right $ ErrorController.handleRouterException exception - routedAction :: Either String (IO ResponseReceived) <- + routes = let ?application = application in router [let ?application = () in webSocketApp @autoRefreshApp] + + routedAction :: Either String Application <- (do res <- evaluate $ parseOnly (routes <* endOfInput) path case res of @@ -850,17 +858,10 @@ runApp routes notFoundAction = do (tmapSetter, controllerFn) <- io pure $ Right $ controllerFn $ tmapSetter ) - -- pure (undefined::IO ResponseReceived))) `Exception.catch` handleException case routedAction of - Left message -> notFoundAction - Right action -> action -{-# INLINABLE runApp #-} - -frontControllerToWAIApp :: forall app. (?applicationContext :: ApplicationContext, ?context :: RequestContext, FrontController app) => app -> [RouteParser] -> IO ResponseReceived -> IO ResponseReceived -frontControllerToWAIApp application additionalControllers notFoundAction = runApp defaultRouter notFoundAction - where - defaultRouter :: RouteParser = (let ?application = application in router additionalControllers) + Left message -> notFoundAction request respond + Right action -> (middleware action) request respond {-# INLINABLE frontControllerToWAIApp #-} mountFrontController :: forall frontController. (?applicationContext :: ApplicationContext, ?context :: RequestContext, FrontController frontController) => frontController -> RouteParser diff --git a/IHP/Server.hs b/IHP/Server.hs index ed93305a6..ce4e8e316 100644 --- a/IHP/Server.hs +++ b/IHP/Server.hs @@ -65,10 +65,9 @@ run configBuilder = do . runServer frameworkConfig . customMiddleware . corsMiddleware - . sessionMiddleware - . requestLoggerMiddleware . methodOverridePost - $ application staticApp + . sessionMiddleware + $ application staticApp requestLoggerMiddleware {-# INLINABLE run #-} @@ -99,7 +98,7 @@ initStaticApp frameworkConfig = do frameworkStaticDir = libDir <> "/static/" frameworkSettings = (Static.defaultWebAppSettings frameworkStaticDir) - { Static.ss404Handler = Just handleNotFound + { Static.ss404Handler = Just (frameworkConfig.requestLoggerMiddleware handleNotFound) , Static.ssMaxAge = maxAge } appSettings = (Static.defaultWebAppSettings "static/") @@ -127,16 +126,9 @@ initCorsMiddleware FrameworkConfig { corsResourcePolicy } = case corsResourcePol Just corsResourcePolicy -> Cors.cors (const (Just corsResourcePolicy)) Nothing -> id -application :: (FrontController RootApplication, ?applicationContext :: ApplicationContext) => Application -> Application -application staticApp request respond = do - requestContext <- ControllerSupport.createRequestContext ?applicationContext request respond - let ?context = requestContext - let builtinControllers = let ?application = () in - [ webSocketApp @AutoRefresh.AutoRefreshWSApp - , webSocketAppWithCustomPath @AutoRefresh.AutoRefreshWSApp "" -- For b.c. with older versions of ihp-auto-refresh.js - ] - - frontControllerToWAIApp RootApplication builtinControllers (staticApp request respond) +application :: (FrontController RootApplication, ?applicationContext :: ApplicationContext) => Application -> Middleware -> Application +application staticApp middleware request respond = do + frontControllerToWAIApp @RootApplication @AutoRefresh.AutoRefreshWSApp middleware RootApplication staticApp request respond {-# INLINABLE application #-} runServer :: (?applicationContext :: ApplicationContext) => FrameworkConfig -> Application -> IO () @@ -152,9 +144,6 @@ runServer FrameworkConfig { environment = Env.Production, appPort, exceptionTrac |> Warp.setPort appPort |> Warp.setOnException exceptionTracker.onException -instance ControllerSupport.InitControllerContext () where - initContext = pure () - withInitalizers :: FrameworkConfig -> ModelContext -> IO () -> IO () withInitalizers frameworkConfig modelContext continue = do let ?context = frameworkConfig