diff --git a/CHANGELOG.md b/CHANGELOG.md
index f99061c58..6b28f4605 100644
--- a/CHANGELOG.md
+++ b/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)
diff --git a/config/settings.yml b/config/settings.yml
index e4568d03f..8eef1cb7b 100644
--- a/config/settings.yml
+++ b/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"
diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index ce29ac156..78d9bb3d6 100644
--- a/messages/uniworx/de.msg
+++ b/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"}
diff --git a/package-lock.json b/package-lock.json
index 82fa1307c..daac92fa4 100644
--- a/package-lock.json
+++ b/package-lock.json
@@ -1,6 +1,6 @@
{
"name": "uni2work",
- "version": "6.5.0",
+ "version": "6.6.0",
"lockfileVersion": 1,
"requires": true,
"dependencies": {
diff --git a/package.json b/package.json
index 25c9cb292..42d9345cf 100644
--- a/package.json
+++ b/package.json
@@ -1,6 +1,6 @@
{
"name": "uni2work",
- "version": "6.5.0",
+ "version": "6.6.0",
"description": "",
"keywords": [],
"author": "",
diff --git a/package.yaml b/package.yaml
index bfd7e66ed..e8685cb40 100644
--- a/package.yaml
+++ b/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
diff --git a/src/Audit.hs b/src/Audit.hs
index ac8270edf..06d3d8767 100644
--- a/src/Audit.hs
+++ b/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 = do
+getRemote :: forall m. (MonadHandler m, MonadCatch m, HasAppSettings (HandlerSite m)) => m IP
+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
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 66b840ced..2637ccb13 100644
--- a/src/Foundation.hs
+++ b/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)
diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs
index 81ac54d5b..7e8cc7cfd 100644
--- a/src/Handler/Course/User.hs
+++ b/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
diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs
index fc7b82a36..ab74991a1 100644
--- a/src/Handler/Course/Users.hs
+++ b/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)))
- -> PSValidator (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData))
- -> DB (FormResult (act, Set UserId), Widget)
-makeCourseUserTable cid restrict colChoices psValidator = do
+ -> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData)))
+ -> PSValidator (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData))
+ -> DB (FormResult (Element acts, Set UserId), Widget)
+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
diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs
index 3c8a4d150..791475e71 100644
--- a/src/Handler/Material.hs
+++ b/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
diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs
index d2d5a6138..fe52740d4 100644
--- a/src/Handler/Submission.hs
+++ b/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
diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs
index 34046f452..a5441c01d 100644
--- a/src/Handler/Tutorial/Users.hs
+++ b/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
diff --git a/src/Handler/Utils/Course.hs b/src/Handler/Utils/Course.hs
index 0b54617f7..7f7645100 100644
--- a/src/Handler/Utils/Course.hs
+++ b/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
}
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index a9b3331b8..3bc9955ba 100644
--- a/src/Handler/Utils/Form.hs
+++ b/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
diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs
index c3f16c18d..b3161ac89 100644
--- a/src/Handler/Utils/Sheet.hs
+++ b/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
}
diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs
index 157934cf1..a6da601c4 100644
--- a/src/Jobs/HealthReport.hs
+++ b/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)
diff --git a/src/Net/IP/Instances.hs b/src/Net/IP/Instances.hs
index c7e1995f7..59a1b32b1 100644
--- a/src/Net/IP/Instances.hs
+++ b/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
diff --git a/src/Net/IPv6/Instances.hs b/src/Net/IPv6/Instances.hs
new file mode 100644
index 000000000..348dbb969
--- /dev/null
+++ b/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
diff --git a/src/Settings.hs b/src/Settings.hs
index 0874d2b50..922749148 100644
--- a/src/Settings.hs
+++ b/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"
diff --git a/src/Utils.hs b/src/Utils.hs
index 9f10f6da8..0e81738d1 100644
--- a/src/Utils.hs
+++ b/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 --
-------------
diff --git a/templates/course-user.hamlet b/templates/course-user.hamlet
index 338bb52c2..d4d057f4a 100644
--- a/templates/course-user.hamlet
+++ b/templates/course-user.hamlet
@@ -12,12 +12,13 @@
$maybe date <- mRegAt
_{MsgRegisteredSince}
#{date}
-
-
- ^{regButtonWidget}
- $maybe _ <- mRegistration
-
- _{MsgCourseDeregisterLecturerTip}
+ $if mayRegister
+
+
+ ^{regButtonWidget}
+ $maybe _ <- mRegistration
+
+ _{MsgCourseDeregisterLecturerTip}
_{MsgStudyTerms}
$if null studies