diff --git a/config/settings.yml b/config/settings.yml index 287baf0b3..974b2e7e2 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -30,6 +30,9 @@ session-timeout: 7200 jwt-expiration: 604800 jwt-encoding: HS256 maximum-content-length: 52428800 +health-check-interval: "_env:HEALTHCHECK_INTERVAL:600" # or WATCHDOG_USEC/2, whichever is smaller +health-check-http: "_env:HEALTHCHECK_HTTP:true" +health-check-delay-notify: "_env:HEALTHCHECK_DELAY_NOTIFY:true" log-settings: detailed: "_env:DETAILED_LOGGING:false" diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 75c9609d5..e3d6da26f 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -702,6 +702,8 @@ MenuInformation: Informationen MenuImpressum: Impressum MenuDataProt: Datenschutz MenuVersion: Versionsgeschichte +MenuInstance: Instanz-Identifikation +MenuHealth: Instanz-Zustand MenuHelp: Hilfe MenuProfile: Anpassen MenuLogin: Login @@ -877,4 +879,16 @@ TutorialCreated tutn@TutorialName: Tutorium #{tutn} erfolgreich angelegt TutorialEditHeading tutn@TutorialName: #{tutn} bearbeiten -MassInputTip: Es können mehrere Werte angegeben werden. Werte müssen mit + zur Liste hinzugefügt werden und können mit - wieder entfernt werden. Die Liste wird zunächst nur lokal in Ihrem Browser gespeichert und muss noch zusammen mit dem Rest des Formulars Gesendet werden. \ No newline at end of file +MassInputTip: Es können mehrere Werte angegeben werden. Werte müssen mit + zur Liste hinzugefügt werden und können mit - wieder entfernt werden. Die Liste wird zunächst nur lokal in Ihrem Browser gespeichert und muss noch zusammen mit dem Rest des Formulars Gesendet werden. + +HealthReport: Instanz-Zustand +InstanceIdentification: Instanz-Identifikation + +InstanceId: Instanz-Nummer +ClusterId: Cluster-Nummer + +HealthMatchingClusterConfig: Cluster-geteilte Konfiguration ist aktuell +HealthHTTPReachable: Cluster kann an der erwarteten URL über HTTP erreicht werden +HealthLDAPAdmins: Anteil der Administratoren, die im LDAP-Verzeichnis gefunden werden können +HealthSMTPConnect: SMTP-Server kann erreicht werden +HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus \ No newline at end of file diff --git a/package.yaml b/package.yaml index d1c262645..3994357bf 100644 --- a/package.yaml +++ b/package.yaml @@ -125,6 +125,7 @@ dependencies: - lifted-async - streaming-commons - hourglass + - unix other-extensions: - GeneralizedNewtypeDeriving diff --git a/routes b/routes index d77ccbf04..17ed427ad 100644 --- a/routes +++ b/routes @@ -50,6 +50,8 @@ /admin/test AdminTestR GET POST /admin/errMsg AdminErrMsgR GET POST +/health HealthR GET !free +/instance InstanceR GET !free /info InfoR GET !free /info/lecturer InfoLecturerR GET !lecturer /info/data DataProtR GET !free diff --git a/src/Application.hs b/src/Application.hs index 77a19df68..503386d64 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -64,7 +64,7 @@ import qualified Yesod.Core.Types as Yesod (Logger(..)) import qualified Data.HashMap.Strict as HashMap -import Control.Lens +import Utils.Lens import Data.Proxy @@ -76,6 +76,10 @@ import qualified Database.Memcached.Binary.IO as Memcached import qualified System.Systemd.Daemon as Systemd import Control.Concurrent.Async.Lifted.Safe (async, waitAnyCancel) +import System.Environment (lookupEnv) +import System.Posix.Process (getProcessID) + +import Control.Monad.Trans.State (execStateT) -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) @@ -95,6 +99,7 @@ import Handler.Tutorial import Handler.Corrections import Handler.CryptoIDDispatch import Handler.SystemMessage +import Handler.Health -- This line actually creates our YesodDispatch instance. It is the second half @@ -141,13 +146,14 @@ makeFoundation appSettings'@AppSettings{..} = do appJobCtl <- liftIO $ newTVarIO Map.empty appCronThread <- liftIO newEmptyTMVarIO + appHealthReport <- liftIO $ newTVarIO Nothing -- 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 appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet = UniWorX {..} + let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID = UniWorX {..} -- The UniWorX {..} syntax is an example of record wild cards. For more -- information, see: -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html @@ -160,6 +166,7 @@ makeFoundation appSettings'@AppSettings{..} = do (error "secretBoxKey forced in tempFoundation") (error "widgetMemcached forced in tempFoundation") (error "JSONWebKeySet forced in tempFoundation") + (error "ClusterID forced in tempFoundation") runAppLoggingT tempFoundation $ do $logInfoS "InstanceID" $ UUID.toText appInstanceID @@ -191,8 +198,9 @@ makeFoundation appSettings'@AppSettings{..} = do appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool + appClusterID <- clusterSetting (Proxy :: Proxy 'ClusterId) `runSqlPool` sqlPool - let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet + let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID $logDebugS "setup" "Job-Handling" handleJobs foundation @@ -311,8 +319,16 @@ makeLogWare app = do warpSettings :: UniWorX -> Settings warpSettings foundation = defaultSettings & setBeforeMainLoop (runAppLoggingT foundation $ do - $logInfoS "setup" "Ready" - void $ liftIO Systemd.notifyReady + let notifyReady = do + $logInfoS "setup" "Ready" + void $ liftIO Systemd.notifyReady + if + | foundation ^. _appHealthCheckDelayNotify + -> void . fork $ do + atomically $ readTVar (foundation ^. _appHealthReport) >>= guard . maybe False ((== HealthSuccess) . classifyHealthReport . snd) + notifyReady + | otherwise + -> notifyReady ) & setHost (foundation ^. _appHost) & setPort (foundation ^. _appPort) @@ -336,8 +352,20 @@ getApplicationDev = do app <- makeApplication foundation return (wsettings, app) -getAppDevSettings :: MonadIO m => m AppSettings -getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv +getAppDevSettings, getAppSettings :: MonadIO m => m AppSettings +getAppDevSettings = liftIO $ adjustSettings =<< loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv +getAppSettings = liftIO $ adjustSettings =<< loadYamlSettingsArgs [configSettingsYmlValue] useEnv + +adjustSettings :: MonadIO m => AppSettings -> m AppSettings +adjustSettings = execStateT $ do + 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 + -> _appHealthCheckInterval %= min (fromRational $ (toRational wInterval / 1e6) / 2) + _other -> return () -- | main function for use by yesod devel develMain :: IO () @@ -347,14 +375,7 @@ develMain = runResourceT $ -- | The @main@ function for an executable running this site. appMain :: MonadResourceBase m => m () appMain = runResourceT $ do - -- Get the settings from all relevant sources - settings <- liftIO $ - loadYamlSettingsArgs - -- fall back to compile-time values, set to [] to require values at runtime - [configSettingsYmlValue] - - -- allow environment variables to override - useEnv + settings <- getAppSettings -- Generate the foundation from the settings foundation <- makeFoundation settings diff --git a/src/Foundation.hs b/src/Foundation.hs index 654df9ded..05b086ed0 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -118,12 +118,14 @@ data UniWorX = UniWorX , appLogger :: (ReleaseKey, TVar Logger) , appLogSettings :: TVar LogSettings , appCryptoIDKey :: CryptoIDKey + , appClusterID :: ClusterId , appInstanceID :: InstanceId , appJobCtl :: TVar (Map ThreadId (TMChan JobCtl)) , appCronThread :: TMVar (ReleaseKey, ThreadId) , appSessionKey :: ClientSession.Key , appSecretBoxKey :: SecretBox.Key , appJSONWebKeySet :: Jose.JwkSet + , appHealthReport :: TVar (Maybe (UTCTime, HealthReport)) } makeLenses_ ''UniWorX @@ -1160,6 +1162,8 @@ siteLayout' headingOverride widget = do isModal <- hasCustomHeader HeaderIsModal + primaryLanguage <- unsafeHead . Text.splitOn "-" <$> selectLanguage appLanguages + mcurrentRoute <- getCurrentRoute -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. @@ -1346,6 +1350,10 @@ instance YesodBreadcrumbs UniWorX where breadcrumb HelpR = return ("Hilfe" , Just HomeR) + breadcrumb HealthR = return ("Status" , Nothing) + breadcrumb InstanceR = return ("Identifikation", Nothing) + + breadcrumb ProfileR = return ("User" , Just HomeR) breadcrumb ProfileDataR = return ("Profile" , Just ProfileR) breadcrumb AuthPredsR = return ("Authentifizierung", Just ProfileR) @@ -1649,6 +1657,26 @@ pageActions (VersionR) = [ , menuItemAccessCallback' = return True } ] +pageActions HealthR = [ + MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuInstance + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute InstanceR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions InstanceR = [ + MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuHealth + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute HealthR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] pageActions (HelpR) = [ -- MenuItem -- { menuItemType = PageActionPrime diff --git a/src/Handler/Common.hs b/src/Handler/Common.hs index 54eddd1c3..f11a76cfb 100644 --- a/src/Handler/Common.hs +++ b/src/Handler/Common.hs @@ -8,10 +8,19 @@ import Import hiding (embedFile) -- runtime dependency, and for efficiency. getFaviconR :: Handler TypedContent -getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month - return $ TypedContent "image/x-icon" - $ toContent $(embedFile "static/favicon.ico") +getFaviconR = do + let content = $(embedFile "static/favicon.ico") + + setEtagHashable content + + return $ TypedContent "image/x-icon" + $ toContent content getRobotsR :: Handler TypedContent -getRobotsR = return $ TypedContent typePlain - $ toContent $(embedFile "static/robots.txt") +getRobotsR = do + let content = $(embedFile "static/robots.txt") + + setEtagHashable content + + return $ TypedContent typePlain + $ toContent content diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs new file mode 100644 index 000000000..872ab3410 --- /dev/null +++ b/src/Handler/Health.hs @@ -0,0 +1,81 @@ +module Handler.Health where + +import Import + +import qualified Data.Aeson.Encode.Pretty as Aeson +import qualified Data.Text.Lazy.Builder as Builder + +import Utils.Lens + +import qualified Data.UUID as UUID + + +getHealthR :: Handler TypedContent +getHealthR = do + healthReport' <- liftIO . readTVarIO =<< getsYesod appHealthReport + let + handleMissing = do + interval <- getsYesod $ round . (* 1e6) . toRational . view _appHealthCheckInterval + reportStore <- getsYesod appHealthReport + waitResult <- threadDelay interval `race` atomically (readTVar reportStore >>= guard . is _Just) + case waitResult of + Left () -> fail "System is not generating HealthReports" + Right _ -> redirect HealthR + (lastUpdated, healthReport) <- maybe handleMissing return healthReport' + interval <- getsYesod $ view _appHealthCheckInterval + instanceId <- getsYesod appInstanceID + + setWeakEtagHashable (instanceId, lastUpdated) + expiresAt $ interval `addUTCTime` lastUpdated + setLastModified lastUpdated + + let status + | HealthSuccess <- classifyHealthReport healthReport + = ok200 + | otherwise + = internalServerError500 + sendResponseStatus status <=< selectRep $ do + provideRep . siteLayoutMsg MsgHealthReport $ do + setTitleI MsgHealthReport + let HealthReport{..} = healthReport + [whamlet| + $newline never +
+
_{MsgHealthMatchingClusterConfig} +
#{boolSymbol healthMatchingClusterConfig} + $maybe httpReachable <- healthHTTPReachable +
_{MsgHealthHTTPReachable} +
#{boolSymbol httpReachable} + $maybe ldapAdmins <- healthLDAPAdmins +
_{MsgHealthLDAPAdmins} +
#{textPercent ldapAdmins} + $maybe smtpConnect <- healthSMTPConnect +
_{MsgHealthSMTPConnect} +
#{boolSymbol smtpConnect} + $maybe widgetMemcached <- healthWidgetMemcached +
_{MsgHealthWidgetMemcached} +
#{boolSymbol widgetMemcached} + |] + provideJson healthReport + provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReport + +getInstanceR :: Handler TypedContent +getInstanceR = do + instanceInfo@(clusterId, instanceId) <- getsYesod $ (,) <$> appClusterID <*> appInstanceID + + setWeakEtagHashable (clusterId, instanceId) + + selectRep $ do + provideRep $ + siteLayoutMsg MsgInstanceIdentification $ do + setTitleI MsgInstanceIdentification + [whamlet| + $newline never +
+
_{MsgClusterId} +
#{UUID.toText clusterId} +
_{MsgInstanceId} +
#{UUID.toText instanceId} + |] + provideJson instanceInfo + provideRep . return $ tshow instanceInfo diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index bc0817d50..94504f1ea 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -37,7 +37,6 @@ import Control.Monad.Trans.Except (throwE, runExceptT) import Control.Monad.Writer.Class import Data.Scientific (Scientific) -import Data.Ratio import Text.Read (readMaybe) import Data.Either (partitionEithers) diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index d0a4e7fa4..e057be569 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -53,7 +53,7 @@ import Data.List.NonEmpty.Instances as Import () import Data.NonNull.Instances as Import () import Data.Text.Encoding.Error as Import(UnicodeException(..)) import Data.Semigroup as Import (Semigroup) -import Data.Monoid as Import (Last(..), First(..), Any(..), All(..)) +import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..)) import Data.Monoid.Instances as Import () import Data.Set.Instances as Import () import Data.HashMap.Strict.Instances as Import () @@ -95,6 +95,8 @@ import Time.Types.Instances as Import () import Data.CaseInsensitive as Import (CI, FoldCase(..), foldedCase) +import Data.Ratio as Import ((%)) + import Control.Monad.Trans.RWS (RWST) diff --git a/src/Jobs.hs b/src/Jobs.hs index 8af6f7235..9c7fd3674 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -51,6 +51,8 @@ import Data.Time.Zones import Control.Concurrent.STM (retry) +import qualified System.Systemd.Daemon as Systemd + import Jobs.Handler.SendNotification import Jobs.Handler.SendTestEmail @@ -62,6 +64,8 @@ import Jobs.Handler.SendCourseCommunication import Jobs.Handler.LecturerInvitation import Jobs.Handler.CorrectorInvitation +import Jobs.HealthReport + data JobQueueException = JInvalid QueuedJobId QueuedJob | JLocked QueuedJobId InstanceId UTCTime @@ -280,6 +284,21 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do -- logDebugS logIdent $ tshow newCTab mapReaderT (liftIO . atomically) $ lift . void . flip swapTMVar newCTab =<< asks jobCrontab + handleCmd JobCtlGenerateHealthReport = do + hrStorage <- getsYesod appHealthReport + newReport@(classifyHealthReport -> newStatus) <- lift generateHealthReport + + $logInfoS "HealthReport" $ toPathPiece newStatus + unless (newStatus == HealthSuccess) $ do + $logErrorS "HealthReport" $ tshow newReport + + liftIO $ do + now <- getCurrentTime + atomically . writeTVar hrStorage $ Just (now, newReport) + + void . Systemd.notifyStatus . unpack $ toPathPiece newStatus + when (newStatus == HealthSuccess) $ + void Systemd.notifyWatchdog jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a jLocked jId act = do diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 434185d2b..5dd98d9b8 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -44,6 +44,15 @@ determineCrontab = execWriterT $ do , cronNotAfter = Right CronNotScheduled } + tell $ HashMap.singleton + JobCtlGenerateHealthReport + Cron + { cronInitial = CronAsap + , cronRepeat = CronRepeatScheduled CronAsap + , cronRateLimit = appHealthCheckInterval + , cronNotAfter = Right CronNotScheduled + } + let sheetJobs (Entity nSheet Sheet{..}) = do tell $ HashMap.singleton diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs new file mode 100644 index 000000000..a8f6a0ff4 --- /dev/null +++ b/src/Jobs/HealthReport.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Jobs.HealthReport + ( generateHealthReport + ) where + +import Import + +import Data.List (genericLength) + +import qualified Data.Aeson as Aeson +import Data.Proxy (Proxy(..)) + +import qualified Data.ByteArray as ByteArray + +import Utils.Lens + +import Network.HTTP.Simple (httpJSON, httpLBS) +import qualified Network.HTTP.Simple as HTTP + +import qualified Database.Esqueleto as E + +import Auth.LDAP + +import qualified Data.CaseInsensitive as CI + +import qualified Network.HaskellNet.SMTP as SMTP +import Data.Pool (withResource) + + +generateHealthReport :: Handler HealthReport +generateHealthReport + = runConcurrently $ HealthReport + <$> Concurrently matchingClusterConfig + <*> Concurrently httpReachable + <*> Concurrently ldapAdmins + <*> Concurrently smtpConnect + <*> Concurrently widgetMemcached + +matchingClusterConfig :: Handler Bool +-- ^ Can the cluster configuration be read from the database and does it match our configuration? +matchingClusterConfig = runDB $ and <$> forM universeF clusterSettingMatches + where + clusterSettingMatches ClusterCryptoIDKey = do + ourSetting <- getsYesod appCryptoIDKey + dbSetting <- clusterSetting @'ClusterCryptoIDKey + return $ ((==) `on` fmap (ByteArray.convert :: CryptoIDKey -> ByteString)) (Just ourSetting) dbSetting + clusterSettingMatches ClusterClientSessionKey = do + ourSetting <- getsYesod appSessionKey + dbSetting <- clusterSetting @'ClusterClientSessionKey + return $ Just ourSetting == dbSetting + clusterSettingMatches ClusterSecretBoxKey = do + ourSetting <- getsYesod appSecretBoxKey + dbSetting <- clusterSetting @'ClusterSecretBoxKey + return $ Just ourSetting == dbSetting + clusterSettingMatches ClusterJSONWebKeySet = do + ourSetting <- getsYesod appJSONWebKeySet + dbSetting <- clusterSetting @'ClusterJSONWebKeySet + return $ Just ourSetting == dbSetting + clusterSettingMatches ClusterId = do + ourSetting <- getsYesod appClusterID + dbSetting <- clusterSetting @'ClusterId + return $ Just ourSetting == dbSetting + + + clusterSetting :: forall key. + ( ClusterSetting key + ) + => DB (Maybe (ClusterSettingValue key)) + clusterSetting = do + current' <- get . ClusterConfigKey $ knownClusterSetting (Proxy @key) + case Aeson.fromJSON . clusterConfigValue <$> current' of + Just (Aeson.Success c) -> return $ Just c + _other -> return Nothing + + +httpReachable :: Handler (Maybe Bool) +httpReachable = do + staticAppRoot <- getsYesod $ view _appRoot + doHTTP <- getsYesod $ view _appHealthCheckHTTP + for (staticAppRoot <* guard doHTTP) $ \_textAppRoot -> do + url <- getUrlRender <*> pure InstanceR + baseRequest <- HTTP.parseRequest $ unpack url + httpManager <- getsYesod appHttpManager + let httpRequest = baseRequest + & HTTP.setRequestManager httpManager + (clusterId, _ :: InstanceId) <- responseBody <$> httpJSON httpRequest + getsYesod $ (== clusterId) . appClusterID + + +ldapAdmins :: Handler (Maybe Rational) +ldapAdmins = do + ldapPool' <- getsYesod appLdapPool + ldapConf' <- getsYesod $ view _appLdapConf + ldapAdminUsers <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do + E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser + E.where_ $ user E.^. UserAuthentication E.==. E.val AuthLDAP + return $ user E.^. UserIdent + case (,) <$> ldapPool' <*> ldapConf' of + Just (ldapPool, ldapConf) + | not $ null ldapAdminUsers + -> do + let numAdmins = genericLength ldapAdminUsers + hCampusExc :: CampusUserException -> Handler (Sum Integer) + hCampusExc _ = return $ Sum 0 + Sum numResolved <- fmap fold . forM ldapAdminUsers $ + \(CI.original -> adminIdent) -> handle hCampusExc $ Sum 1 <$ campusUser ldapConf ldapPool (Creds "LDAP" adminIdent []) + return . Just $ numResolved % numAdmins + _other -> return Nothing + + +smtpConnect :: Handler (Maybe Bool) +smtpConnect = do + smtpPool <- getsYesod appSmtpPool + for smtpPool . flip withResource $ \smtpConn -> do + response@(rCode, _) <- liftIO $ SMTP.sendCommand smtpConn SMTP.NOOP + case rCode of + 250 -> return True + _ -> do + $logErrorS "Mail" $ "NOOP failed: " <> tshow response + return False + + +widgetMemcached :: Handler (Maybe Bool) +widgetMemcached = do + memcachedConn <- getsYesod appWidgetMemcached + for memcachedConn $ \_memcachedConn' -> do + let ext = "bin" + mimeType = "application/octet-stream" + content <- pack . take 256 <$> liftIO getRandoms + staticLink <- addStaticContent ext mimeType content + doHTTP <- getsYesod $ view _appHealthCheckHTTP + case staticLink of + _ | not doHTTP -> return True + Just (Left url) -> do + baseRequest <- HTTP.parseRequest $ unpack url + httpManager <- getsYesod appHttpManager + let httpRequest = baseRequest + & HTTP.setRequestManager httpManager + (== content) . responseBody <$> httpLBS httpRequest + _other -> return False + diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index fc399d6a5..80d308626 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -69,6 +69,7 @@ data JobCtl = JobCtlFlush | JobCtlPerform QueuedJobId | JobCtlDetermineCrontab | JobCtlQueue Job + | JobCtlGenerateHealthReport deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Hashable JobCtl diff --git a/src/Ldap/Client/Pool.hs b/src/Ldap/Client/Pool.hs index 875078b6f..6682d7c98 100644 --- a/src/Ldap/Client/Pool.hs +++ b/src/Ldap/Client/Pool.hs @@ -95,7 +95,7 @@ createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) lim setup <- newEmptyTMVarIO void . fork . flip runLoggingT logFunc $ do - $logDebugS "LdapExecutor" "Starting" + $logInfoS "LdapExecutor" "Starting" res <- liftIO . Ldap.with host port $ flip runLoggingT logFunc . go (Just setup) case res of Left exc -> do diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 28ecff845..50335333d 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -86,6 +86,10 @@ import qualified Data.Binary as Binary import Time.Types (WeekDay(..)) import Data.Time.LocalTime (LocalTime, TimeOfDay) + +import Data.Semigroup (Min(..)) +import Control.Monad.Trans.Writer (execWriter) +import Control.Monad.Writer.Class (MonadWriter(..)) instance PathPiece UUID where @@ -922,6 +926,55 @@ deriveJSON defaultOptions derivePersistFieldJSON ''Occurences +data HealthReport = HealthReport + { healthMatchingClusterConfig :: Bool + -- ^ Is the database-stored configuration we're running under still up to date? + , healthHTTPReachable :: Maybe Bool + -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP? + -- + -- Can be `Nothing` if we don't have a static configuration setting `appRoot` or if check is disabled in settings + , healthLDAPAdmins :: Maybe Rational + -- ^ Proportion of school admins that could be found in LDAP + -- + -- Is `Nothing` if LDAP is not configured or no users are school admins + , healthSMTPConnect :: Maybe Bool + -- ^ Can we connect to the SMTP server and say @NOOP@? + , healthWidgetMemcached :: Maybe Bool + -- ^ Can we store values in memcached and retrieve them via HTTP? + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , omitNothingFields = True + } ''HealthReport + +-- | `HealthReport` classified (`classifyHealthReport`) by badness +-- +-- > a < b = a `worseThan` b +-- +-- Currently all consumers of this type check for @(== HealthSuccess)@; this +-- needs to be adjusted on a case-by-case basis if new constructors are added +data HealthStatus = HealthFailure | HealthSuccess + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + +instance Universe HealthStatus +instance Finite HealthStatus + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''HealthStatus +nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1 + +classifyHealthReport :: HealthReport -> HealthStatus +-- ^ Classify `HealthReport` by badness +classifyHealthReport HealthReport{..} = getMin . execWriter $ do -- Construction with `Writer (Min HealthStatus) a` returns worst `HealthStatus` passed to `tell` at any point + unless healthMatchingClusterConfig . tell $ Min HealthFailure + unless (fromMaybe True healthHTTPReachable) . tell $ Min HealthFailure + unless (maybe True (> 0) healthLDAPAdmins) . tell $ Min HealthFailure + unless (fromMaybe True healthSMTPConnect) . tell $ Min HealthFailure + unless (fromMaybe True healthWidgetMemcached) . tell $ Min HealthFailure + + -- Type synonyms type Email = Text @@ -936,5 +989,6 @@ type TutorialName = CI Text type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString type InstanceId = UUID +type ClusterId = UUID type TokenId = UUID type TermCandidateIncidence = UUID diff --git a/src/Settings.hs b/src/Settings.hs index 085ec469a..d9798caea 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -48,9 +48,6 @@ import qualified Ldap.Client as Ldap import Utils hiding (MessageStatus(..)) import Control.Lens -import Data.Maybe (fromJust) -import qualified Data.Char as Char - import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..)) import qualified Network.Socket as HaskellNet (PortNumber(..), HostName) import qualified Network @@ -111,6 +108,10 @@ data AppSettings = AppSettings , appMaximumContentLength :: Maybe Word64 , appJwtExpiration :: Maybe NominalDiffTime , appJwtEncoding :: JwtEncoding + + , appHealthCheckInterval :: NominalDiffTime + , appHealthCheckHTTP :: Bool + , appHealthCheckDelayNotify :: Bool , appInitialLogSettings :: LogSettings @@ -278,7 +279,7 @@ deriveFromJSON deriveJSON defaultOptions - { constructorTagModifier = over (ix 1) Char.toLower . fromJust . stripPrefix "Level" + { constructorTagModifier = camelToPathPiece' 1 , sumEncoding = UntaggedValue } ''LogLevel @@ -378,6 +379,10 @@ instance FromJSON AppSettings where appJwtExpiration <- o .:? "jwt-expiration" appJwtEncoding <- o .: "jwt-encoding" + appHealthCheckInterval <- o .: "health-check-interval" + appHealthCheckHTTP <- o .: "health-check-http" + appHealthCheckDelayNotify <- o .: "health-check-delay-notify" + appSessionTimeout <- o .: "session-timeout" appMaximumContentLength <- o .: "maximum-content-length" diff --git a/src/Settings/Cluster.hs b/src/Settings/Cluster.hs index 872d901b7..037c9d967 100644 --- a/src/Settings/Cluster.hs +++ b/src/Settings/Cluster.hs @@ -36,12 +36,16 @@ import qualified Jose.Jwa as Jose import qualified Jose.Jwk as Jose import qualified Jose.Jwt as Jose +import Data.UUID (UUID) +import Control.Monad.Random.Class (MonadRandom(..)) + data ClusterSettingsKey = ClusterCryptoIDKey | ClusterClientSessionKey | ClusterSecretBoxKey | ClusterJSONWebKeySet + | ClusterId deriving (Eq, Ord, Enum, Bounded, Show, Read) instance Universe ClusterSettingsKey @@ -134,3 +138,9 @@ instance ClusterSetting 'ClusterJSONWebKeySet where jwkSig <- Jose.generateSymmetricKey 32 (Jose.UTCKeyId now) Jose.Sig (Just $ Jose.Signed Jose.HS256) return $ Jose.JwkSet [jwkSig] knownClusterSetting _ = ClusterJSONWebKeySet + + +instance ClusterSetting 'ClusterId where + type ClusterSettingValue 'ClusterId = UUID + initClusterSetting _ = liftIO getRandom + knownClusterSetting _ = ClusterId diff --git a/src/Utils.hs b/src/Utils.hs index 40fa580ee..0d656c1fd 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -17,6 +17,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import Utils.DB as Utils import Utils.TH as Utils @@ -72,6 +73,10 @@ import Data.Ratio ((%)) import qualified Data.Binary as Binary +import Network.Wai (requestMethod) + +import Data.Time.Clock + {-# ANN choice ("HLint: ignore Use asum" :: String) #-} @@ -152,6 +157,10 @@ isNew :: Bool -> Markup isNew True = [shamlet||] -- was exclamation isNew False = mempty +boolSymbol :: Bool -> Markup +boolSymbol True = [shamlet||] +boolSymbol False = [shamlet||] + --------------------- -- Text and String -- @@ -653,7 +662,7 @@ instance Finite CustomHeader nullaryPathPiece ''CustomHeader (intercalate "-" . drop 1 . splitCamel) lookupCustomHeader :: (MonadHandler m, PathPiece result) => CustomHeader -> m (Maybe result) -lookupCustomHeader ident = (>>= fromPathPiece . decodeUtf8) <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident) +lookupCustomHeader ident = (=<<) (fromPathPiece <=< either (const Nothing) Just . Text.decodeUtf8') <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident) hasCustomHeader :: MonadHandler m => CustomHeader -> m Bool hasCustomHeader ident = isJust <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident) @@ -752,3 +761,27 @@ cachedHere :: Q Exp cachedHere = do loc <- location [e| cachedBy (toStrict $ Binary.encode loc) |] + +hashToText :: Hashable a => a -> Text +hashToText = decodeUtf8 . Base64.encode . toStrict . Binary.encode . hash + +setEtagHashable, setWeakEtagHashable :: (MonadHandler m, Hashable a) => a -> m () +setEtagHashable = setEtag . hashToText +setWeakEtagHashable = setEtag . hashToText + +setLastModified :: (MonadHandler m, MonadLogger m) => UTCTime -> m () +setLastModified lastModified = do + rMethod <- requestMethod <$> waiRequest + + when (rMethod `elem` safeMethods) $ do + ifModifiedSince <- (=<<) (parseTimeM True defaultTimeLocale "%a, %d %b %Y %X %Z" . unpack <=< either (const Nothing) Just . Text.decodeUtf8') <$> lookupHeader "If-Modified-Since" + $logDebugS "LastModified" $ tshow (lastModified, ifModifiedSince) + when (maybe False ((lastModified <=) . addUTCTime precision) ifModifiedSince) + notModified + + addHeader "Last-Modified" $ formatRFC1123 lastModified + where + precision :: NominalDiffTime + precision = 1 + + safeMethods = [ methodGet, methodHead, methodOptions ] diff --git a/static/js/utils/form.js b/static/js/utils/form.js index 54c3a430f..4c77f8621 100644 --- a/static/js/utils/form.js +++ b/static/js/utils/form.js @@ -106,11 +106,15 @@ return init(); }; - formUtilities.push({ - name: REACTIVE_SUBMIT_BUTTON_UTIL_NAME, - selector: REACTIVE_SUBMIT_BUTTON_UTIL_SELECTOR, - setup: reactiveSubmitButtonUtil, - }); + // skipping reactiveButtonUtil (for now) + // the button did not properly re-enable after filling out a form for some safari users. + // if maybe in the future there is going to be a proper way of (asynchronously) and + // meaningfully validating forms this can be re-activated by commenting in the next few lines + // formUtilities.push({ + // name: REACTIVE_SUBMIT_BUTTON_UTIL_NAME, + // selector: REACTIVE_SUBMIT_BUTTON_UTIL_SELECTOR, + // setup: reactiveSubmitButtonUtil, + // }); /** * diff --git a/templates/course.hamlet b/templates/course.hamlet index 4fc2f9366..6f4b83866 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -1,94 +1,93 @@ $newline never -
-
-
Fakultät/Institut +
+
Fakultät/Institut +
+
+ #{schoolName} + + $maybe descr <- courseDescription course +
_{MsgCourseDescription}
- #{schoolName} + #{descr} - $maybe descr <- courseDescription course -
_{MsgCourseDescription} + $with numlecs <- length lecturers + $if numlecs /= 0 + $if numlecs > 1 +
_{MsgLecturersFor} + $else +
_{MsgLecturerFor}
- #{descr} - - $with numlecs <- length lecturers - $if numlecs /= 0 - $if numlecs > 1 -
_{MsgLecturersFor} - $else -
_{MsgLecturerFor} -
-
-