From 25badbe030884eba1d61e72cf32f83f11f2d763b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 30 Apr 2019 17:19:42 +0200 Subject: [PATCH 01/15] HealthReport --- config/settings.yml | 2 ++ messages/uniworx/de.msg | 8 ++++- routes | 2 ++ src/Application.hs | 8 +++-- src/Foundation.hs | 6 ++++ src/Handler/Health.hs | 55 +++++++++++++++++++++++++++++++ src/Jobs.hs | 19 +++++++++++ src/Jobs/Crontab.hs | 9 +++++ src/Jobs/HealthReport.hs | 71 ++++++++++++++++++++++++++++++++++++++++ src/Jobs/Types.hs | 1 + src/Model/Types.hs | 36 ++++++++++++++++++++ src/Settings.hs | 5 +++ src/Settings/Cluster.hs | 10 ++++++ 13 files changed, 229 insertions(+), 3 deletions(-) create mode 100644 src/Handler/Health.hs create mode 100644 src/Jobs/HealthReport.hs diff --git a/config/settings.yml b/config/settings.yml index 287baf0b3..168ba3688 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -30,6 +30,8 @@ session-timeout: 7200 jwt-expiration: 604800 jwt-encoding: HS256 maximum-content-length: 52428800 +health-check-interval: "_env:HEALTHCHECK_INTERVAL:60" +health-check-http: "_env:HEALTHCHECK_HTTP:true" log-settings: detailed: "_env:DETAILED_LOGGING:false" diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 4b8c7f201..259162ce0 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -875,4 +875,10 @@ 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 \ No newline at end of file diff --git a/routes b/routes index dd82ed43b..2fd5f7985 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..7d8927e73 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -95,6 +95,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 +142,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 +162,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 +194,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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 654df9ded..1560cab35 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 @@ -1346,6 +1348,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) diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs new file mode 100644 index 000000000..ecc16589d --- /dev/null +++ b/src/Handler/Health.hs @@ -0,0 +1,55 @@ +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 + + +getHealthR :: Handler TypedContent +getHealthR = do + healthReport' <- liftIO . readTVarIO =<< getsYesod appHealthReport + case healthReport' of + Nothing -> sendResponseStatus noContent204 () + Just (lastUpdated, healthReport) -> do + rContent <- selectRep $ do + provideRep $ + siteLayoutMsg MsgHealthReport $ do + setTitleI MsgHealthReport + let report' = Aeson.encodePrettyToTextBuilder healthReport + [whamlet| + 
+                #{report'}
+            |]
+        provideJson healthReport
+        provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReport
+
+      interval <- getsYesod $ view _appHealthCheckInterval
+      expiresAt $ interval `addUTCTime` lastUpdated
+      addHeader "Last-Modified" $ formatRFC1123 lastUpdated
+      let
+        status 
+          | HealthSuccess <- classifyHealthReport healthReport
+          = ok200
+          | otherwise
+          = internalServerError500
+      sendResponseStatus status rContent
+
+getInstanceR :: Handler TypedContent
+getInstanceR = do
+  instanceInfo@(clusterId, instanceId) <- getsYesod $ (,) <$> appClusterID <*> appInstanceID
+  selectRep $ do
+    provideRep $
+      siteLayoutMsg MsgInstanceIdentification $ do
+        setTitleI MsgInstanceIdentification
+        [whamlet|
+          

+            
_{MsgClusterId}
+            
#{tshow clusterId}
+            
_{MsgInstanceId}
+            
#{tshow instanceId}
+        |]
+    provideJson instanceInfo
+    provideRep . return $ tshow instanceInfo
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..2c10b8f82
--- /dev/null
+++ b/src/Jobs/HealthReport.hs
@@ -0,0 +1,71 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+
+module Jobs.HealthReport
+  ( generateHealthReport
+  ) where
+
+import Import
+
+import qualified Data.Aeson as Aeson
+import Data.Proxy (Proxy(..))
+
+import qualified Data.ByteArray as ByteArray
+
+import Utils.Lens
+
+import Network.HTTP.Simple (httpJSON)
+import qualified Network.HTTP.Simple as HTTP
+
+
+generateHealthReport :: Handler HealthReport
+generateHealthReport = HealthReport
+  <$> matchingClusterConfig
+  <*> httpReachable
+  
+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
+  for staticAppRoot $ \_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
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/Model/Types.hs b/src/Model/Types.hs
index 28ecff845..ac780c123 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,37 @@ 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
+  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  , omitNothingFields  = True
+  } ''HealthReport
+
+data HealthStatus = HealthFailure | HealthWarning | 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
+classifyHealthReport HealthReport{..} = getMin . execWriter $ do
+  unless healthMatchingClusterConfig . tell $ Min HealthFailure
+  unless (fromMaybe True healthHTTPReachable) . tell $ Min HealthFailure
+
+
 -- Type synonyms
 
 type Email           = Text
@@ -936,5 +971,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..ac5e832c2 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -111,6 +111,8 @@ data AppSettings = AppSettings
     , appMaximumContentLength   :: Maybe Word64
     , appJwtExpiration          :: Maybe NominalDiffTime
     , appJwtEncoding            :: JwtEncoding
+    , appHealthCheckInterval    :: NominalDiffTime
+    , appHealthCheckHTTP        :: Bool
 
     , appInitialLogSettings     :: LogSettings
 
@@ -378,6 +380,9 @@ instance FromJSON AppSettings where
         appJwtExpiration          <- o .:? "jwt-expiration"
         appJwtEncoding            <- o .: "jwt-encoding"
 
+        appHealthCheckInterval    <- o .:  "health-check-interval"
+        appHealthCheckHTTP        <- o .:  "health-check-http"
+
         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

From 369c2227a036ef3179a651507e720df6350be68c Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Tue, 30 Apr 2019 19:36:43 +0200
Subject: [PATCH 02/15] healthLDAPAdmins

---
 src/Handler/Utils/Form.hs  |  1 -
 src/Import/NoFoundation.hs |  4 +++-
 src/Jobs/HealthReport.hs   | 31 +++++++++++++++++++++++++++++++
 src/Model/Types.hs         |  7 ++++++-
 4 files changed, 40 insertions(+), 3 deletions(-)

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/HealthReport.hs b/src/Jobs/HealthReport.hs
index 2c10b8f82..e54de26e1 100644
--- a/src/Jobs/HealthReport.hs
+++ b/src/Jobs/HealthReport.hs
@@ -6,6 +6,8 @@ module Jobs.HealthReport
 
 import Import
 
+import Data.List (genericLength)
+
 import qualified Data.Aeson as Aeson
 import Data.Proxy (Proxy(..))
 
@@ -16,11 +18,18 @@ import Utils.Lens
 import Network.HTTP.Simple (httpJSON)
 import qualified Network.HTTP.Simple as HTTP
 
+import qualified Database.Esqueleto as E
+
+import Auth.LDAP
+
+import qualified Data.CaseInsensitive as CI
+
 
 generateHealthReport :: Handler HealthReport
 generateHealthReport = HealthReport
   <$> matchingClusterConfig
   <*> httpReachable
+  <*> ldapAdmins
   
 matchingClusterConfig :: Handler Bool
 -- ^ Can the cluster configuration be read from the database and does it match our configuration?
@@ -58,6 +67,7 @@ matchingClusterConfig = runDB $ and <$> forM universeF clusterSettingMatches
         Just (Aeson.Success c) -> return $ Just c
         _other                 -> return Nothing
 
+
 httpReachable :: Handler (Maybe Bool)
 httpReachable = do
   staticAppRoot <- getsYesod $ view _appRoot
@@ -69,3 +79,24 @@ httpReachable = do
           & 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
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index ac780c123..e7834a59f 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -932,7 +932,11 @@ data HealthReport = HealthReport
   , 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
+    -- 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
   } deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 deriveJSON defaultOptions
@@ -955,6 +959,7 @@ classifyHealthReport :: HealthReport -> HealthStatus
 classifyHealthReport HealthReport{..} = getMin . execWriter $ do
   unless healthMatchingClusterConfig . tell $ Min HealthFailure
   unless (fromMaybe True healthHTTPReachable) . tell $ Min HealthFailure
+  unless (maybe True (> 0) healthLDAPAdmins) . tell $ Min HealthFailure
 
 
 -- Type synonyms

From 8ade1a1bb1fbc9588ff9d864b53709cc5d750aa7 Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Tue, 30 Apr 2019 19:59:47 +0200
Subject: [PATCH 03/15] Delay systemd notify ready until first successful
 healthcheck

---
 config/settings.yml |  1 +
 src/Application.hs  | 14 +++++++++++---
 src/Model/Types.hs  |  2 +-
 src/Settings.hs     |  8 ++++----
 4 files changed, 17 insertions(+), 8 deletions(-)

diff --git a/config/settings.yml b/config/settings.yml
index 168ba3688..60e25dd9a 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -32,6 +32,7 @@ jwt-encoding: HS256
 maximum-content-length: 52428800
 health-check-interval: "_env:HEALTHCHECK_INTERVAL:60"
 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/src/Application.hs b/src/Application.hs
index 7d8927e73..91ef1c7fe 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
 
@@ -315,8 +315,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)
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index e7834a59f..8978b16d6 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -944,7 +944,7 @@ deriveJSON defaultOptions
   , omitNothingFields  = True
   } ''HealthReport
 
-data HealthStatus = HealthFailure | HealthWarning | HealthSuccess
+data HealthStatus = HealthFailure | HealthSuccess
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
 
 instance Universe HealthStatus
diff --git a/src/Settings.hs b/src/Settings.hs
index ac5e832c2..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,8 +108,10 @@ data AppSettings = AppSettings
     , appMaximumContentLength   :: Maybe Word64
     , appJwtExpiration          :: Maybe NominalDiffTime
     , appJwtEncoding            :: JwtEncoding
+    
     , appHealthCheckInterval    :: NominalDiffTime
     , appHealthCheckHTTP        :: Bool
+    , appHealthCheckDelayNotify :: Bool
 
     , appInitialLogSettings     :: LogSettings
 
@@ -280,7 +279,7 @@ deriveFromJSON
 
 deriveJSON
   defaultOptions
-    { constructorTagModifier = over (ix 1) Char.toLower . fromJust . stripPrefix "Level"
+    { constructorTagModifier = camelToPathPiece' 1
     , sumEncoding = UntaggedValue
     }
   ''LogLevel
@@ -382,6 +381,7 @@ instance FromJSON AppSettings where
 
         appHealthCheckInterval    <- o .:  "health-check-interval"
         appHealthCheckHTTP        <- o .:  "health-check-http"
+        appHealthCheckDelayNotify <- o .:  "health-check-delay-notify"
 
         appSessionTimeout         <- o .: "session-timeout"
 

From 667677731e25c289e5c12e9cd4ffeb18d33116d8 Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Tue, 30 Apr 2019 20:18:54 +0200
Subject: [PATCH 04/15] healthSMTPConnect

---
 src/Jobs/HealthReport.hs | 25 +++++++++++++++++++++----
 src/Model/Types.hs       | 12 +++++++++++-
 2 files changed, 32 insertions(+), 5 deletions(-)

diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs
index e54de26e1..1e8cfa4b9 100644
--- a/src/Jobs/HealthReport.hs
+++ b/src/Jobs/HealthReport.hs
@@ -24,12 +24,17 @@ import Auth.LDAP
 
 import qualified Data.CaseInsensitive as CI
 
+import qualified Network.HaskellNet.SMTP as SMTP
+import Data.Pool (withResource)
+
 
 generateHealthReport :: Handler HealthReport
-generateHealthReport = HealthReport
-  <$> matchingClusterConfig
-  <*> httpReachable
-  <*> ldapAdmins
+generateHealthReport
+  = runConcurrently $ HealthReport
+    <$> Concurrently matchingClusterConfig
+    <*> Concurrently httpReachable
+    <*> Concurrently ldapAdmins
+    <*> Concurrently smtpConnect
   
 matchingClusterConfig :: Handler Bool
 -- ^ Can the cluster configuration be read from the database and does it match our configuration?
@@ -100,3 +105,15 @@ ldapAdmins = do
             \(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
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index 8978b16d6..0e0cb2884 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -937,6 +937,8 @@ data HealthReport = HealthReport
     -- ^ 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@?
   } deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 deriveJSON defaultOptions
@@ -944,6 +946,12 @@ deriveJSON defaultOptions
   , 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)
 
@@ -956,10 +964,12 @@ deriveJSON defaultOptions
 nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1
 
 classifyHealthReport :: HealthReport -> HealthStatus
-classifyHealthReport HealthReport{..} = getMin . execWriter $ do
+-- ^ 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
 
 
 -- Type synonyms

From 32512db3cba291e9c860f85a089490e557572529 Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Tue, 30 Apr 2019 20:34:31 +0200
Subject: [PATCH 05/15] healthWidgetMemcached

---
 src/Jobs/HealthReport.hs | 22 +++++++++++++++++++++-
 src/Model/Types.hs       |  3 +++
 2 files changed, 24 insertions(+), 1 deletion(-)

diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs
index 1e8cfa4b9..d1edc5faf 100644
--- a/src/Jobs/HealthReport.hs
+++ b/src/Jobs/HealthReport.hs
@@ -15,7 +15,7 @@ import qualified Data.ByteArray as ByteArray
 
 import Utils.Lens
 
-import Network.HTTP.Simple (httpJSON)
+import Network.HTTP.Simple (httpJSON, httpLBS)
 import qualified Network.HTTP.Simple as HTTP
 
 import qualified Database.Esqueleto as E
@@ -35,6 +35,7 @@ generateHealthReport
     <*> 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?
@@ -117,3 +118,22 @@ smtpConnect = do
       _   -> 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
+    case staticLink of
+      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/Model/Types.hs b/src/Model/Types.hs
index 0e0cb2884..50335333d 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -939,6 +939,8 @@ data HealthReport = HealthReport
     -- 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
@@ -970,6 +972,7 @@ classifyHealthReport HealthReport{..} = getMin . execWriter $ do -- Construction
   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

From 6871a695b41e930a5c2a981f31e80b6cf6629aa4 Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Tue, 30 Apr 2019 20:44:54 +0200
Subject: [PATCH 06/15] 500 instead of 204 when no report is available for too
 long

---
 src/Handler/Health.hs | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs
index ecc16589d..d21b7734a 100644
--- a/src/Handler/Health.hs
+++ b/src/Handler/Health.hs
@@ -12,7 +12,13 @@ getHealthR :: Handler TypedContent
 getHealthR = do
   healthReport' <- liftIO . readTVarIO =<< getsYesod appHealthReport
   case healthReport' of
-    Nothing -> sendResponseStatus noContent204 ()
+    Nothing -> 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
     Just (lastUpdated, healthReport) -> do
       rContent <- selectRep $ do
         provideRep $

From 99fdd4b46f4c2b794243fca79905068c803ab0d3 Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Tue, 30 Apr 2019 21:15:37 +0200
Subject: [PATCH 07/15] Assimilate WATCHDOG_USEC

---
 config/settings.yml |  2 +-
 package.yaml        |  1 +
 src/Application.hs  | 17 ++++++++++++++++-
 3 files changed, 18 insertions(+), 2 deletions(-)

diff --git a/config/settings.yml b/config/settings.yml
index 60e25dd9a..974b2e7e2 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -30,7 +30,7 @@ session-timeout: 7200
 jwt-expiration: 604800
 jwt-encoding: HS256
 maximum-content-length: 52428800
-health-check-interval: "_env:HEALTHCHECK_INTERVAL:60"
+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"
 
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/src/Application.hs b/src/Application.hs
index 91ef1c7fe..30d0947de 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -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.)
@@ -360,7 +364,7 @@ develMain = runResourceT $
 appMain :: MonadResourceBase m => m ()
 appMain = runResourceT $ do
     -- Get the settings from all relevant sources
-    settings <- liftIO $
+    settings' <- liftIO $
       loadYamlSettingsArgs
         -- fall back to compile-time values, set to [] to require values at runtime
         [configSettingsYmlValue]
@@ -368,6 +372,17 @@ appMain = runResourceT $ do
         -- allow environment variables to override
         useEnv
 
+    settings <- execStateT ?? settings' $ do
+      watchdogMicroSec <- liftIO $ (>>= readMay) <$> lookupEnv "WATCHDOG_USEC"
+      watchdogProcess <- liftIO $ (>>= fmap fromInteger . readMay) <$> lookupEnv "WATCHDOG_PID"
+      myProcessID <- liftIO getProcessID
+      $logDebugS "WATCHDOG_USEC" $ tshow (watchdogMicroSec, watchdogProcess, myProcessID)
+      case watchdogMicroSec of
+        Just wInterval
+          | maybe True (== myProcessID) watchdogProcess
+            -> _appHealthCheckInterval %= min (fromRational $ (toRational wInterval / 1e6) / 2)
+        _other -> return ()
+
     -- Generate the foundation from the settings
     foundation <- makeFoundation settings
   

From 347a5ace6327446ed8c3e811580bf6193684f924 Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Tue, 30 Apr 2019 21:23:05 +0200
Subject: [PATCH 08/15] Fix build

---
 src/Application.hs       | 36 +++++++++++++++---------------------
 src/Jobs/HealthReport.hs |  5 ++++-
 2 files changed, 19 insertions(+), 22 deletions(-)

diff --git a/src/Application.hs b/src/Application.hs
index 30d0947de..503386d64 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -352,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 ()
@@ -363,25 +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 <- execStateT ?? settings' $ do
-      watchdogMicroSec <- liftIO $ (>>= readMay) <$> lookupEnv "WATCHDOG_USEC"
-      watchdogProcess <- liftIO $ (>>= fmap fromInteger . readMay) <$> lookupEnv "WATCHDOG_PID"
-      myProcessID <- liftIO getProcessID
-      $logDebugS "WATCHDOG_USEC" $ tshow (watchdogMicroSec, watchdogProcess, myProcessID)
-      case watchdogMicroSec of
-        Just wInterval
-          | maybe True (== myProcessID) watchdogProcess
-            -> _appHealthCheckInterval %= min (fromRational $ (toRational wInterval / 1e6) / 2)
-        _other -> return ()
+    settings <- getAppSettings
 
     -- Generate the foundation from the settings
     foundation <- makeFoundation settings
diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs
index d1edc5faf..a8f6a0ff4 100644
--- a/src/Jobs/HealthReport.hs
+++ b/src/Jobs/HealthReport.hs
@@ -77,7 +77,8 @@ matchingClusterConfig = runDB $ and <$> forM universeF clusterSettingMatches
 httpReachable :: Handler (Maybe Bool)
 httpReachable = do
   staticAppRoot <- getsYesod $ view _appRoot
-  for staticAppRoot $ \_textAppRoot -> do
+  doHTTP <- getsYesod $ view _appHealthCheckHTTP
+  for (staticAppRoot <* guard doHTTP) $ \_textAppRoot -> do
     url <- getUrlRender <*> pure InstanceR
     baseRequest <- HTTP.parseRequest $ unpack url
     httpManager <- getsYesod appHttpManager
@@ -128,7 +129,9 @@ widgetMemcached = do
         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

From d0b2ffe93630eb5cafea92c7f4b1039391d005cd Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Tue, 30 Apr 2019 22:54:29 +0200
Subject: [PATCH 09/15] Prettier human-readable health reports

---
 messages/uniworx/de.msg | 10 +++++++++-
 src/Foundation.hs       | 20 ++++++++++++++++++++
 src/Handler/Health.hs   | 27 ++++++++++++++++++++++-----
 src/Utils.hs            |  4 ++++
 4 files changed, 55 insertions(+), 6 deletions(-)

diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 259162ce0..7f0df9e9a 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -700,6 +700,8 @@ MenuInformation: Informationen
 MenuImpressum: Impressum
 MenuDataProt: Datenschutz
 MenuVersion: Versionsgeschichte
+MenuInstance: Instanz-Identifikation
+MenuHealth: Instanz-Zustand
 MenuHelp: Hilfe
 MenuProfile: Anpassen
 MenuLogin: Login
@@ -881,4 +883,10 @@ HealthReport: Instanz-Zustand
 InstanceIdentification: Instanz-Identifikation
 
 InstanceId: Instanz-Nummer
-ClusterId: Cluster-Nummer
\ No newline at end of file
+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/src/Foundation.hs b/src/Foundation.hs
index 1560cab35..d7b1060ae 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -1655,6 +1655,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/Health.hs b/src/Handler/Health.hs
index d21b7734a..f3d5b4007 100644
--- a/src/Handler/Health.hs
+++ b/src/Handler/Health.hs
@@ -7,6 +7,8 @@ import qualified Data.Text.Lazy.Builder as Builder
 
 import Utils.Lens
 
+import qualified Data.UUID as UUID
+
 
 getHealthR :: Handler TypedContent
 getHealthR = do
@@ -24,10 +26,24 @@ getHealthR = do
         provideRep $
           siteLayoutMsg MsgHealthReport $ do
             setTitleI MsgHealthReport
-            let report' = Aeson.encodePrettyToTextBuilder healthReport
+            let HealthReport{..} = healthReport
             [whamlet|
-              
-                #{report'}
+              $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
@@ -51,11 +67,12 @@ getInstanceR = do
       siteLayoutMsg MsgInstanceIdentification $ do
         setTitleI MsgInstanceIdentification
         [whamlet|
+          $newline never
           

             
_{MsgClusterId}
-            
#{tshow clusterId}
+            
#{UUID.toText clusterId}
             
_{MsgInstanceId}
-            
#{tshow instanceId}
+            
#{UUID.toText instanceId}
         |]
     provideJson instanceInfo
     provideRep . return $ tshow instanceInfo
diff --git a/src/Utils.hs b/src/Utils.hs
index 40fa580ee..7084ecbcb 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -152,6 +152,10 @@ isNew :: Bool -> Markup
 isNew True  = [shamlet||] -- was exclamation
 isNew False = mempty
 
+boolSymbol :: Bool -> Markup
+boolSymbol True  = [shamlet||]
+boolSymbol False = [shamlet||]
+
 
 ---------------------
 -- Text and String --

From 707beee3e349f4f2e56119c3525bf97ddad1dd2d Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Wed, 1 May 2019 12:23:11 +0200
Subject: [PATCH 10/15] Minor HTML tweaks

Fixes #324
---
 src/Foundation.hs                        |   2 +
 templates/course.hamlet                  | 159 +++++++++++------------
 templates/default-layout-wrapper.hamlet  |  30 +++--
 templates/default-layout.hamlet          |   1 +
 templates/home/openCourses.hamlet        |   1 +
 templates/home/upcomingSheets.hamlet     |   1 +
 templates/table/layout-standalone.hamlet |   1 +
 templates/table/sortable-header.hamlet   |   1 +
 templates/terms.hamlet                   |   4 +-
 templates/widgets/alerts/alerts.hamlet   |   1 +
 templates/widgets/footer/footer.hamlet   |   1 +
 templates/widgets/footer/footer.lucius   |   8 ++
 templates/widgets/navbar/item.hamlet     |   1 +
 13 files changed, 118 insertions(+), 93 deletions(-)

diff --git a/src/Foundation.hs b/src/Foundation.hs
index d7b1060ae..05b086ed0 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -1162,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.
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}
-        

-          

-