Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

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"

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
@@ -878,3 +880,15 @@ 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.
+
+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

package.yaml

@@ -125,6 +125,7 @@ dependencies:
   - lifted-async
   - streaming-commons
   - hourglass
+  - unix
 
 other-extensions:
   - GeneralizedNewtypeDeriving

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

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"
+                            let notifyReady = do
-                            void $ liftIO Systemd.notifyReady
+                                  $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, getAppSettings :: MonadIO m => m AppSettings
-getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
+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 <- getAppSettings
-    settings <- liftIO $
-      loadYamlSettingsArgs
-        -- fall back to compile-time values, set to [] to require values at runtime
-        [configSettingsYmlValue]
-
-        -- allow environment variables to override
-        useEnv
 
     -- Generate the foundation from the settings
     foundation <- makeFoundation settings

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

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
+getFaviconR = do
-                 return $ TypedContent "image/x-icon"
+  let content = $(embedFile "static/favicon.ico")
-                        $ toContent $(embedFile "static/favicon.ico")
+
+  setEtagHashable content
+
+  return $ TypedContent "image/x-icon"
+         $ toContent content
 
 getRobotsR :: Handler TypedContent
-getRobotsR = return $ TypedContent typePlain
+getRobotsR = do
-                    $ toContent $(embedFile "static/robots.txt")
+  let content = $(embedFile "static/robots.txt")
+
+  setEtagHashable content
+  
+  return $ TypedContent typePlain
+         $ toContent content

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
+        <dl .deflist>
+          <dt .deflist__dt>_{MsgHealthMatchingClusterConfig}
+          <dd .deflist__dd>#{boolSymbol healthMatchingClusterConfig}
+          $maybe httpReachable <- healthHTTPReachable
+            <dt .deflist__dt>_{MsgHealthHTTPReachable}
+            <dd .deflist__dd>#{boolSymbol httpReachable}
+          $maybe ldapAdmins <- healthLDAPAdmins
+            <dt .deflist__dt>_{MsgHealthLDAPAdmins}
+            <dd .deflist__dd>#{textPercent ldapAdmins}
+          $maybe smtpConnect <- healthSMTPConnect
+            <dt .deflist__dt>_{MsgHealthSMTPConnect}
+            <dd .deflist__dd>#{boolSymbol smtpConnect}
+          $maybe widgetMemcached <- healthWidgetMemcached
+            <dt .deflist__dt>_{MsgHealthWidgetMemcached}
+            <dd .deflist__dd>#{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
+          <dl .deflist>
+            <dt .deflist__dt>_{MsgClusterId}
+            <dd .deflist__dd style="font-family: monospace">#{UUID.toText clusterId}
+            <dt .deflist__dt>_{MsgInstanceId}
+            <dd .deflist__dd style="font-family: monospace">#{UUID.toText instanceId}
+        |]
+    provideJson instanceInfo
+    provideRep . return $ tshow instanceInfo

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)
 

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)
 

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

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

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
+      

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

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

src/Model/Types.hs

@@ -87,6 +87,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
   fromPathPiece = UUID.fromString . unpack
@@ -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

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
@@ -112,6 +109,10 @@ data AppSettings = AppSettings
     , appJwtExpiration          :: Maybe NominalDiffTime
     , appJwtEncoding            :: JwtEncoding
     
+    , appHealthCheckInterval    :: NominalDiffTime
+    , appHealthCheckHTTP        :: Bool
+    , appHealthCheckDelayNotify :: Bool
+
     , appInitialLogSettings     :: LogSettings
 
     , appReloadTemplates        :: Bool
@@ -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"

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

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|<i .fas .fa-seedling>|] -- was exclamation
 isNew False = mempty
 
+boolSymbol :: Bool -> Markup
+boolSymbol True  = [shamlet|<i .fas .fa-check>|]
+boolSymbol False = [shamlet|<i .fas .fa-times>|]
+
 
 ---------------------
 -- 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 ]

static/js/utils/form.js

@@ -106,11 +106,15 @@
     return init();
   };
 
-  formUtilities.push({
+  // skipping reactiveButtonUtil (for now)
-    name: REACTIVE_SUBMIT_BUTTON_UTIL_NAME,
+  // the button did not properly re-enable after filling out a form for some safari users.
-    selector: REACTIVE_SUBMIT_BUTTON_UTIL_SELECTOR,
+  // if maybe in the future there is going to be a proper way of (asynchronously) and
-    setup: reactiveSubmitButtonUtil,
+  // 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,
+  // });
 
   /**
    *

templates/course.hamlet

@@ -1,93 +1,92 @@
 $newline never
-<div .container>
+<dl .deflist>
-  <dl .deflist>
+  <dt .deflist__dt>Fakultät/Institut
-    <dt .deflist__dt>Fakultät/Institut
+  <dd .deflist__dd>
+    <div>
+      #{schoolName}
+
+  $maybe descr <- courseDescription course
+    <dt .deflist__dt>_{MsgCourseDescription}
     <dd .deflist__dd>
       <div>
-        #{schoolName}
+        #{descr}
 
-    $maybe descr <- courseDescription course
+  $with numlecs <- length lecturers
-      <dt .deflist__dt>_{MsgCourseDescription}
+    $if numlecs /= 0
+      $if numlecs > 1
+        <dt .deflist__dt>_{MsgLecturersFor}
+      $else
+        <dt .deflist__dt>_{MsgLecturerFor}
       <dd .deflist__dd>
         <div>
-          #{descr}
+          <ul .list--inline .list--comma-separated>
-
+            $forall lect <- lecturers
-    $with numlecs <- length lecturers
+              <li>^{nameEmailWidget' lect}
-      $if numlecs /= 0
+  $with numassi <- length assistants
-        $if numlecs > 1
+    $if numassi /= 0
-          <dt .deflist__dt>_{MsgLecturersFor}
+      $if numassi > 1
-        $else
+        <dt .deflist__dt>_{MsgAssistantsFor}
-          <dt .deflist__dt>_{MsgLecturerFor}
+      $else
-        <dd .deflist__dd>
+        <dt .deflist__dt>_{MsgAssistantFor}
-          <div>
-            <ul .list--inline .list--comma-separated>
-              $forall lect <- lecturers
-                <li>^{nameEmailWidget' lect}
-    $with numassi <- length assistants
-      $if numassi /= 0
-        $if numassi > 1
-          <dt .deflist__dt>_{MsgAssistantsFor}
-        $else
-          <dt .deflist__dt>_{MsgAssistantFor}
-        <dd .deflist__dd>
-          <div>
-            <ul .list--inline .list--comma-separated>
-              $forall assi <- assistants
-                <li>^{nameEmailWidget' assi}
-    $with numcorrector <- length correctors
-      $if numcorrector /= 0
-        <dt .deflist__dt>_{MsgCorrectorsFor numcorrector}
-        <dd .deflist__dd>
-          <div>
-            <ul .list--inline .list--comma-separated>
-              $forall corrector <- correctors
-                <li>^{nameEmailWidget' corrector}
-
-    $maybe link <- courseLinkExternal course
-      <dt .deflist__dt>Website
       <dd .deflist__dd>
         <div>
-          <a href=#{link} target="_blank" rel="noopener" title="Website des Kurses">#{link}
+          <ul .list--inline .list--comma-separated>
+            $forall assi <- assistants
+              <li>^{nameEmailWidget' assi}
+  $with numcorrector <- length correctors
+    $if numcorrector /= 0
+      <dt .deflist__dt>_{MsgCorrectorsFor numcorrector}
+      <dd .deflist__dd>
+        <div>
+          <ul .list--inline .list--comma-separated>
+            $forall corrector <- correctors
+              <li>^{nameEmailWidget' corrector}
+
+  $maybe link <- courseLinkExternal course
+    <dt .deflist__dt>Website
+    <dd .deflist__dd>
+      <div>
+        <a href=#{link} target="_blank" rel="noopener" title="Website des Kurses">#{link}
 $#    $if NTop (Just 0) < NTop (courseCapacity course)
-    <dt .deflist__dt>Teilnehmer
+  <dt .deflist__dt>Teilnehmer
-    <dd .deflist__dd>
+  <dd .deflist__dd>
-        <div>
+      <div>
-          #{participants}
+        #{participants}
-          $maybe capacity <- courseCapacity course
+        $maybe capacity <- courseCapacity course
-            \ von #{capacity}
+          \ von #{capacity}
-    $maybe regFrom <- mRegFrom
+  $maybe regFrom <- mRegFrom
-      <dt .deflist__dt>Anmeldezeitraum
+    <dt .deflist__dt>Anmeldezeitraum
-      <dd .deflist__dd>
-        <div>
-          Ab #{regFrom}
-          $maybe regTo <- mRegTo
-            \ bis #{regTo}
-        $maybe dereg <- mDereg
-          <div>
-            \ <em>Achtung:</em>
-            \ Abmeldung nur bis #{dereg} erlaubt.
-    $if registrationOpen || isJust mRegAt
-      <dt .deflist__dt>
-      <dd .deflist__dd>
-        <div .course__registration>
-          $if registrationOpen
-            $# regForm is defined through templates/widgets/registerForm
-            ^{regForm}
-          $maybe date <- mRegAt
-            _{MsgRegisteredSince date}
-    <dt .deflist__dt>
-      Material
     <dd .deflist__dd>
       <div>
-        $if courseMaterialFree course
+        Ab #{regFrom}
-          Das Kursmaterial ist ohne Anmeldung frei zugänglich.
+        $maybe regTo <- mRegTo
-        $else
+          \ bis #{regTo}
-          Eine Anmeldung zum Kurs ist Voraussetzung zum Zugang zu Kursmaterial
+      $maybe dereg <- mDereg
-          (z.B. Übungsblätter).
+        <div>
-    $if hasTutorials
+          \ <em>Achtung:</em>
-      <dt .deflist__dt>_{MsgCourseTutorials}
+          \ Abmeldung nur bis #{dereg} erlaubt.
-      <dd .deflist__dd>
+  $if registrationOpen || isJust mRegAt
-        ^{tutorialTable}
+    <dt .deflist__dt>
+    <dd .deflist__dd>
+      <div .course__registration>
+        $if registrationOpen
+          $# regForm is defined through templates/widgets/registerForm
+          ^{regForm}
+        $maybe date <- mRegAt
+          _{MsgRegisteredSince date}
+  <dt .deflist__dt>
+    Material
+  <dd .deflist__dd>
+    <div>
+      $if courseMaterialFree course
+        Das Kursmaterial ist ohne Anmeldung frei zugänglich.
+      $else
+        Eine Anmeldung zum Kurs ist Voraussetzung zum Zugang zu Kursmaterial
+        (z.B. Übungsblätter).
+  $if hasTutorials
+    <dt .deflist__dt>_{MsgCourseTutorials}
+    <dd .deflist__dd>
+      ^{tutorialTable}
 
 
 $# <div .container>

templates/default-layout-wrapper.hamlet

@@ -1,20 +1,28 @@
 $newline never
 \<!doctype html>
-\<!--[if lt IE 7]> <html class="no-js ie6 oldie" lang="en"> <![endif]-->
+<html lang=#{primaryLanguage}>
-\<!--[if IE 7]>    <html class="no-js ie7 oldie" lang="en"> <![endif]-->
-\<!--[if IE 8]>    <html class="no-js ie8 oldie" lang="en"> <![endif]-->
-\<!--[if gt IE 8]><!-->
-<html class="no-js" lang="en"> <!--<![endif]-->
   <head>
     <meta charset="UTF-8">
-    <title>#{pageTitle pc}
     <meta name="viewport" content="width=device-width,initial-scale=1">
 
+    $case currentTheme
+      $of ThemeDefault
+        <meta name="theme-color" content="#0a9342">
+      $of ThemeLavender
+        <meta name="theme-color" content="#584c9c">
+      $of ThemeNeutralBlue
+        <meta name="theme-color" content="#3e606f">
+      $of ThemeAberdeenReds
+        <meta name="theme-color" content="#820333">
+      $of ThemeMossGreen
+        <meta name="theme-color" content="#5c996b">
+      $of ThemeSkyLove
+        <meta name="theme-color" content="#87abe5">
+
+    $# title-tag is required even if it is empty
+    <title>#{pageTitle pc}
+
     ^{pageHead pc}
 
-  <body .no-js .theme--#{toPathPiece currentTheme} :isAuth:.logged-in>
+  <body .theme--#{toPathPiece currentTheme} :isAuth:.logged-in>
-    <!-- removes no-js class from body if client supports javascript -->
-    <script>
-      document.body.classList.remove('no-js');
-
     ^{pageBody pc}

templates/default-layout.hamlet

@@ -1,3 +1,4 @@
+$newline never
 $if not isModal
   <!-- secondary navigation at the side -->
   ^{asidenav}

templates/home/openCourses.hamlet

@@ -1,3 +1,4 @@
+$newline never
 <section>
   <h2>_{MsgHomeOpenCourses}
   ^{courseTable}

templates/home/upcomingSheets.hamlet

@@ -1,3 +1,4 @@
+$newline never
 <section>
   <h2>_{MsgHomeUpcomingSheets}
   ^{sheetTable}

templates/table/cell/header.hamlet

@@ -3,10 +3,10 @@ $newline never
   $maybe flag <- sortableKey
     $case directions
       $of [SortAsc]
-        <a .table__th-link href=^{tblLink' $ setParams (wIdent "sorting") (map toPathPiece (SortingSetting flag SortDesc : piSorting'))}>
+        <a .table__th-link rel=nofollow href=^{tblLink' $ setParams (wIdent "sorting") (map toPathPiece (SortingSetting flag SortDesc : piSorting'))}>
           ^{widget}
       $of _
-        <a .table__th-link href=^{tblLink' $ setParams (wIdent "sorting") (map toPathPiece (SortingSetting flag SortAsc : piSorting'))}>
+        <a .table__th-link rel=nofollow href=^{tblLink' $ setParams (wIdent "sorting") (map toPathPiece (SortingSetting flag SortAsc : piSorting'))}>
           ^{widget}
   $nothing
     ^{widget}

templates/table/layout-standalone.hamlet

@@ -1 +1,2 @@
+$newline never
 ^{pageBody tbl}

templates/table/sortable-header.hamlet

@@ -1,3 +1,4 @@
+$newline never
 $maybe flag <- sortableKey
   $case directions
     $of [SortAsc]

templates/terms.hamlet

@@ -1,2 +1,2 @@
-<div .container>
+$newline never
-  ^{table}
+^{table}

templates/widgets/alerts/alerts.hamlet

@@ -1,3 +1,4 @@
+$newline never
 <div #alerts-1 .alerts uw-alerts>
   <div .alerts__toggler>
   $forall (status, msg) <- mmsgs

templates/widgets/footer/footer.hamlet

@@ -1,3 +1,4 @@
+$newline never
 <footer .footer>
   <div .footer-links>
     $forall (MenuItem{menuItemType, menuItemRoute = _, menuItemIcon = _, menuItemLabel, menuItemModal = _}, menuIdent, route) <- menuTypes

templates/widgets/footer/footer.lucius

@@ -14,3 +14,11 @@
     background-color: var(--color-grey-light);
   }
 }
+
+.footer-links * {
+    margin-right: 0.5em;
+
+    &:last {
+        margin-right: 0;
+    }
+}

templates/widgets/navbar/item.hamlet

@@ -1,3 +1,4 @@
+$newline never
 <a .navbar__link-wrapper href=#{route} ##{menuIdent}>
   <i .fas.fa-#{fromMaybe "none" menuItemIcon}>
   <div .navbar__link-label>_{SomeMessage menuItemLabel}