refactor: move makeMiddleware and dependencies to separate module; refactor Application imports
This commit is contained in:
Sarah Vaupel
parent
de8cf11d4d
commit
5be23c0d52
@ -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
|
||||
, develMain
|
||||
, appMain, 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 Network.HTTP.Types.Header (hSetCookie)
|
||||
import GHC.RTS.Flags (getRTSFlags)
|
||||
|
||||
import qualified Data.UUID as UUID
|
||||
import qualified Data.UUID.V4 as UUID
|
||||
import Language.Haskell.TH.Syntax (qLocation)
|
||||
|
||||
import System.Directory
|
||||
|
||||
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 qualified Ldap.Client as Ldap (Host(Plain,Tls))
|
||||
|
||||
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 qualified Prometheus
|
||||
|
||||
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
|
||||
import Yesod.Auth.OAuth2.AzureAD (oauth2AzureADScoped)
|
||||
import Yesod.Auth.Util.PasswordStore
|
||||
import qualified Yesod.Core.Types as Yesod (Logger(..))
|
||||
|
||||
#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
|
||||
|
||||
86
src/Middleware.hs
Normal file
86
src/Middleware.hs
Normal file
@ -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
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user