-- 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.Cors (CorsResourcePolicy(..), cors)
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 . corsWare . 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


corsWare :: Middleware
corsWare = cors . const $ Just CorsResourcePolicy
  { corsOrigins = Nothing
  , corsMethods = [ "GET", "HEAD", "POST" ]
  , corsRequestHeaders = []
  , corsExposedHeaders = Nothing
  , corsMaxAge = Just 600
  , corsVaryOrigin = True
  , corsRequireOrigin = False
  , corsIgnoreFailures = False
  }
