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