refactor: move makeMiddleware and dependencies to separate module; refactor Application imports

src/Application.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Sarah Vaupel <vaupel.sarah@campus.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, David Mosbach <david.mosbach@uniworx.de>
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Sarah Vaupel <vaupel.sarah@campus.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, David Mosbach <david.mosbach@uniworx.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -6,10 +6,8 @@
 
 module Application
     ( getAppSettings, getAppDevSettings
-    , appMain
+    , appMain, develMain
-    , develMain
     , makeFoundation
-    , makeMiddleware
     -- * for DevelMain
     , foundationStoreNum
     , getApplicationRepl
@@ -20,118 +18,99 @@ module Application
     , addPWEntry
     ) where
 
-import Control.Monad.Logger                 (liftLoc, LoggingT(..), MonadLoggerIO(..))
+import Import hiding (cancel, respond)
+
+import Handler.Utils (runAppLoggingT)
+import Handler.Utils.Memcached (manageMemcachedLocalInvalidations)
+
+import Jobs
+
+import Middleware
+
+import Utils.Avs
+import qualified Utils.Pool as Custom
+import Utils.Postgresql
+
+
+import Control.Concurrent.STM.Delay
+import Control.Monad.Logger (liftLoc, LoggingT(..), MonadLoggerIO(..))
+import Control.Monad.Trans.Cont (runContT, callCC)
+import Control.Monad.Trans.Resource
+
+import qualified Data.Acid.Memory as Acid
+import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.IntervalMap.Strict as IntervalMap
+import qualified Data.Map as Map
+import Data.Ratio ((%))
+import qualified Data.Set as Set
+import Data.Streaming.Network (bindPortTCP)
+import qualified Data.Text.Encoding as Text
+import qualified Data.UUID as UUID
+import qualified Data.UUID.V4 as UUID
+
+import qualified Database.Memcached.Binary.IO as Memcached
 import Database.Persist.Postgresql          ( openSimpleConn, pgConnStr, pgPoolIdleTimeout
                                             , pgPoolSize
                                             )
 import Database.Persist.SqlBackend.Internal ( connClose )
 import qualified Database.PostgreSQL.Simple as PG
-import Import                        hiding (cancel, respond)
-import Language.Haskell.TH.Syntax           (qLocation)
-import Network.Wai (Middleware)
-import qualified Network.Wai as Wai
-import Network.Wai.Handler.Warp             (Settings, defaultSettings,
-                                             defaultShouldDisplayException,
-                                             runSettings, runSettingsSocket, setHost,
-                                             setBeforeMainLoop,
-                                             setOnException, setPort, getPort)
-import Network.Connection (settingDisableCertificateValidation)
-import Data.Streaming.Network               (bindPortTCP)
-import Network.Wai.Middleware.RequestLogger (Destination (Logger),
-                                             IPAddrSource (..),
-                                             OutputFormat (..), destination,
-                                             mkRequestLogger, outputFormat)
-import System.Log.FastLogger                ( defaultBufSize, newStderrLoggerSet, newStdoutLoggerSet, newFileLoggerSet
-                                            , toLogStr, rmLoggerSet
-                                            )
-
-import Handler.Utils                        (runAppLoggingT)
 
 import Foreign.Store
 
-import Web.Cookie
+import GHC.RTS.Flags (getRTSFlags)
-import Network.HTTP.Types.Header (hSetCookie)
 
-import qualified Data.UUID as UUID
+import Language.Haskell.TH.Syntax (qLocation)
-import qualified Data.UUID.V4 as UUID
 
-import System.Directory
+import qualified Ldap.Client as Ldap (Host(Plain,Tls))
-
-import Jobs
-
-import qualified Data.Text.Encoding as Text
-
-import Yesod.Auth.OAuth2.AzureAD (oauth2AzureADScoped)
-import Yesod.Auth.Util.PasswordStore
-
-import qualified Data.ByteString.Lazy as LBS
 
+import Network.Connection (settingDisableCertificateValidation)
 import Network.HaskellNet.SSL hiding (Settings)
 import Network.HaskellNet.SMTP.SSL as SMTP hiding (Settings)
+import Network.HTTP.Client.TLS (mkManagerSettings)
+import qualified Network.Minio as Minio
+import Network.Socket (socketPort, Socket, PortNumber)
+import qualified Network.Socket as Socket (close)
+import Network.Wai.Handler.Warp ( Settings
+                                , defaultSettings
+                                , defaultShouldDisplayException
+                                , runSettings, runSettingsSocket
+                                , getPort, setPort
+                                , setHost, setBeforeMainLoop, setOnException
+                                )
+
+import qualified Prometheus
+
+import qualified System.Clock as Clock
+import System.Directory
+import System.Environment (lookupEnv)
+import System.Exit
+import System.Log.FastLogger ( defaultBufSize
+                             , newStderrLoggerSet, newStdoutLoggerSet, newFileLoggerSet
+                             , toLogStr, rmLoggerSet
+                             )
+import System.Log.FastLogger.Date
+import System.Posix.Process (getProcessID)
+import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM, sigINT)
+import qualified System.Posix.Signals as Signals (Handler(..))
+import qualified System.Systemd.Daemon as Systemd
 
 import UnliftIO.Concurrent
 import UnliftIO.Pool
 
-import Control.Monad.Trans.Resource
-
-import System.Log.FastLogger.Date
-import qualified Yesod.Core.Types as Yesod (Logger(..))
-
-import qualified Data.HashMap.Strict as HashMap
-
-import qualified Data.Aeson as Aeson
-
-import System.Exit
-
-import qualified Database.Memcached.Binary.IO as Memcached
-
-import qualified System.Systemd.Daemon as Systemd
-import System.Environment (lookupEnv)
-import System.Posix.Process (getProcessID)
-import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM, sigINT)
-import qualified System.Posix.Signals as Signals (Handler(..))
-
-import Network.Socket (socketPort, Socket, PortNumber)
-import qualified Network.Socket as Socket (close)
-
-import Control.Concurrent.STM.Delay
-import Control.Monad.Trans.Cont (runContT, callCC)
-
-import Data.Ratio ((%))
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-
-import Handler.Utils.Routes (classifyHandler)
-
-import qualified Data.Acid.Memory as Acid
 import qualified Web.ServerSession.Backend.Acid as Acid
-
-import qualified Ldap.Client as Ldap (Host(Plain, Tls))
-
-import qualified Network.Minio as Minio
-
 import Web.ServerSession.Core (StorageException(..))
 
-import GHC.RTS.Flags (getRTSFlags)
+import Yesod.Auth.OAuth2.AzureAD (oauth2AzureADScoped)
-
+import Yesod.Auth.Util.PasswordStore
-import qualified Prometheus
+import qualified Yesod.Core.Types as Yesod (Logger(..))
-
-import qualified Data.IntervalMap.Strict as IntervalMap
-
-import qualified Utils.Pool as Custom
-
-import Utils.Postgresql
-import Handler.Utils.Memcached (manageMemcachedLocalInvalidations)
-
-import qualified System.Clock as Clock
-
-import Utils.Avs
 
 #ifdef DEVELOPMENT
 import Data.Maybe (fromJust)
 import Auth.OAuth2 (azureMockServer)
 #endif
 
+
 -- Import all relevant handler modules here.
 -- (HPack takes care to add new modules to our cabal file nowadays.)
 import Handler.News
@@ -172,7 +151,6 @@ import Handler.SingleSignOut
 import ServantApi () -- YesodSubDispatch instances
 import Servant.API
 import Servant.Client
-import Network.HTTP.Client.TLS (mkManagerSettings)
 
 
 -- This line actually creates our YesodDispatch instance. It is the second half
@@ -533,66 +511,6 @@ createMemcached MemcachedConf{memcachedConnectInfo} = snd <$> allocate (Memcache
 makeApplication :: MonadIO m => UniWorX -> m Application
 makeApplication foundation = liftIO $ makeMiddleware foundation <*> toWaiAppPlain foundation
 
-makeMiddleware :: MonadIO m => UniWorX -> m Middleware
-makeMiddleware app = do
-  logWare <- makeLogWare
-  return $ observeHTTPRequestLatency classifyHandler . logWare . normalizeCookies . defaultMiddlewaresNoLogging
-  where
-    makeLogWare = do
-      logWareMap <- liftIO $ newTVarIO HashMap.empty
-
-      let
-        mkLogWare ls@LogSettings{..} = do
-          logger <- readTVarIO . snd $ appLogger app
-          logWare <- mkRequestLogger def
-            { outputFormat = bool
-                (Apache . bool FromSocket FromHeader $ app ^. _appIpFromHeader)
-                (Detailed True)
-                logDetailed
-            , destination = Logger $ loggerSet logger
-            }
-          atomically . modifyTVar' logWareMap $ HashMap.insert ls logWare
-          return logWare
-
-      void. liftIO $
-        mkLogWare =<< readTVarIO (appLogSettings app)
-
-      return $ \wai req fin -> do
-        lookupRes <- atomically $ do
-          ls <- readTVar $ appLogSettings app
-          existing <- HashMap.lookup ls <$> readTVar logWareMap
-          return $ maybe (Left ls) Right existing
-        logWare <- either mkLogWare return lookupRes
-        logWare wai req fin
-
-    normalizeCookies :: Wai.Middleware
-    normalizeCookies waiApp req respond = waiApp req $ \res -> do
-        resHdrs' <- go $ Wai.responseHeaders res
-        respond $ Wai.mapResponseHeaders (const resHdrs') res
-      where parseSetCookie' :: ByteString -> IO (Maybe SetCookie)
-            parseSetCookie' = fmap (either (\(_ :: SomeException) -> Nothing) Just) . try . evaluate . force . parseSetCookie
-
-            go [] = return []
-            go (hdr@(hdrName, hdrValue) : hdrs)
-              | hdrName == hSetCookie = do
-                  mcookieHdr <- parseSetCookie' hdrValue
-                  case mcookieHdr of
-                    Nothing -> (hdr :) <$> go hdrs
-                    Just cookieHdr -> do
-                      let cookieHdrMatches hdrValue' = maybeT (return False) $ do
-                            cookieHdr' <- MaybeT $ parseSetCookie' hdrValue'
-                            -- See https://tools.ietf.org/html/rfc6265
-                            guard $ setCookiePath     cookieHdr' == setCookiePath     cookieHdr
-                            guard $ setCookieName     cookieHdr' == setCookieName     cookieHdr
-                            guard $ setCookieDomain   cookieHdr' == setCookieDomain   cookieHdr
-                            return True
-                      others <- filterM (\(hdrName', hdrValue') -> and2M (pure $ hdrName' == hSetCookie) (cookieHdrMatches hdrValue')) hdrs
-                      if | null others -> (hdr :) <$> go hdrs
-                         | otherwise   -> go hdrs
-              | otherwise = (hdr :) <$> go hdrs
-
-
-
 -- | Warp settings for the given foundation value.
 warpSettings :: UniWorX -> Settings
 warpSettings foundation = defaultSettings

src/Middleware.hs

@@ -0,0 +1,86 @@
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+module Middleware
+  ( makeMiddleware
+  ) where
+
+import Import
+
+import Handler.Utils.Routes (classifyHandler)
+
+import qualified Data.HashMap.Strict as HashMap
+
+import Network.HTTP.Types.Header (hSetCookie)
+import Network.Wai (Middleware)
+import qualified Network.Wai as Wai
+import Network.Wai.Middleware.RequestLogger ( Destination(Logger)
+                                            , IPAddrSource(..)
+                                            , OutputFormat(..)
+                                            , mkRequestLogger, outputFormat, destination
+                                            )
+
+import Web.Cookie
+
+
+makeMiddleware :: MonadIO m => UniWorX -> m Middleware
+makeMiddleware app = do
+  logWare <- makeLogWare app
+  return $ observeHTTPRequestLatency classifyHandler . logWare . normalizeCookiesWare . defaultMiddlewaresNoLogging
+
+
+makeLogWare :: MonadIO m => UniWorX -> m Middleware
+makeLogWare app = do
+  logWareMap <- liftIO $ newTVarIO HashMap.empty
+
+  let
+    mkLogWare ls@LogSettings{..} = do
+      logger <- readTVarIO . snd $ appLogger app
+      logWare <- mkRequestLogger def
+        { outputFormat = bool
+            (Apache . bool FromSocket FromHeader $ app ^. _appIpFromHeader)
+            (Detailed True)
+            logDetailed
+        , destination = Logger $ loggerSet logger
+        }
+      atomically . modifyTVar' logWareMap $ HashMap.insert ls logWare
+      return logWare
+
+  void. liftIO $
+    mkLogWare =<< readTVarIO (appLogSettings app)
+
+  return $ \wai req fin -> do
+    lookupRes <- atomically $ do
+      ls <- readTVar $ appLogSettings app
+      existing <- HashMap.lookup ls <$> readTVar logWareMap
+      return $ maybe (Left ls) Right existing
+    logWare <- either mkLogWare return lookupRes
+    logWare wai req fin
+
+
+normalizeCookiesWare :: Middleware
+normalizeCookiesWare waiApp req res = waiApp req $ \res' -> do
+    resHdrs' <- go $ Wai.responseHeaders res'
+    res $ Wai.mapResponseHeaders (const resHdrs') res'
+  where parseSetCookie' :: ByteString -> IO (Maybe SetCookie)
+        parseSetCookie' = fmap (either (\(_ :: SomeException) -> Nothing) Just) . try . evaluate . force . parseSetCookie
+
+        go [] = return []
+        go (hdr@(hdrName, hdrValue) : hdrs)
+          | hdrName == hSetCookie = do
+              mcookieHdr <- parseSetCookie' hdrValue
+              case mcookieHdr of
+                Nothing -> (hdr :) <$> go hdrs
+                Just cookieHdr -> do
+                  let cookieHdrMatches hdrValue' = maybeT (return False) $ do
+                        cookieHdr' <- MaybeT $ parseSetCookie' hdrValue'
+                        -- See https://tools.ietf.org/html/rfc6265
+                        guard $ setCookiePath     cookieHdr' == setCookiePath     cookieHdr
+                        guard $ setCookieName     cookieHdr' == setCookieName     cookieHdr
+                        guard $ setCookieDomain   cookieHdr' == setCookieDomain   cookieHdr
+                        return True
+                  others <- filterM (\(hdrName', hdrValue') -> and2M (pure $ hdrName' == hSetCookie) (cookieHdrMatches hdrValue')) hdrs
+                  if | null others -> (hdr :) <$> go hdrs
+                     | otherwise   -> go hdrs
+          | otherwise = (hdr :) <$> go hdrs

templates/default-layout-wrapper.hamlet

@@ -1,6 +1,6 @@
 $newline never
 
-$# SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+$# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Felix Hamann <felix.hamann@campus.lmu.de>, Sarah Vaupel <vaupel.sarah@campus.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
 $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later