Merge branch 'master' into exam-office

CHANGELOG.md

@@ -2,6 +2,28 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
+## [6.6.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.5.0...v6.6.0) (2019-09-09)
+
+
+### Bug Fixes
+
+* **audit:** add missing submission edit ([537e66e](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/537e66e))
+* **campus-login:** add i18n for ident placeholder ([692e533](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/692e533)), closes [#417](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/417)
+* **course-edit:** improve instructions ([9d53730](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/9d53730))
+* fix tests ([a671937](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a671937))
+* inherit authorization of CAddUserR in more places ([3391904](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/3391904))
+* typo ([fc5ffb7](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/fc5ffb7))
+* **file-upload:** fix inverted logic for when upload is required ([3868e8f](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/3868e8f))
+
+
+### Features
+
+* **course-edit:** warn about long shorthands ([80cb16a](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/80cb16a))
+* **forms:** allow customisation of user-facing datalist values ([412ce98](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/412ce98))
+* **forms:** show studyFeaturesField in studyFeaturesFieldFor ([b7496f9](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/b7496f9)), closes [#451](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/451)
+
+
+
 ## [6.5.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.4.0...v6.5.0) (2019-09-05)
 
 

config/settings.yml

@@ -39,7 +39,13 @@ health-check-interval:
   active-job-executors: "_env:HEALTHCHECK_INTERVAL_ACTIVE_JOB_EXECUTORS:60"
 health-check-delay-notify: "_env:HEALTHCHECK_DELAY_NOTIFY:true"
 health-check-http: "_env:HEALTHCHECK_HTTP:true" # Can we assume, that we can reach ourselves under APPROOT via HTTP (reverse proxies or firewalls might prevent this)?
+
 health-check-active-job-executors-timeout: "_env:HEALTHCHECK_ACTIVE_JOB_EXECUTORS_TIMEOUT:5"
+health-check-active-widget-memcached-timeout: "_env:HEALTHCHECK_ACTIVE_WIDGET_MEMCACHED_TIMEOUT:2"
+health-check-smtp-connect-timeout: "_env:HEALTHCHECK_SMTP_CONNECT_TIMEOUT:5"
+health-check-ldap-admins-timeout: "_env:HEALTHCHECK_LDAP_ADMINS_TIMEOUT:60"
+health-check-http-reachable-timeout: "_env:HEALTHCHECK_HTTP_REACHABLE_TIMEOUT:2"
+health-check-matching-cluster-config-timeout: "_env:HEALTHCHECK_MATCHING_CLUSTER_CONFIG_TIMEOUT:2"
 
 synchronise-ldap-users-within: "_env:SYNCHRONISE_LDAP_WITHIN:1209600"
 synchronise-ldap-users-interval: "_env:SYNCHRONISE_LDAP_INTERVAL:3600"

messages/uniworx/de.msg

@@ -116,7 +116,8 @@ CourseNewHeading: Neuen Kurs anlegen
 CourseEditHeading tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} editieren
 CourseEditTitle: Kurs editieren/anlegen
 CourseMembers: Teilnehmer
-CourseMemberOf: Teilnehmer
+CourseMemberOf: Teilnehmer von
+CourseAssociatedWith: assoziiert mit
 CourseMembersCount n@Int: #{n}
 CourseMembersCountLimited n@Int max@Int: #{n}/#{max}
 CourseMembersCountOf n@Int mbNum@IntMaybe: #{n} Kursanmeldungen #{maybeToMessage " von " mbNum " möglichen"}

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "6.5.0",
+  "version": "6.6.0",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "6.5.0",
+  "version": "6.6.0",
   "description": "",
   "keywords": [],
   "author": "",

package.yaml

@@ -1,5 +1,5 @@
 name:    uniworx
-version: 6.5.0
+version: 6.6.0
 
 dependencies:
   # Due to a bug in GHC 8.0.1, we block its usage
@@ -136,6 +136,7 @@ dependencies:
   - constraints
   - memory
   - pqueue
+  - deepseq
 
 other-extensions:
   - GeneralizedNewtypeDeriving

src/Audit.hs

@@ -20,6 +20,9 @@ import qualified Network.Wai as Wai
 import qualified Network.Socket as Wai
 
 import qualified Net.IP as IP
+import qualified Net.IPv6 as IPv6
+
+import Control.Exception (ErrorCall(..), evaluate)
 
 {-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
 
@@ -30,18 +33,19 @@ data AuditRemoteException
 instance Exception AuditRemoteException
 
 
-getRemote :: (MonadHandler m, MonadThrow m, HasAppSettings (HandlerSite m)) => m IP
+getRemote :: forall m. (MonadHandler m, MonadCatch m, HasAppSettings (HandlerSite m)) => m IP
-getRemote = do
+getRemote = handle testHandler $ do
   ipFromHeader <- getsYesod $ view _appIpFromHeader
   wai <- waiRequest
 
-  if
+  ip <- if
     | ipFromHeader
     , Just ip <- byHeader wai
       -> return ip
     | otherwise
       -> byRemoteHost wai
-  
+
+  liftIO $ evaluate $!! ip
   where
     byHeader wai = listToMaybe $ do
       (h, v) <- Wai.requestHeaders wai
@@ -58,6 +62,15 @@ getRemote = do
             in return $ IP.ipv6 w1 w2 w3 w4 w5 w6 w7 w8
       _other -> throwM ARUnsupportedSocketKind
 
+    testHandler :: ErrorCall -> m IP
+    -- ^ `Yesod.Core.Unsafe.runFakeHandler` does not set a `Wai.remoteHost`
+    --
+    -- We catch only the specific error call used by
+    -- `Yesod.Core.Unsafe.runFakeHandler` and replace it with `IPv6.any` as a
+    -- placeholder value for testing.
+    testHandler (ErrorCall "runFakeHandler-remoteHost") = return $ IP.fromIPv6 IPv6.any
+    testHandler err = throwM err
+
 
 data AuditException
   = AuditRemoteException AuditRemoteException

src/Foundation.hs

@@ -1812,7 +1812,10 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb (CourseR tid ssh csh CUsersR)    = return ("Anmeldungen", Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh CAddUserR)  = return ("Kursteilnehmer hinzufügen", Just $ CourseR tid ssh csh CUsersR)
   breadcrumb (CourseR tid ssh csh CInviteR)   = return ("Einladung", Just $ CourseR tid ssh csh CShowR)
-  breadcrumb (CourseR tid ssh csh (CUserR _)) = return ("Teilnehmer" , Just $ CourseR tid ssh csh CUsersR)
+  breadcrumb (CourseR tid ssh csh (CUserR cID)) = do
+    uid <- decrypt cID
+    User{userDisplayName} <- runDB $ get404 uid
+    return (userDisplayName, Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh CAssignR)   = return ("Zuteilung Korrekturen"  , Just $ CourseR tid ssh csh CCorrectionsR)
   breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen"    , Just $ CourseR tid ssh csh CShowR)

src/Handler/Course/User.hs

@@ -114,8 +114,9 @@ postCUserR tid ssh csh uCId = do
         addMessageI Success MsgCourseStudyFeatureUpdated
       redirect $ currentRoute :#: registrationFieldFrag
 
+  mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
   let regButton
-        | Just _ <- mRegistration = BtnCourseDeregister
+        | is _Just mRegistration = BtnCourseDeregister
         | otherwise = BtnCourseRegister
   ((regButtonRes, regButtonView), regButtonEnctype) <- runFormPost . identifyForm FIDcRegButton $ buttonForm' [regButton]
 
@@ -130,6 +131,9 @@ postCUserR tid ssh csh uCId = do
         , formAnchor = Just registrationButtonFrag
         }
   formResult regButtonRes $ \case
+    _
+      | not mayRegister
+        -> permissionDenied "User may not be registered"
     BtnCourseDeregister
       | Just (Entity pId _) <- mRegistration
         -> do
@@ -160,7 +164,9 @@ postCUserR tid ssh csh uCId = do
   mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime
 
   -- generate output
-  let headingLong  = [whamlet|^{nameWidget userDisplayName userSurname} - _{MsgCourseMemberOf} #{csh} #{tid}|]
+  let headingLong
+        | is _Just mRegistration = [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseMemberOf} #{csh} #{tid}|]
+        | otherwise = [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseAssociatedWith} #{csh} #{tid}|]
       headingShort = prependCourseTitle tid ssh csh $ SomeMessage userDisplayName
   siteLayout headingLong $ do
     setTitleI headingShort

src/Handler/Course/Users.hs

@@ -130,15 +130,18 @@ nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2
 embedRenderMessage ''UniWorX ''CourseUserAction id
 
 
-makeCourseUserTable :: forall h act.
+makeCourseUserTable :: forall h acts.
                        ( Functor h, ToSortable h
-                       , RenderMessage UniWorX act, Eq act, PathPiece act, Finite act)
+                       , MonoFoldable acts
+                       , RenderMessage UniWorX (Element acts), Eq (Element acts), PathPiece (Element acts)
+                       )
                     => CourseId
+                    -> acts
                     -> (UserTableExpr -> E.SqlExpr (E.Value Bool))
-                    -> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData)))
+                    -> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData)))
-                    -> PSValidator (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData))
+                    -> PSValidator (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData))
-                    -> DB (FormResult (act, Set UserId), Widget)
+                    -> DB (FormResult (Element acts, Set UserId), Widget)
-makeCourseUserTable cid restrict colChoices psValidator = do
+makeCourseUserTable cid acts restrict colChoices psValidator = do
     Just currentRoute <- liftHandlerT getCurrentRoute
     -- -- psValidator has default sorting and filtering
     let dbtIdent     = "courseUsers" :: Text
@@ -209,7 +212,7 @@ makeCourseUserTable cid restrict colChoices psValidator = do
           , dbParamsFormAdditional
               = renderAForm FormStandard
                    $  (, mempty) . First . Just
-                  <$> areq (selectField optionsFinite) (fslI MsgAction) Nothing
+                  <$> areq (selectField $ optionsF acts) (fslI MsgAction) Nothing
           , dbParamsFormEvaluate = liftHandlerT . runFormPost
           , dbParamsFormResult   = id
           , dbParamsFormIdent    = def
@@ -228,6 +231,7 @@ getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCUsersR = postCUsersR
 postCUsersR tid ssh csh = do
   (Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do
+    mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
     let colChoices  = mconcat
           [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
           , colUserNameLink (CourseR tid ssh csh . CUserR)
@@ -240,9 +244,13 @@ postCUsersR tid ssh csh = do
           , colUserComment tid ssh csh
           ]
         psValidator = def & defaultSortingByName
+        acts = catMaybes
+          [ Just CourseUserSendMail
+          , guardOn mayRegister CourseUserDeregister
+          ]
     ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
     numParticipants <- count [CourseParticipantCourse ==. cid]
-    table <- makeCourseUserTable cid (const E.true) colChoices psValidator
+    table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator
     return (ent, numParticipants, table)
   formResult participantRes $ \case
     (CourseUserSendMail, selectedUsers) -> do

src/Handler/Material.hs

@@ -356,7 +356,7 @@ postMDelR tid ssh csh mnm = do
     , drSuccessMessage = SomeMessage $ MsgMaterialDeleted mnm
     , drSuccess = SomeRoute $ CourseR tid ssh csh   MaterialListR
     , drAbort   = SomeRoute $ CourseR tid ssh csh $ MaterialR mnm MShowR
-    , drDelete  = \_ -> id  -- TODO: audit 
+    , drDelete  = const id  -- TODO: audit 
     }
 
 -- | Serve all material-files

src/Handler/Submission.hs

@@ -124,7 +124,7 @@ submissionUserInvitationConfig = InvitationConfig{..}
 
 makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe (Source Handler File), Set (Either UserEmail UserId))
 makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,)
-  <$> fileUploadForm (is _Just msmid) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode
+  <$> fileUploadForm (not isLecturer && is _Nothing msmid) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode
   <*> wFormToAForm submittorsForm
   where
     miCell' :: Markup -> Either UserEmail UserId -> Widget

src/Handler/Tutorial/Users.hs

@@ -50,8 +50,9 @@ postTUsersR tid ssh csh tutn = do
         isInTut q = E.exists . E.from $ \tutorialParticipant ->
           E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
                E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
+
     cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-    table <- makeCourseUserTable cid isInTut colChoices psValidator
+    table <- makeCourseUserTable cid universeF isInTut colChoices psValidator
     return (tut, table)
 
   formResult participantRes $ \case

src/Handler/Utils/Course.hs

@@ -24,5 +24,5 @@ courseDeleteRoute drRecords = DeleteRoute
   , drSuccessMessage = SomeMessage MsgCourseDeleted
   , drAbort = error "drAbort undefined"
   , drSuccess = error "drSuccess undefined"
-  , drDelete = \_ -> id  -- TODO: audit
+  , drDelete = const id  -- TODO: audit
   }

src/Handler/Utils/Form.hs

@@ -701,7 +701,7 @@ fileUploadForm isReq mkFs = \case
   NoUpload
     -> pure Nothing
   UploadAny{..}
-    -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt isReq) (zipFileField unpackZips extensionRestriction) (mkFs unpackZips) Nothing
+    -> bool aopt (\f fs _ -> Just <$> areq f fs Nothing) isReq (zipFileField unpackZips extensionRestriction) (mkFs unpackZips) Nothing
   UploadSpecific{..}
     -> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles)
   where

src/Handler/Utils/Sheet.hs

@@ -79,5 +79,5 @@ sheetDeleteRoute drRecords = DeleteRoute
   , drSuccessMessage = SomeMessage MsgSheetDeleted
   , drAbort = error "drAbort undefined"
   , drSuccess = error "drSuccess undefined"
-  , drDelete = \_ -> id  -- TODO: audit
+  , drDelete = const id  -- TODO: audit
   }

src/Jobs/HealthReport.hs

@@ -26,8 +26,6 @@ import qualified Data.CaseInsensitive as CI
 import qualified Network.HaskellNet.SMTP as SMTP
 import Data.Pool (withResource)
 
-import System.Timeout
-
 import Jobs.Queue
 
 import Control.Concurrent.Async.Lifted.Safe (forConcurrently)
@@ -35,11 +33,12 @@ import Control.Concurrent.Async.Lifted.Safe (forConcurrently)
 
 generateHealthReport :: HealthCheck -> Handler HealthReport
 generateHealthReport = $(dispatchTH ''HealthCheck)
+
   
 dispatchHealthCheckMatchingClusterConfig :: Handler HealthReport
 -- ^ Can the cluster configuration be read from the database and does it match our configuration?
 dispatchHealthCheckMatchingClusterConfig
-  = fmap HealthMatchingClusterConfig . runDB $ and <$> forM universeF clusterSettingMatches
+  = fmap HealthMatchingClusterConfig . yesodTimeout (^. _appHealthCheckMatchingClusterConfigTimeout) False . runDB $ and <$> forM universeF clusterSettingMatches
   where
     clusterSettingMatches ClusterCryptoIDKey = do
       ourSetting <- getsYesod appCryptoIDKey
@@ -75,7 +74,7 @@ dispatchHealthCheckMatchingClusterConfig
 
 
 dispatchHealthCheckHTTPReachable :: Handler HealthReport
-dispatchHealthCheckHTTPReachable = HealthHTTPReachable <$> do
+dispatchHealthCheckHTTPReachable = fmap HealthHTTPReachable . yesodTimeout (^. _appHealthCheckHTTPReachableTimeout) (Just False) $ do
   staticAppRoot <- getsYesod $ view _appRoot
   doHTTP <- getsYesod $ view _appHealthCheckHTTP
   for (staticAppRoot <* guard doHTTP) $ \_ -> do
@@ -89,7 +88,7 @@ dispatchHealthCheckHTTPReachable = HealthHTTPReachable <$> do
 
 
 dispatchHealthCheckLDAPAdmins :: Handler HealthReport
-dispatchHealthCheckLDAPAdmins = HealthLDAPAdmins <$> do
+dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHealthCheckLDAPAdminsTimeout) (Just 0) $ 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
@@ -110,7 +109,7 @@ dispatchHealthCheckLDAPAdmins = HealthLDAPAdmins <$> do
 
 
 dispatchHealthCheckSMTPConnect :: Handler HealthReport
-dispatchHealthCheckSMTPConnect = HealthSMTPConnect <$> do
+dispatchHealthCheckSMTPConnect = fmap HealthSMTPConnect . yesodTimeout (^. _appHealthCheckSMTPConnectTimeout) (Just False) $ do
   smtpPool <- getsYesod appSmtpPool
   for smtpPool . flip withResource $ \smtpConn -> do
     response@(rCode, _) <- liftIO $ SMTP.sendCommand smtpConn SMTP.NOOP
@@ -122,7 +121,7 @@ dispatchHealthCheckSMTPConnect = HealthSMTPConnect <$> do
 
 
 dispatchHealthCheckWidgetMemcached :: Handler HealthReport
-dispatchHealthCheckWidgetMemcached = HealthWidgetMemcached <$> do
+dispatchHealthCheckWidgetMemcached = fmap HealthWidgetMemcached . yesodTimeout (^. _appHealthCheckActiveWidgetMemcachedTimeout) (Just False) $ do
   memcachedConn <- getsYesod appWidgetMemcached
   for memcachedConn $ \_memcachedConn' -> do
     let ext = "bin"
@@ -155,11 +154,9 @@ dispatchHealthCheckActiveJobExecutors = HealthActiveJobExecutors <$> do
       tid <- liftIO myThreadId
       let workers' = Map.fromSet jobWorkerName (Map.keysSet jobWorkers)
           workers = Map.filterWithKey (\a _ -> asyncThreadId a /= tid) workers'
-          timeoutMicro = let (MkFixed micro :: Micro) = realToFrac timeoutLength
-                          in fromInteger micro
       $logDebugS "HealthCheckActiveJobExecutors" . tshow . map showWorkerId $ Map.elems workers'
       responders <- fmap (getSum . fold) . liftIO . forConcurrently (Map.toList workers) $ \(_, wName)
-        -> fromMaybe (Sum 0) <$> timeout timeoutMicro (runReaderT ?? app $ Sum 1 <$ writeJobCtlBlock' (writeJobCtl' wName) JobCtlTest)
+        -> diffTimeout timeoutLength (Sum 0) (runReaderT ?? app $ Sum 1 <$ writeJobCtlBlock' (writeJobCtl' wName) JobCtlTest)
       if
         | Map.null workers -> return Nothing
         | otherwise        -> return . Just $ responders % fromIntegral (Map.size workers)

src/Net/IP/Instances.hs

@@ -12,6 +12,13 @@ import Database.Persist.Sql
 
 import qualified Data.Text.Encoding as Text
 
+import Control.DeepSeq (NFData)
+
+import Net.IPv6.Instances ()
+
+
+deriving instance Generic IP
+
 
 instance PersistField IP where
   toPersistValue = PersistDbSpecific . encodeUtf8 . IP.encode
@@ -21,3 +28,5 @@ instance PersistField IP where
   fromPersistValue _ = Left "IP-address values must be converted from PersistDbSpecific, PersistText, or PersistByteString"
 instance PersistFieldSql IP where
   sqlType _ = SqlOther "inet"
+
+instance NFData IP

src/Net/IPv6/Instances.hs

@@ -0,0 +1,16 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Net.IPv6.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Net.IPv6 (IPv6)
+import qualified Net.IPv6 as IPv6
+
+import Control.DeepSeq (NFData)
+
+
+deriving instance Generic IPv6
+
+instance NFData IPv6

src/Settings.hs

@@ -116,7 +116,13 @@ data AppSettings = AppSettings
     , appHealthCheckInterval    :: HealthCheck -> Maybe NominalDiffTime
     , appHealthCheckDelayNotify :: Bool
     , appHealthCheckHTTP        :: Bool
+    
     , appHealthCheckActiveJobExecutorsTimeout :: NominalDiffTime
+    , appHealthCheckActiveWidgetMemcachedTimeout :: NominalDiffTime
+    , appHealthCheckSMTPConnectTimeout :: NominalDiffTime
+    , appHealthCheckLDAPAdminsTimeout :: NominalDiffTime
+    , appHealthCheckHTTPReachableTimeout :: NominalDiffTime
+    , appHealthCheckMatchingClusterConfigTimeout :: NominalDiffTime
 
     , appSynchroniseLdapUsersWithin :: Maybe NominalDiffTime
     , appSynchroniseLdapUsersInterval :: NominalDiffTime
@@ -398,7 +404,13 @@ instance FromJSON AppSettings where
         appHealthCheckInterval    <- (assertM' (> 0) . ) <$> o .: "health-check-interval"
         appHealthCheckDelayNotify <- o .:  "health-check-delay-notify"
         appHealthCheckHTTP        <- o .:  "health-check-http"
+
         appHealthCheckActiveJobExecutorsTimeout <- o .:  "health-check-active-job-executors-timeout"
+        appHealthCheckActiveWidgetMemcachedTimeout <- o .:  "health-check-active-widget-memcached-timeout"
+        appHealthCheckSMTPConnectTimeout <- o .:  "health-check-smtp-connect-timeout"
+        appHealthCheckLDAPAdminsTimeout <- o .:  "health-check-ldap-admins-timeout"
+        appHealthCheckHTTPReachableTimeout <- o .:  "health-check-http-reachable-timeout"
+        appHealthCheckMatchingClusterConfigTimeout <- o .:  "health-check-matching-cluster-config-timeout"
 
         appSessionTimeout         <- o .: "session-timeout"
 

src/Utils.hs

@@ -53,6 +53,7 @@ import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
 import Control.Monad.Except (MonadError(..))
 import Control.Monad.Trans.Maybe as Utils (MaybeT(..))
 import Control.Monad.Catch (catchIf)
+import System.Timeout.Lifted (timeout)
 
 import Language.Haskell.TH
 import Language.Haskell.TH.Instances ()
@@ -689,6 +690,26 @@ mconcatForM = flip mconcatMapM
 findM :: (Monad m, Foldable f) => (a -> MaybeT m b) -> f a -> m (Maybe b)
 findM f = runMaybeT . Fold.foldr (\x as -> f x <|> as) mzero
 
+  
+yesodTimeout :: ( MonadHandler m
+                , MonadBaseControl IO m
+                )
+             => (HandlerSite m -> NominalDiffTime) -- ^ Calculate timeout
+             -> a -- ^ Default value
+             -> m a -- ^ Computation
+             -> m a -- ^ Result of computation or default value, if timeout is reached
+yesodTimeout getTimeout timeoutRes act = do
+  timeoutLength <- getsYesod getTimeout
+  diffTimeout timeoutLength timeoutRes act
+
+diffTimeout :: MonadBaseControl IO m
+            => NominalDiffTime -> a -> m a -> m a
+diffTimeout timeoutLength timeoutRes act = fromMaybe timeoutRes <$> timeout timeoutMicro act
+  where
+    timeoutMicro
+      = let (MkFixed micro :: Micro) = realToFrac timeoutLength
+         in fromInteger micro
+
 -------------
 -- Conduit --
 -------------

templates/course-user.hamlet

@@ -12,12 +12,13 @@
         $maybe date <- mRegAt
           <dt .deflist__dt>_{MsgRegisteredSince}
           <dd .deflist__dd>#{date}
-        <dt .deflist__dt>
+        $if mayRegister
-        <dd .deflist__dd>
+          <dt .deflist__dt>
-          ^{regButtonWidget}
+          <dd .deflist__dd>
-          $maybe _ <- mRegistration
+            ^{regButtonWidget}
-            <p>
+            $maybe _ <- mRegistration
-              _{MsgCourseDeregisterLecturerTip}
+              <p>
+                _{MsgCourseDeregisterLecturerTip}
         <dt .deflist__dt>_{MsgStudyTerms}
         <dd .deflist__dd>
           $if null studies