-- SPDX-FileCopyrightText: 2022 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>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Application
    ( getAppSettings, getAppDevSettings
    , appMain
    , develMain
    , makeFoundation
    , makeMiddleware
    -- * for DevelMain
    , foundationStoreNum
    , getApplicationRepl
    , shutdownApp
    -- * for GHCI
    , handler, handler'
    , db, db'
    , addPWEntry
    ) where

import Control.Monad.Logger                 (liftLoc, LoggingT(..), MonadLoggerIO(..))
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 qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID

import System.Directory

import Jobs

import qualified Data.Text.Encoding as Text

import Yesod.Auth.Util.PasswordStore

import qualified Data.ByteString.Lazy as LBS

import Network.HaskellNet.SSL hiding (Settings)
import Network.HaskellNet.SMTP.SSL as SMTP hiding (Settings)

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 (mkAvsQuery)

-- Import all relevant handler modules here.
-- (HPack takes care to add new modules to our cabal file nowadays.)
import Handler.News
import Handler.Info
import Handler.Help
import Handler.Profile
import Handler.Users
import Handler.Users.Add
import Handler.Admin
import Handler.Term
import Handler.School
import Handler.Course
import Handler.Sheet
import Handler.Submission
import Handler.Tutorial
import Handler.Material
import Handler.CryptoIDDispatch
import Handler.SystemMessage
import Handler.Health
import Handler.Health.Interface
import Handler.Exam
import Handler.ExamOffice
import Handler.Metrics
import Handler.ExternalExam
import Handler.Participants
import Handler.StorageKey
import Handler.Error
import Handler.Upload
import Handler.Qualification
import Handler.LMS
import Handler.SAP
import Handler.CommCenter
import Handler.MailCenter
import Handler.PrintCenter
import Handler.ApiDocs
import Handler.Swagger
import Handler.Firm

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
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
-- comments there for more details.
mkYesodDispatch "UniWorX" resourcesUniWorX

-- | This function allocates resources (such as a database connection pool),
-- performs initialization and returns a foundation datatype value. This is also
-- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
makeFoundation :: (MonadResource m, MonadUnliftIO m, MonadCatch m) => AppSettings -> m UniWorX
makeFoundation appSettings''@AppSettings{..} = do
    registerGHCMetrics
    registerHealthCheckInterval appHealthCheckInterval

    -- Some basic initializations: HTTP connection manager, logger, and static
    -- subsite.
    appHttpManager <- newManager
    appLogSettings <- liftIO $ newTVarIO appInitialLogSettings

    let
      mkLogger LogSettings{..} = do
        tgetter <- newTimeCache "%Y-%m-%d %T %z"
        loggerSet <- case logDestination of
          LogDestStderr -> newStderrLoggerSet defaultBufSize
          LogDestStdout -> newStdoutLoggerSet defaultBufSize
          LogDestFile{..} -> newFileLoggerSet defaultBufSize logDestFile
        return $ Yesod.Logger loggerSet tgetter
      mkLogger' = liftIO $ do
        initialSettings <- readTVarIO appLogSettings
        tVar <- newTVarIO =<< mkLogger initialSettings
        let updateLogger prevSettings = do
              newSettings <- atomically $ do
                newSettings <- readTVar appLogSettings
                guard $ newSettings /= prevSettings
                return newSettings
              oldLogger <- atomically . swapTVar tVar =<< mkLogger newSettings
              rmLoggerSet $ loggerSet oldLogger
              updateLogger newSettings
        (tVar, ) <$> forkIO (updateLogger initialSettings)
    appLogger <- over _2 fst <$> allocate mkLogger' (\(tVar, tId) -> killThread tId >> (readTVarIO tVar >>= rmLoggerSet . loggerSet))

    let appStatic = embeddedStatic

    appInstanceID <- liftIO $ maybe UUID.nextRandom (either readInstanceIDFile return) appInitialInstanceID

    appJobState <- liftIO newEmptyTMVarIO
    appHealthReport <- liftIO $ newTVarIO Set.empty

    appFileSourceARC <- for appFileSourceARCConf $ \ARCConf{..} -> do
      ah <- initARCHandle arccMaximumGhost arccMaximumWeight
      void . Prometheus.register $ arcMetrics ARCFileSource ah
      return ah
    appFileSourcePrewarm <- for appFileSourcePrewarmConf $ \PrewarmCacheConf{..} -> do
      lh <- initLRUHandle precMaximumWeight
      void . Prometheus.register $ lruMetrics LRUFileSourcePrewarm lh
      return lh
    appFileInjectInhibit <- liftIO $ newTVarIO IntervalMap.empty
    for_ (guardOnM (isn't _JobsOffload appJobMode) appInjectFiles) $ \_ ->
      void . Prometheus.register $ injectInhibitMetrics appFileInjectInhibit

    appStartTime <- liftIO getCurrentTime
    -- We need a log function to create a connection pool. We need a connection
    -- pool to create our foundation. And we need our foundation to get a
    -- logging function. To get out of this loop, we initially create a
    -- temporary foundation without a real connection pool, get a log function
    -- from there, and then create the real foundation.
    let
      mkFoundation :: _ -> (forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend) -> _
      mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..}
      tempFoundation = mkFoundation
        (error "appSettings' forced in tempFoundation")
        (error "connPool forced in tempFoundation")
        (error "smtpPool forced in tempFoundation")
        (error "ldapPool forced in tempFoundation")
        (error "cryptoIDKey forced in tempFoundation")
        (error "sessionStore forced in tempFoundation")
        (error "secretBoxKey forced in tempFoundation")
        (error "widgetMemcached forced in tempFoundation")
        (error "JSONWebKeySet forced in tempFoundation")
        (error "ClusterID forced in tempFoundation")
        (error "memcached forced in tempFoundation")
        (error "memcachedLocal forced in tempFoundation")
        (error "MinioConn forced in tempFoundation")
        (error "VerpSecret forced in tempFoundation")
        (error "AuthKey forced in tempFoundation")
        (error "PersonalisedSheetFilesSeedKey forced in tempFoundation")
        (error "VolatileClusterSettingsCache forced in tempFoundation")
        (error "AvsQuery forced in tempFoundation")

    runAppLoggingT tempFoundation $ do
      $logInfoS "InstanceID" $ UUID.toText appInstanceID
      $logInfoS "Configuration" $ tshowCrop appSettings''
      $logDebugS "RTSFlags" . tshow =<< liftIO getRTSFlags

      smtpPool <- for appSmtpConf $ \c -> do
        $logDebugS "setup" "SMTP-Pool"
        createSmtpPool c

      appWidgetMemcached <- for appWidgetMemcachedConf $ \WidgetMemcachedConf{ widgetMemcachedConf } -> do
        $logDebugS "setup" "Widget-Memcached"
        createMemcached widgetMemcachedConf

      -- Create the database connection pool
      $logDebugS "setup" "PostgreSQL-Pool"
      logFunc <- askLoggerIO
      sqlPool' <-
        let create = do
              $logDebugS "SqlPool" "Opening connection..."
              conn <- liftIO . PG.connectPostgreSQL $ pgConnStr appDatabaseConf
              backend <- liftIO $ openSimpleConn logFunc conn
              observeDatabaseConnectionOpened
              $logDebugS "SqlPool" "Opened connection"
              return backend
            destroy conn = do
              $logDebugS "SqlPool" "Closing connection..."
              liftIO $ connClose conn
              observeDatabaseConnectionClosed
              $logDebugS "SqlPool" "Closed connection"
         in Custom.createPool' (liftIO . flip runLoggingT logFunc) create destroy ((flip runLoggingT logFunc .) . onUseDBConn) onReleaseDBConn (Just . fromIntegral $ pgPoolIdleTimeout appDatabaseConf) (Just $ pgPoolSize appDatabaseConf)
      let sqlPool :: forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend
          sqlPool = Custom.hoistPool (liftIO . flip runLoggingT logFunc) sqlPool'
      void . Prometheus.register . poolMetrics PoolDatabaseConnections $ sqlPool @IO

      ldapPool <- traverse mkFailoverLabeled <=< forOf (traverse . traverse) appLdapConf $ \conf@LdapConf{..} -> do
        let ldapLabel = case ldapHost of
              Ldap.Plain str -> pack str <> ":" <> tshow ldapPort
              Ldap.Tls str _ -> pack str <> ":" <> tshow ldapPort
        $logDebugS "setup" $ "LDAP-Pool " <> ldapLabel
        (ldapLabel,) . (conf,) <$> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
      forM_ ldapPool $ registerFailoverMetrics "ldap"

      -- Perform database migration using our application's logging settings.
      flip runReaderT tempFoundation $
        if
          | appAutoDbMigrate -> do
              $logDebugS "setup" "Migration"
              migrateAll `customRunSqlPool` sqlPool
          | otherwise -> whenM (requiresMigration `customRunSqlPool` sqlPool) $ do
              $logErrorS "setup" "Migration required"
              liftIO . exitWith $ ExitFailure 130

      $logDebugS "setup" "Cluster-Config"
      appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `customRunSqlPool` sqlPool
      appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `customRunSqlPool` sqlPool
      appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `customRunSqlPool` sqlPool
      appClusterID <- clusterSetting (Proxy :: Proxy 'ClusterId) `customRunSqlPool` sqlPool
      appVerpSecret <- clusterSetting (Proxy :: Proxy 'ClusterVerpSecret) `customRunSqlPool` sqlPool
      appAuthKey <- clusterSetting (Proxy :: Proxy 'ClusterAuthKey) `customRunSqlPool` sqlPool
      appPersonalisedSheetFilesSeedKey <- clusterSetting (Proxy :: Proxy 'ClusterPersonalisedSheetFilesSeedKey) `customRunSqlPool` sqlPool

      let appVolatileClusterSettingsCacheTime' = Clock.fromNanoSecs ns
            where (MkFixed ns :: Nano) = realToFrac appVolatileClusterSettingsCacheTime
      appVolatileClusterSettingsCache <- newTVarIO $ mkVolatileClusterSettingsCache appVolatileClusterSettingsCacheTime'

      needsRechunk <- exists [FileContentChunkContentBased !=. True] `customRunSqlPool` sqlPool
      let appSettings' = appSettings''
            & _appRechunkFiles %~ guardOnM needsRechunk

      appMemcached <- for appMemcachedConf $ \memcachedConf -> do
        $logDebugS "setup" "Memcached"
        memcachedKey <- clusterSetting (Proxy :: Proxy 'ClusterMemcachedKey) `customRunSqlPool` sqlPool
        memcachedConn <- createMemcached memcachedConf
        when appClearCache $ do
          $logWarnS "setup" "Clearing memcached"
          liftIO $ Memcached.flushAll memcachedConn
        return AppMemcached{..}
      appMemcachedLocal <- for appMemcachedLocalConf $ \ARCConf{..} -> do
        memcachedLocalARC <- initARCHandle arccMaximumGhost arccMaximumWeight
        void . Prometheus.register $ arcMetrics ARCMemcachedLocal memcachedLocalARC
        memcachedLocalInvalidationQueue <- newTVarIO mempty
        memcachedLocalHandleInvalidations <- allocateLinkedAsync . managePostgresqlChannel appDatabaseConf ChannelMemcachedLocalInvalidation $ manageMemcachedLocalInvalidations memcachedLocalARC memcachedLocalInvalidationQueue
        return AppMemcachedLocal{..}

      appSessionStore <- mkSessionStore appSettings'' sqlPool `customRunSqlPool` sqlPool

      appUploadCache <- for appUploadCacheConf $ \minioConf -> liftIO $ do
        conn <- Minio.connect minioConf
        let isBucketExists Minio.BucketAlreadyOwnedByYou = True
            isBucketExists _ = False
        throwLeft <=< Minio.runMinioWith conn $ do
          handleIf isBucketExists (const $ return ()) $ Minio.makeBucket appUploadCacheBucket Nothing
          handleIf isBucketExists (const $ return ()) $ Minio.makeBucket appUploadTmpBucket Nothing
        return conn

      appAvsQuery <- case appAvsConf of
        Nothing -> do
          $logErrorS "avsPrepare" "appAvsConfig is empty, i.e. invalid AVS configuration settings."
          return Nothing
          -- error "AvsConfig is empty, i.e. invalid AVS configuration settings."

        Just avsConf -> do
          manager <- newManagerSettings $ mkManagerSettings (def { settingDisableCertificateValidation = True }) Nothing
          let avsServer = BaseUrl
                            { baseUrlScheme = Https
                            , baseUrlHost = avsHost avsConf
                            , baseUrlPort = avsPort avsConf
                            , baseUrlPath = ""
                            }
              avsEnv  = mkClientEnv manager avsServer
              avsAuth = BasicAuthData
                          { basicAuthUsername = avsUser avsConf
                          , basicAuthPassword = avsPass avsConf
                          }
          return . Just $ mkAvsQuery avsServer avsAuth avsEnv

      when (null appLegalExternal) $ $logErrorS "Legal" "Configuration of external legal links is missing."

      $logDebugS "Runtime configuration" $ tshowCrop appSettings'

      let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery

      -- Return the foundation
      $logInfoS "setup" "*** DONE ***"
      return foundation

data SessionStoreException
  = SessionStoreNotAvailable
  deriving (Eq, Ord, Read, Show, Generic)
instance Exception SessionStoreException

mkSessionStore :: forall m.
                  ( MonadIO m
                  , MonadLogger m
                  , MonadThrow m
                  , MonadResource m
                  )
               => AppSettings
               -> (forall m'. MonadIO m' => Custom.Pool' m' DBConnLabel DBConnUseState SqlBackend)
               -> ReaderT SqlBackend m SomeSessionStorage
mkSessionStore AppSettings{..} mcdSqlConnPool
  | Just mcdConf@MemcachedConf{..} <- appSessionMemcachedConf = do
      mcdSqlMemcachedKey <- clusterSetting (Proxy :: Proxy 'ClusterServerSessionKey)
      $logDebugS "setup" "Session-Memcached"
      mcdSqlMemcached <- createMemcached mcdConf
      let mcdSqlMemcachedExpiration = memcachedExpiry
      return $ _SessionStorageMemcachedSql # MemcachedSqlStorage{..}
  | appServerSessionAcidFallback = liftIO $
      review _SessionStorageAcid . Acid.AcidStorage <$> Acid.openMemoryState Acid.emptyState
  | otherwise = throwM SessionStoreNotAvailable


clusterSetting :: forall key m p.
                  ( MonadIO m
                  , ClusterSetting key
                  , MonadLogger m
                  )
               => p (key :: ClusterSettingsKey)
               -> ReaderT SqlBackend m (ClusterSettingValue key)
clusterSetting proxy@(knownClusterSetting -> key) = do
  current' <- get (ClusterConfigKey key)
  case Aeson.fromJSON . clusterConfigValue <$> current' of
    Just (Aeson.Success c) -> return c
    Just (Aeson.Error str) -> do
      $logErrorS "clusterSetting" $ "Could not parse JSON-Value for " <> toPathPiece key <> ": " <> pack str
      liftIO exitFailure
    Nothing -> do
      new <- initClusterSetting proxy
      void . insert $ ClusterConfig key (Aeson.toJSON new)
      return new

readInstanceIDFile :: MonadIO m => FilePath -> m UUID
readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFile >>= parseBS
  where
    parseBS :: LBS.ByteString -> IO UUID
    parseBS = maybe (throwString "appInstanceIDFile does not contain an UUID encoded in network byte order") return . UUID.fromByteString
    generateInstead :: IOException -> IO UUID
    generateInstead e
      | isDoesNotExistError e = do
          createDirectoryIfMissing True $ takeDirectory idFile
          instanceId <- UUID.nextRandom
          LBS.writeFile idFile $ UUID.toByteString instanceId
          return instanceId
      | otherwise = throwIO e

createSmtpPool :: MonadLoggerIO m => SmtpConf -> m SMTPPool
createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
  logFunc <- askLoggerIO
  let
    withLogging :: LoggingT IO a -> IO a
    withLogging = flip runLoggingT logFunc

    mkConnection = withLogging $ do
      $logInfoS "SMTP" "Opening new connection"
      liftIO mkConnection'
    mkConnection'
      | SmtpSslNone <- smtpSsl = connectSMTPPort smtpHost smtpPort
      | SmtpSslSmtps <- smtpSsl = connectSMTPSSLWithSettings smtpHost $ defaultSettingsWithPort smtpPort
      | SmtpSslStarttls <- smtpSsl = connectSMTPSTARTTLSWithSettings smtpHost $ defaultSettingsWithPort smtpPort
    reapConnection conn = withLogging $ do
      $logDebugS "SMTP" "Closing connection"
      liftIO $ closeSMTP conn
    applyAuth :: SmtpAuthConf -> SMTPConnection -> IO SMTPConnection
    applyAuth SmtpAuthConf{..} conn = withLogging $ do
      $logDebugS "SMTP" "Doing authentication"
      authSuccess <- liftIO $ SMTP.authenticate smtpAuthType smtpAuthUsername smtpAuthPassword conn
      unless authSuccess $
        fail "SMTP authentication failed"
      return conn
  liftIO $ createPool (mkConnection >>= maybe return applyAuth smtpAuth) reapConnection poolStripes poolTimeout poolLimit

createMemcached :: (MonadLogger m, MonadResource m) => MemcachedConf -> m Memcached.Connection
createMemcached MemcachedConf{memcachedConnectInfo} = snd <$> allocate (Memcached.connect memcachedConnectInfo) Memcached.close

-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares.
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
    & setBeforeMainLoop (runAppLoggingT foundation $ do
                            let notifyReady = do
                                  $logInfoS "setup" "Ready"
                                  void . liftIO $ do
                                    registerReadyMetric
                                    Systemd.notifyReady
                            if
                              | foundation ^. _appHealthCheckDelayNotify
                                -> void . forkIO $ do
                                  let activeChecks = Set.fromList universeF
                                                   & Set.filter (is _Just . (foundation ^. _appHealthCheckInterval))
                                  atomically $ do
                                    results <- readTVar $ foundation ^. _appHealthReport
                                    guard $ activeChecks `Set.isSubsetOf` Set.map (classifyHealthReport . snd) results
                                    guard . (/= Min HealthFailure) $ foldMap (Min . healthReportStatus . snd) results
                                  notifyReady
                              | otherwise
                                -> notifyReady
                        )
    & setHost (foundation ^. _appHost)
    & setPort (foundation ^. _appPort)
    & setOnException (\_req e ->
        when (shouldDisplayException e) $ do
          logger <- readTVarIO . snd $ appLogger foundation
          messageLoggerSource
            foundation
            logger
            $(qLocation >>= liftLoc)
            "yesod"
            LevelError
            (toLogStr $ "Exception from Warp: " ++ show e)
                     )
  where
    shouldDisplayException e = and
      [ defaultShouldDisplayException e
      , case fromException e of
          Just (SessionDoesNotExist{} :: StorageException (MemcachedSqlStorage SessionMap)) -> False
          _other -> True
      , case fromException e of
          Just (SessionDoesNotExist{} :: StorageException (AcidStorage SessionMap)) -> False
          _other -> True
      ]


getAppDevSettings, getAppSettings :: MonadIO m => m AppSettings
getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
getAppSettings = liftIO $ loadYamlSettingsArgs [configSettingsYmlValue] useEnv

-- | main function for use by yesod devel
develMain :: IO ()
develMain = runResourceT $ do
  settings <- getAppDevSettings
  foundation <- makeFoundation settings
  wsettings <- liftIO . getDevSettings $ warpSettings foundation
  app <- makeApplication foundation

  let
    awaitTermination :: IO ()
    awaitTermination
      = flip runContT return . forever $ do
          lift $ threadDelay 100e3
          whenM (lift $ doesFileExist "yesod-devel/devel-terminate") $
            callCC ($ ())

  void . liftIO $ installHandler sigINT (Signals.Catch $ return ()) Nothing
  runAppLoggingT foundation $ handleJobs foundation
  void . liftIO $ awaitTermination `race` runSettings wsettings app

-- | The @main@ function for an executable running this site.
appMain :: forall m. (MonadUnliftIO m, MonadMask m) => m ()
appMain = runResourceT $ do
    settings <- getAppSettings

    -- Generate the foundation from the settings
    foundation <- makeFoundation settings

    runAppLoggingT foundation $ do
      $logInfoS "setup" "Job-Handling"
      handleJobs foundation

      -- Generate a WAI Application from the foundation
      app <- makeApplication foundation

      -- Run the application with Warp
      activatedSockets <- liftIO Systemd.getActivatedSocketsWithNames
      sockets <- case activatedSockets of
        Just socks
          | not $ null socks -> do
            $logInfoS "bind" [st|Ignoring configuration and listening on #{intercalate ", " (fmap (tshow . snd) socks)}|]
            return $ fst <$> socks
        _other -> do
          let
            host = foundation ^. _appHost
            port = foundation ^. _appPort
          $logInfoS "bind" [st|Listening on #{tshow host} port #{tshow port} as per configuration|]
          liftIO $ pure <$> bindPortTCP port host

      $logDebugS "bind" . tshow =<< mapM (liftIO . try . socketPort :: Socket -> _ (Either SomeException PortNumber)) sockets

      mainThreadId <- myThreadId
      liftIO . void . flip (installHandler sigTERM) Nothing . Signals.CatchInfo $ \SignalInfo{..} -> runAppLoggingT foundation $ do
        $logInfoS "shutdown" [st|Received signal #{tshow siginfoSignal}|]
        didStore <- runMaybeT . forM_ sockets $ MaybeT . liftIO . Systemd.storeFd
        case didStore of
          Just () -> $logInfoS "shutdown" "Stored all bound sockets for restart"
          Nothing -> forM_ sockets $ liftIO . Socket.close
        liftIO $ throwTo mainThreadId ExitSuccess

      watchdogMicroSec <- liftIO $ (>>= readMay) <$> lookupEnv "WATCHDOG_USEC"
      watchdogProcess <- liftIO $ (>>= fmap fromInteger . readMay) <$> lookupEnv "WATCHDOG_PID"
      myProcessID <- liftIO getProcessID
      case watchdogMicroSec of
        Just wInterval
          | maybe True (== myProcessID) watchdogProcess
            -> let notifyWatchdog :: forall a m'. ( MonadLogger m', MonadIO m') => m' a
                   notifyWatchdog = forever' Nothing $ \pResults -> do
                     let delay = floor $ wInterval % 4
                     d <- liftIO $ newDelay delay

                     $logDebugS "Notify" $ "Waiting up to " <> tshow delay <> "µs..."
                     mResults <- atomically $ asum
                       [ pResults <$ waitDelay d
                       , do
                           results <- readTVar $ foundation ^. _appHealthReport
                           guardOn (pResults /= Just results) $ Just results
                       ]

                     $logDebugS "Notify" "Checking for status/watchdog..."
                     mResults <$ do
                       void . runMaybeT $ do
                         results <- hoistMaybe mResults

                         let latestResults = Map.fromListWith (\_ x -> x) $ Set.toAscList results
                         Min status <- hoistMaybe $ ofoldMap1 (Min . healthReportStatus) <$> fromNullable latestResults
                         $logInfoS "NotifyStatus" $ toPathPiece status
                         liftIO . void . Systemd.notifyStatus . unpack $ toPathPiece status

                       now <- liftIO getCurrentTime
                       let missing = flip ifoldMap (foundation ^. _appHealthCheckInterval) $ \hc mInterval -> fromMaybe mempty $ do
                             interval <- mInterval
                             let lastSuccess = maybeMonoid mResults
                                   & Set.filter (\(_, rep) -> classifyHealthReport rep == hc)
                                   & Set.filter (\(_, rep) -> healthReportStatus rep > HealthFailure)
                                   & Set.mapMonotonic (view _1)
                                   & Set.lookupMax

                                 successIsCurrent = lastSuccess > Just (negate interval `addUTCTime` now)

                             return . guardMonoid (not successIsCurrent) $ Set.singleton hc

                       if | Set.null missing -> do
                              $logInfoS "NotifyWatchdog" "Notify"
                              liftIO $ void Systemd.notifyWatchdog
                          | otherwise ->
                              $logWarnS "NotifyWatchdog" $ "No notify; missing \n\t   " <> tshow (toList missing) <> "\n\tin " <> tshow (toList <$> mResults)
                in do
                     $logDebugS "Notify" "Spawning notify thread..."
                     void $ allocateLinkedAsync notifyWatchdog
        _other -> $logWarnS "Notify" "Not sending notifications of status/poking watchdog"

      let runWarp socket = runSettingsSocket (warpSettings foundation) socket app
      case sockets of
        []  -> $logErrorS "bind" "No sockets to listen on"
        [s] -> liftIO $ runWarp s
        ss  -> liftIO $ void . waitAnyCancel =<< mapM (async . runWarp) ss


--------------------------------------------------------------
-- Functions for DevelMain.hs (a way to run the app from GHCi)
--------------------------------------------------------------
foundationStoreNum :: Word32
foundationStoreNum = 2

getApplicationRepl :: (MonadResource m, MonadUnliftIO m, MonadMask m) => m (Int, UniWorX, Application)
getApplicationRepl = do
    settings <- getAppDevSettings
    foundation <- makeFoundation settings
    runAppLoggingT foundation $ handleJobs foundation
    wsettings <- liftIO . getDevSettings $ warpSettings foundation
    app1 <- makeApplication foundation

    let foundationStore = Store foundationStoreNum
    liftIO $ deleteStore foundationStore
    liftIO $ writeStore foundationStore foundation

    return (getPort wsettings, foundation, app1)

shutdownApp :: (MonadIO m, MonadUnliftIO m) => UniWorX -> m ()
shutdownApp app = do
  stopJobCtl app
  liftIO $ do
    Custom.purgePool $ appConnPool app
    for_ (appSmtpPool app) destroyAllResources
    for_ (appLdapPool app) . mapFailover $ views _2 destroyAllResources
    for_ (appWidgetMemcached app) Memcached.close
    for_ (appMemcached app) $ views _memcachedConn Memcached.close
  release . fst $ appLogger app

  liftIO $ threadDelay 1e6


---------------------------------------------
-- Functions for use in development with GHCi
---------------------------------------------

-- | Run a handler
handler, handler' :: Handler a -> IO a
handler  h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h
handler' h = runResourceT $ getAppSettings    >>= makeFoundation >>= liftIO . flip unsafeHandler h

-- | Run DB queries
db, db' :: DB a -> IO a
db = handler . runDB
db' = handler' . runDB

addPWEntry :: User
           -> Text {-^ Password -}
           -> IO ()
addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db' $ do
  PWHashConf{..} <- getsYesod $ view _appAuthPWHash
  (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
  void $ insert User{..}