766 lines
34 KiB
Haskell
766 lines
34 KiB
Haskell
-- 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
|
|
|
|
-- old job system
|
|
import Jobs
|
|
|
|
-- new job system
|
|
import JobSystem () -- TODO work in progress
|
|
|
|
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
|
|
|
|
-- 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.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.PrintCenter
|
|
import Handler.ApiDocs
|
|
import Handler.Swagger
|
|
|
|
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{..}
|