Merge branch 'master' into exam-office
This commit is contained in:
Gregor Kleen
commit
5cec146cb7
22
CHANGELOG.md
22
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)
|
||||
|
||||
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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"}
|
||||
|
||||
2
package-lock.json
generated
2
package-lock.json
generated
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "6.5.0",
|
||||
"version": "6.6.0",
|
||||
"lockfileVersion": 1,
|
||||
"requires": true,
|
||||
"dependencies": {
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "6.5.0",
|
||||
"version": "6.6.0",
|
||||
"description": "",
|
||||
"keywords": [],
|
||||
"author": "",
|
||||
|
||||
@ -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
|
||||
|
||||
21
src/Audit.hs
21
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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
16
src/Net/IPv6/Instances.hs
Normal file
16
src/Net/IPv6/Instances.hs
Normal file
@ -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
|
||||
@ -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"
|
||||
|
||||
|
||||
21
src/Utils.hs
21
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 --
|
||||
-------------
|
||||
|
||||
@ -12,12 +12,13 @@
|
||||
$maybe date <- mRegAt
|
||||
<dt .deflist__dt>_{MsgRegisteredSince}
|
||||
<dd .deflist__dd>#{date}
|
||||
<dt .deflist__dt>
|
||||
<dd .deflist__dd>
|
||||
^{regButtonWidget}
|
||||
$maybe _ <- mRegistration
|
||||
<p>
|
||||
_{MsgCourseDeregisterLecturerTip}
|
||||
$if mayRegister
|
||||
<dt .deflist__dt>
|
||||
<dd .deflist__dd>
|
||||
^{regButtonWidget}
|
||||
$maybe _ <- mRegistration
|
||||
<p>
|
||||
_{MsgCourseDeregisterLecturerTip}
|
||||
<dt .deflist__dt>_{MsgStudyTerms}
|
||||
<dd .deflist__dd>
|
||||
$if null studies
|
||||
|
||||
Reference in New Issue
Block a user