diff --git a/src/Application.hs b/src/Application.hs index c5898670c..fbf55b8aa 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Sarah Vaupel , Steffen Jost , David Mosbach +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Sarah Vaupel , Steffen Jost , David Mosbach -- -- 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 diff --git a/src/Middleware.hs b/src/Middleware.hs new file mode 100644 index 000000000..e7e697dd7 --- /dev/null +++ b/src/Middleware.hs @@ -0,0 +1,86 @@ +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost +-- +-- 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 diff --git a/templates/default-layout-wrapper.hamlet b/templates/default-layout-wrapper.hamlet index 18e535c24..28e4befe3 100644 --- a/templates/default-layout-wrapper.hamlet +++ b/templates/default-layout-wrapper.hamlet @@ -1,6 +1,6 @@ $newline never -$# SPDX-FileCopyrightText: 2022 Felix Hamann ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +$# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Felix Hamann , Sarah Vaupel , Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later