Merge pull request #1926 from digitallyinduced/request-logger-static-…

…files

Request logger static files

.envrc

@@ -1 +1,2 @@
 use flake . --impure
+export IHP_LIB=lib/IHP/

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

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|
                     <p>Routing failed with: {tshow exception}</p>
@@ -329,14 +330,12 @@ handleRouterException exception =
             let title = case value of
                     Just value -> [hsx|Expected <strong>{expectedType}</strong> for field <strong>{field}</strong> but got <q>{value}</q>|]
                     Nothing -> [hsx|The action was called without the required <q>{field}</q> 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|
                     <p>Routing failed with: {tshow exception}</p>
                 |]
             let title = [hsx|Query parameter <q>{field}</q> needs to be a <q>{expectedType}</q> but got <q>{value}</q>|]
-            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 =
                         </p>
                     |]
                 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 =
                         </p>
                     |]
                 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 =
                         </p>
                     |]
                 let title = [hsx|Action was called with a {method} request, but needs to be called with one of these request methods: <q>{allowedMethods}</q>|]
-                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 =
                         <p>Are you trying to do a DELETE action, but your link is missing class="js-delete"?</p>
                     |]
                 let title = H.text "Routing failed"
-                let RequestContext { respond } = ?context
                 respond $ responseBuilder status500 [(hContentType, "text/html")] (Blaze.renderHtmlBuilder (renderError title errorMessage))
 
 

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)

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

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

Main.hs

@@ -13,12 +13,19 @@ data DemoController = DemoAction deriving (Eq, Show, Data)
 
 instance AutoRoute DemoController
 instance InitControllerContext RootApplication
-instance FrontController RootApplication where
+data WebApplication = WebApplication deriving (Eq, Show)
+
+instance InitControllerContext WebApplication where
+    initContext = pure ()
+
+instance FrontController WebApplication where
     controllers =
-        [ parseRoute @DemoController
-        , startPage DemoAction
+        [ startPage DemoAction
         ]
 
+instance FrontController RootApplication where
+    controllers = [ mountFrontController WebApplication ]
+
 instance Controller DemoController where
     action DemoAction = renderPlain "Hello World!"
 

Test/Controller/AccessDeniedSpec.hs

@@ -75,7 +75,7 @@ makeApplication :: (?applicationContext :: ApplicationContext) => IO Application
 makeApplication = do
     store <- Session.mapStore_
     let sessionMiddleware :: Middleware = Session.withSession store "SESSION" ?applicationContext.frameworkConfig.sessionCookie ?applicationContext.session
-    pure (sessionMiddleware (Server.application handleNotFound))
+    pure (sessionMiddleware $ (Server.application handleNotFound) (\app -> app))
 
 assertAccessDenied :: SResponse -> IO ()
 assertAccessDenied response = do

Test/Controller/NotFoundSpec.hs

@@ -75,7 +75,7 @@ makeApplication :: (?applicationContext :: ApplicationContext) => IO Application
 makeApplication = do
     store <- Session.mapStore_
     let sessionMiddleware :: Middleware = Session.withSession store "SESSION" ?applicationContext.frameworkConfig.sessionCookie ?applicationContext.session
-    pure (sessionMiddleware (Server.application handleNotFound))
+    pure (sessionMiddleware $ (Server.application handleNotFound) (\app -> app))
 
 assertNotFound :: SResponse -> IO ()
 assertNotFound response = do

Test/RouterSupportSpec.hs

@@ -141,7 +141,7 @@ config = do
     option (AppPort 8000)
 
 application :: (?applicationContext :: ApplicationContext) => Application
-application = Server.application handleNotFound
+application = Server.application handleNotFound (\app -> app)
 
 tests :: Spec
 tests = beforeAll (mockContextNoDatabase WebApplication config) do

Test/SEO/Sitemap.hs

@@ -79,5 +79,5 @@ tests = beforeAll (mockContextNoDatabase WebApplication config) do
     describe "SEO" do
         describe "Sitemap" do
             it "should render a XML Sitemap" $ withContext do
-                runSession (testGet "/sitemap.xml") (Server.application handleNotFound)
+                runSession (testGet "/sitemap.xml") (Server.application handleNotFound (\app -> app))
                     >>= assertSuccess "<?xml version=\"1.0\" encoding=\"UTF-8\"?><urlset xmlns=\"http://www.sitemaps.org/schemas/sitemap/0.9\"><url><loc>http://localhost:8000/test/ShowPost?postId=00000000-0000-0000-0000-000000000000</loc><lastmod>2105-04-16</lastmod><changefreq>hourly</changefreq></url></urlset>"

Test/ViewSupportSpec.hs

@@ -102,7 +102,7 @@ makeApplication :: (?applicationContext :: ApplicationContext) => IO Application
 makeApplication = do
     store <- Session.mapStore_
     let sessionMiddleware :: Middleware = Session.withSession store "SESSION" ?applicationContext.frameworkConfig.sessionCookie ?applicationContext.session
-    pure (sessionMiddleware (Server.application handleNotFound))
+    pure (sessionMiddleware $ (Server.application handleNotFound (\app -> app)))
 
 tests :: Spec
 tests = beforeAll (mockContextNoDatabase WebApplication config) do