HealthReport

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"

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.
+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

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

@@ -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

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)

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|
+              <pre style="font-family: monospace; white-space: pre-wrap">
+                #{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|
+          <dl .deflist>
+            <dt .deflist__dt>_{MsgClusterId}
+            <dd .deflist__dd style="font-family: monospace">#{tshow clusterId}
+            <dt .deflist__dt>_{MsgInstanceId}
+            <dd .deflist__dd style="font-family: monospace">#{tshow instanceId}
+        |]
+    provideJson instanceInfo
+    provideRep . return $ tshow instanceInfo

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,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

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/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

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"

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