diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg
index 4ec9695d9..b23d44074 100644
--- a/messages/uniworx/de-de-formal.msg
+++ b/messages/uniworx/de-de-formal.msg
@@ -289,9 +289,15 @@ SheetDescription: Hinweise für Teilnehmer
SheetGroup: Gruppenabgabe
SheetVisibleFrom: Sichtbar für Teilnehmer ab
SheetVisibleFromTip: Ohne Datum nie sichtbar und keine Abgabe möglich; nur für unfertige Blätter leer lassen, deren Bewertung/Fristen sich noch ändern können
-SheetActiveFrom: Beginn Abgabezeitraum
-SheetActiveFromTip: Download der Aufgabenstellung erst ab diesem Datum möglich
-SheetActiveTo: Ende Abgabezeitraum
+SheetActiveFrom: Aktiv ab/Beginn Abgabezeitraum
+SheetActiveFromParticipant: Beginn Abgabezeitraum
+SheetActiveFromParticipantNoSubmit: Herausgabe der Aufgabestellung
+SheetActiveFromTip: Download der Aufgabenstellung und Abgabe erst ab diesem Datum möglich. Ohne Datum keine Abgabe und keine Herausgabe der Aufgabenstellung
+SheetActiveFromUnset: Nie
+SheetActiveTo: Aktiv bis/Ende Abgabezeitraum
+SheetActiveToParticipant: Ende Abgabezeitraum
+SheetActiveToTip: Abgabe nur bis zu diesem Datum möglich. Ohne Datum unbeschränkte Abgabe möglich (soweit gefordert).
+SheetActiveToUnset: Nie
SheetHintFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen
SheetSolutionFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen
SheetMarkingTip: Hinweise zur Korrektur, sichtbar nur für Korrektoren
diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg
index 7232e1590..f760368f4 100644
--- a/messages/uniworx/en-eu.msg
+++ b/messages/uniworx/en-eu.msg
@@ -288,9 +288,15 @@ SheetDescription: Description
SheetGroup: Group submission
SheetVisibleFrom: Visible from (for participants)
SheetVisibleFromTip: Always invisible for participants and no submission possible if left empty; only leave this field empty for temporary/unfinished sheets
-SheetActiveFrom: Submission period start
-SheetActiveFromTip: The exercise sheet will only be available for download starting at this time
-SheetActiveTo: Submission period end
+SheetActiveFrom: Active from/Submission period start
+SheetActiveFromParticipant: Submission period start
+SheetActiveFromParticipantNoSubmit: Assignment published
+SheetActiveFromTip: The exercise sheet's assignment will only be available for download and submission starting at this time. If left empty no submission or download of assignment is ever allowed
+SheetActiveFromUnset: Never
+SheetActiveTo: Active to/Submission period end
+SheetActiveToParticipant: Submission period end
+SheetActiveToTip: Submission will only be possible until this time. If left empty submissions are allowed forever (if at all possible)
+SheetActiveToUnset: Never
SheetHintFromTip: Always invisible for participants if left empty; correctors can always download hints
SheetSolutionFromTip: Always invisible for participants if left empty; correctors can always download solutions
SheetMarkingTip: Instructions for correction, visible only to correctors
diff --git a/models/sheets.model b/models/sheets.model
index 138b50bf1..fcd2cadc4 100644
--- a/models/sheets.model
+++ b/models/sheets.model
@@ -6,8 +6,8 @@ Sheet -- exercise sheet for a given course
grouping SheetGroup -- May participants submit in groups of certain sizes?
markingText Html Maybe -- Instructons for correctors, included in marking templates
visibleFrom UTCTime Maybe -- Invisible to enrolled participants before
- activeFrom UTCTime -- Download of questions and submission is permitted afterwards
- activeTo UTCTime -- Submission is only permitted before
+ activeFrom UTCTime Maybe -- Download of questions and submission is permitted afterwards
+ activeTo UTCTime Maybe -- Submission is only permitted before
hintFrom UTCTime Maybe -- Additional files are made available
solutionFrom UTCTime Maybe -- Solution is made available
submissionMode SubmissionMode -- Submission upload by students and/or through tutors?
diff --git a/routes b/routes
index 1c5500267..af3ba9fc1 100644
--- a/routes
+++ b/routes
@@ -143,7 +143,6 @@
/invite SInviteR GET POST !ownerANDtimeANDuser-submissions
!/#SubmissionFileType SubArchiveR GET !owner !corrector
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector
- /correctors SCorrR GET POST
/iscorrector SIsCorrR GET !corrector -- Route is used to check for corrector access to this sheet
/pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions
/corrector-invite/ SCorrInviteR GET POST
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 5dc20beb7..501c7b22b 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -922,19 +922,19 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
cTime <- liftIO getCurrentTime
let
visible = NTop sheetVisibleFrom <= NTop (Just cTime)
- active = sheetActiveFrom <= cTime && cTime <= sheetActiveTo
- marking = cTime > sheetActiveTo
+ active = NTop sheetActiveFrom <= NTop (Just cTime) && NTop (Just cTime) <= NTop sheetActiveTo
+ marking = NTop (Just cTime) > NTop sheetActiveTo
guard visible
case subRoute of
-- Single Files
- SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime
+ SFileR SheetExercise _ -> guard $ NTop sheetActiveFrom <= NTop (Just cTime)
SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom
SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
SFileR _ _ -> mzero
-- Archives of SheetFileType
- SZipR SheetExercise -> guard $ sheetActiveFrom <= cTime
+ SZipR SheetExercise -> guard $ NTop sheetActiveFrom <= NTop (Just cTime)
SZipR SheetHint -> guard $ maybe False (<= cTime) sheetHintFrom
SZipR SheetSolution -> guard $ maybe False (<= cTime) sheetSolutionFrom
SZipR _ -> mzero
@@ -2192,7 +2192,6 @@ instance YesodBreadcrumbs UniWorX where
SInviteR -> i18nCrumb MsgBreadcrumbSubmissionUserInvite . Just $ CSubmissionR tid ssh csh shn cid SubShowR
SubArchiveR sft -> i18nCrumb sft . Just $ CSubmissionR tid ssh csh shn cid SubShowR
SubDownloadR _ _ -> i18nCrumb MsgBreadcrumbSubmissionFile . Just $ CSubmissionR tid ssh csh shn cid SubShowR
- SCorrR -> i18nCrumb MsgMenuCorrectors . Just $ CSheetR tid ssh csh shn SShowR
SArchiveR -> i18nCrumb MsgBreadcrumbSheetArchive . Just $ CSheetR tid ssh csh shn SShowR
SIsCorrR -> i18nCrumb MsgBreadcrumbSheetIsCorrector . Just $ CSheetR tid ssh csh shn SShowR
SPseudonymR -> i18nCrumb MsgBreadcrumbSheetPseudonym . Just $ CSheetR tid ssh csh shn SShowR
@@ -3120,14 +3119,6 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
, menuItemModal = False
, menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh
}
- , MenuItem
- { menuItemType = PageActionPrime
- , menuItemLabel = MsgMenuCorrectors
- , menuItemIcon = Nothing
- , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR
- , menuItemModal = False
- , menuItemAccessCallback' = return True
- }
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSubmissions
@@ -3178,14 +3169,6 @@ pageActions (CSheetR tid ssh csh shn SSubsR) =
, menuItemModal = True
, menuItemAccessCallback' = return True
}
- , MenuItem
- { menuItemType = PageActionPrime
- , menuItemLabel = MsgMenuCorrectors
- , menuItemIcon = Nothing
- , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR
- , menuItemModal = False
- , menuItemAccessCallback' = return True
- }
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectionsAssign
@@ -3231,32 +3214,6 @@ pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) =
, menuItemAccessCallback' = return True
}
]
-pageActions (CSheetR tid ssh csh shn SCorrR) =
- [ MenuItem
- { menuItemType = PageActionPrime
- , menuItemLabel = MsgMenuSubmissions
- , menuItemIcon = Nothing
- , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR
- , menuItemModal = False
- , menuItemAccessCallback' = return True
- }
- , MenuItem
- { menuItemType = PageActionPrime
- , menuItemLabel = MsgMenuCorrectionsAssign
- , menuItemIcon = Nothing
- , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR
- , menuItemModal = False
- , menuItemAccessCallback' = return True
- }
- , MenuItem
- { menuItemType = PageActionSecondary
- , menuItemLabel = MsgMenuSheetEdit
- , menuItemIcon = Nothing
- , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SEditR
- , menuItemModal = False
- , menuItemAccessCallback' = return True
- }
- ]
pageActions (CourseR tid ssh csh CApplicationsR) =
[ MenuItem
{ menuItemType = PageActionPrime
@@ -3456,8 +3413,6 @@ pageHeading (CSubmissionR tid ssh csh shn _ SubShowR) -- TODO: Rethink this one!
pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR)
= Just $ i18nHeading $ MsgCorrectionHead tid ssh csh shn cid
-- (CSubmissionR tid csh shn cid SubDownloadR) -- just a download
-pageHeading (CSheetR _tid _ssh _csh shn SCorrR)
- = Just $ i18nHeading $ MsgCorrectorsHead shn
-- (CSheetR tid ssh csh shn SFileR) -- just for Downloads
pageHeading CorrectionsR
diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs
index 0382fab4a..7608b1195 100644
--- a/src/Handler/Home.hs
+++ b/src/Handler/Home.hs
@@ -32,7 +32,7 @@ homeUpcomingSheets uid = do
, E.SqlExpr (E.Value SchoolId)
, E.SqlExpr (E.Value CourseShorthand)
, E.SqlExpr (E.Value SheetName)
- , E.SqlExpr (E.Value UTCTime)
+ , E.SqlExpr (E.Value (Maybe UTCTime))
, E.SqlExpr (E.Value (Maybe SubmissionId)))
tableData ((participant `E.InnerJoin` course `E.InnerJoin` sheet) `E.LeftOuterJoin` (submission `E.InnerJoin` subuser)) = do
E.on $ submission E.?. SubmissionId E.==. subuser E.?. SubmissionUserSubmission
@@ -41,7 +41,7 @@ homeUpcomingSheets uid = do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
- E.&&. sheet E.^. SheetActiveTo E.>=. E.val cTime
+ E.&&. E.maybe E.true (E.>=. E.val cTime) (sheet E.^. SheetActiveTo)
return
( course E.^. CourseTerm
, course E.^. CourseSchool
@@ -55,7 +55,7 @@ homeUpcomingSheets uid = do
, E.Value SchoolId
, E.Value CourseShorthand
, E.Value SheetName
- , E.Value UTCTime
+ , E.Value (Maybe UTCTime)
, E.Value (Maybe SubmissionId)
))
(DBCell Handler ())
@@ -70,8 +70,8 @@ homeUpcomingSheets uid = do
anchorCell (CourseR tid ssh csh CShowR) csh
, sortable (Just "sheet") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } ->
anchorCell (CSheetR tid ssh csh shn SShowR) shn
- , sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } ->
- cell $ formatTime SelFormatDateTime deadline >>= toWidget
+ , sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value mDeadline, _) } ->
+ maybe mempty (cell . formatTimeW SelFormatDateTime) mDeadline
, sortable (Just "done") (i18nCell MsgDone) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) } ->
case mbsid of
Nothing -> cell $ do
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index caca8b576..661744614 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -55,6 +55,8 @@ import Text.Hamlet (ihamlet)
import System.FilePath (addExtension)
+import Data.Time.Clock.System (systemEpochDay)
+
{-
* Implement Handlers
@@ -62,22 +64,38 @@ import System.FilePath (addExtension)
* Implement Access in Foundation
-}
+type Loads = Map (Either UserEmail UserId) (InvitationData SheetCorrector)
+
data SheetForm = SheetForm
{ sfName :: SheetName
+ , sfDescription :: Maybe Html
+ , sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe (ConduitT () (Either FileId File) Handler ())
, sfVisibleFrom :: Maybe UTCTime
- , sfActiveFrom :: UTCTime
- , sfActiveTo :: UTCTime
+ , sfActiveFrom :: Maybe UTCTime
+ , sfActiveTo :: Maybe UTCTime
, sfHintFrom :: Maybe UTCTime
, sfSolutionFrom :: Maybe UTCTime
- , sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe (ConduitT () (Either FileId File) Handler ())
, sfType :: SheetType
, sfGrouping :: SheetGroup
, sfSubmissionMode :: SubmissionMode
- , sfDescription :: Maybe Html
+ , sfAutoDistribute :: Bool
, sfMarkingText :: Maybe Html
+ , sfCorrectors :: Loads
-- Keine SheetId im Formular!
}
+data ButtonGeneratePseudonym = BtnGenerate
+ deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonGeneratePseudonym
+instance Finite ButtonGeneratePseudonym
+
+nullaryPathPiece ''ButtonGeneratePseudonym (camelToPathPiece' 1)
+
+instance Button UniWorX ButtonGeneratePseudonym where
+ btnLabel BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|]
+ btnClasses BtnGenerate = [BCIsButton, BCDefault]
+
+
getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileId)
getFtIdMap sId = do
allfIds <- E.select . E.from $ \(sheetFile `E.InnerJoin` file) -> do
@@ -95,33 +113,34 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
(result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
<$> areq (textField & cfStrip & cfCI) (fslI MsgSheetName) (sfName <$> template)
- <* aformSection MsgSheetFormTimes
- <*> aopt utcTimeField (fslI MsgSheetVisibleFrom
- & setTooltip MsgSheetVisibleFromTip)
- ((sfVisibleFrom <$> template) <|> pure (Just ctime))
- <*> areq utcTimeField (fslI MsgSheetActiveFrom
- & setTooltip MsgSheetActiveFromTip)
- (sfActiveFrom <$> template)
- <*> areq utcTimeField (fslI MsgSheetActiveTo) (sfActiveTo <$> template)
- <*> aopt utcTimeField (fslpI MsgSheetHintFrom (mr MsgSheetHintFromPlaceholder)
- & setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template)
- <*> aopt utcTimeField (fslpI MsgSheetSolutionFrom (mr MsgSheetSolutionFromPlaceholder)
- & setTooltip MsgSheetSolutionFromTip) (sfSolutionFrom <$> template)
+ <*> aopt htmlField (fslpI MsgSheetDescription "Html") (sfDescription <$> template)
<* aformSection MsgSheetFormFiles
<*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
<*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template)
<*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
<*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarkingFiles
& setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
+ <* aformSection MsgSheetFormTimes
+ <*> aopt utcTimeField (fslI MsgSheetVisibleFrom
+ & setTooltip MsgSheetVisibleFromTip)
+ ((sfVisibleFrom <$> template) <|> pure (Just ctime))
+ <*> aopt utcTimeField (fslI MsgSheetActiveFrom
+ & setTooltip MsgSheetActiveFromTip)
+ (sfActiveFrom <$> template)
+ <*> aopt utcTimeField (fslI MsgSheetActiveTo & setTooltip MsgSheetActiveToTip) (sfActiveTo <$> template)
+ <*> aopt utcTimeField (fslpI MsgSheetHintFrom (mr MsgSheetHintFromPlaceholder)
+ & setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template)
+ <*> aopt utcTimeField (fslpI MsgSheetSolutionFrom (mr MsgSheetSolutionFromPlaceholder)
+ & setTooltip MsgSheetSolutionFromTip) (sfSolutionFrom <$> template)
<* aformSection MsgSheetFormType
<*> sheetTypeAFormReq (fslI MsgSheetType
& setTooltip (uniworxMessages [MsgSheetTypeInfoBonus, MsgSheetTypeInfoInformational, MsgSheetTypeInfoNotGraded]))
(sfType <$> template)
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
<*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction))
- <*> aopt htmlField (fslpI MsgSheetDescription "Html")
- (sfDescription <$> template)
+ <*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template)
<*> aopt htmlField (fslpI MsgSheetMarking "Html") (sfMarkingText <$> template)
+ <*> correctorForm (fromMaybe mempty $ sfCorrectors <$> template)
return $ case result of
FormSuccess sheetResult
| errorMsgs <- validateSheet mr' sheetResult
@@ -132,10 +151,10 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
validateSheet :: MsgRenderer -> SheetForm -> [Text]
validateSheet (MsgRenderer {..}) (SheetForm{..}) =
[ msg | (False, msg) <-
- [ ( sfVisibleFrom <= Just sfActiveFrom , render MsgSheetErrVisibility)
- , ( sfActiveFrom <= sfActiveTo , render MsgSheetErrDeadlineEarly)
- , ( NTop sfHintFrom >= NTop (Just sfActiveFrom) , render MsgSheetErrHintEarly)
- , ( NTop sfSolutionFrom >= NTop (Just sfActiveTo) , render MsgSheetErrSolutionEarly)
+ [ ( NTop sfVisibleFrom <= NTop sfActiveFrom , render MsgSheetErrVisibility)
+ , ( NTop sfActiveFrom <= NTop sfActiveTo , render MsgSheetErrDeadlineEarly)
+ , ( NTop sfHintFrom >= NTop sfActiveFrom , render MsgSheetErrHintEarly)
+ , ( NTop sfSolutionFrom >= NTop sfActiveTo , render MsgSheetErrSolutionEarly)
] ]
@@ -216,9 +235,9 @@ getSheetListR tid ssh csh = do
else spacerCell
] id & cellAttrs <>~ [("class","list--inline list--space-separated")]
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
- $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> dateTimeCell sheetActiveFrom
+ $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> maybe mempty dateTimeCell sheetActiveFrom
, sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
- $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> dateTimeCell sheetActiveTo
+ $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> maybe mempty dateTimeCell sheetActiveTo
, sortable Nothing (i18nCell MsgSheetType)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> i18nCell sheetType
, sortable Nothing (i18nCell MsgSubmission)
@@ -319,17 +338,6 @@ getSheetListR tid ssh csh = do
defaultLayout $ do
$(widgetFile "sheetList")
-data ButtonGeneratePseudonym = BtnGenerate
- deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
-instance Universe ButtonGeneratePseudonym
-instance Finite ButtonGeneratePseudonym
-
-nullaryPathPiece ''ButtonGeneratePseudonym (camelToPathPiece' 1)
-
-instance Button UniWorX ButtonGeneratePseudonym where
- btnLabel BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|]
- btnClasses BtnGenerate = [BCIsButton, BCDefault]
-
-- Show single sheet
getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSShowR tid ssh csh shn = do
@@ -422,8 +430,9 @@ getSShowR tid ssh csh shn = do
setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn
let zipLink = CSheetR tid ssh csh shn SArchiveR
visibleFrom = visibleUTCTime SelFormatDateTime <$> sheetVisibleFrom sheet
- sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
- sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet
+ hasSubmission = classifySubmissionMode (sheetSubmissionMode sheet) /= SubmissionModeNone
+ sheetFrom <- traverse (formatTime SelFormatDateTime) $ sheetActiveFrom sheet
+ sheetTo <- traverse (formatTime SelFormatDateTime) $ sheetActiveTo sheet
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
markingText <- runMaybeT $ assertM_ (Authorized ==) (evalAccessCorrector tid ssh csh) >> hoistMaybe (sheetMarkingText sheet)
@@ -480,7 +489,8 @@ getSheetNewR tid ssh csh = do
(FormSuccess (Just shn)) -> E.where_ $ sheet E.^. SheetName E.==. E.val shn
-- (FormFailure msgs) -> -- not in MonadHandler anymore -- forM_ msgs (addMessage Error . toHtml)
_other -> return ()
- lastSheets <- runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
+ (lastSheets, loads) <- runDB $ do
+ lSheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
@@ -493,27 +503,35 @@ getSheetNewR tid ssh csh = do
-- E.orderBy [E.desc lastSheetEdit, E.desc (sheet E.^. SheetActiveFrom)]
E.orderBy [E.desc (sheet E.^. SheetActiveFrom)]
E.limit 1
- return sheet
+ let firstEdit = E.sub_select . E.from $ \sheetEdit -> do
+ E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
+ return . E.min_ $ sheetEdit E.^. SheetEditTime
+ return (sheet, firstEdit)
+ cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+ loads <- defaultLoads cid
+ return (lSheets, loads)
now <- liftIO getCurrentTime
let template = case lastSheets of
- ((Entity {entityVal=Sheet{..}}):_) ->
- let addTime = addWeeks $ max 1 $ weeksToAdd sheetActiveTo now
+ ((Entity {entityVal=Sheet{..}}, E.Value fEdit):_) ->
+ let addTime = addWeeks $ max 1 $ weeksToAdd (fromMaybe (UTCTime systemEpochDay 0) $ sheetActiveTo <|> fEdit) now
in Just $ SheetForm
- { sfName = stepTextCounterCI sheetName
- , sfDescription = sheetDescription
- , sfType = sheetType
- , sfGrouping = sheetGrouping
- , sfVisibleFrom = addTime <$> sheetVisibleFrom
- , sfActiveFrom = addTime sheetActiveFrom
- , sfActiveTo = addTime sheetActiveTo
+ { sfName = stepTextCounterCI sheetName
+ , sfDescription = sheetDescription
+ , sfType = sheetType
+ , sfGrouping = sheetGrouping
+ , sfVisibleFrom = addTime <$> sheetVisibleFrom
+ , sfActiveFrom = addTime <$> sheetActiveFrom
+ , sfActiveTo = addTime <$> sheetActiveTo
, sfSubmissionMode = sheetSubmissionMode
- , sfSheetF = Nothing
- , sfHintFrom = addTime <$> sheetHintFrom
- , sfHintF = Nothing
- , sfSolutionFrom = addTime <$> sheetSolutionFrom
- , sfSolutionF = Nothing
- , sfMarkingF = Nothing
- , sfMarkingText = sheetMarkingText
+ , sfSheetF = Nothing
+ , sfHintFrom = addTime <$> sheetHintFrom
+ , sfHintF = Nothing
+ , sfSolutionFrom = addTime <$> sheetSolutionFrom
+ , sfSolutionF = Nothing
+ , sfMarkingF = Nothing
+ , sfMarkingText = sheetMarkingText
+ , sfAutoDistribute = sheetAutoDistribute
+ , sfCorrectors = loads
}
_other -> Nothing
let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
@@ -526,44 +544,49 @@ postSheetNewR = getSheetNewR
getSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSEditR tid ssh csh shn = do
- (Entity sid Sheet{..}, sheetFileIds) <- runDB $ do
- ent <- fetchSheet tid ssh csh shn
+ (Entity sid Sheet{..}, sheetFileIds, currentLoads) <- runDB $ do
+ ent@(Entity sid _) <- fetchSheet tid ssh csh shn
fti <- getFtIdMap $ entityKey ent
- return (ent, fti)
+ cLoads <- Map.union
+ <$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (InvDBDataSheetCorrector sheetCorrectorLoad sheetCorrectorState, InvTokenDataSheetCorrector)) (selectList [ SheetCorrectorSheet ==. sid ] [])
+ <*> fmap (fmap (, InvTokenDataSheetCorrector) . Map.mapKeysMonotonic Left) (sourceInvitationsF sid)
+ return (ent, fti, cLoads)
let template = Just $ SheetForm
- { sfName = sheetName
- , sfDescription = sheetDescription
- , sfType = sheetType
- , sfGrouping = sheetGrouping
- , sfVisibleFrom = sheetVisibleFrom
- , sfActiveFrom = sheetActiveFrom
- , sfActiveTo = sheetActiveTo
+ { sfName = sheetName
+ , sfDescription = sheetDescription
+ , sfType = sheetType
+ , sfGrouping = sheetGrouping
+ , sfVisibleFrom = sheetVisibleFrom
+ , sfActiveFrom = sheetActiveFrom
+ , sfActiveTo = sheetActiveTo
, sfSubmissionMode = sheetSubmissionMode
- , sfSheetF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise
- , sfHintFrom = sheetHintFrom
- , sfHintF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint
- , sfSolutionFrom = sheetSolutionFrom
- , sfSolutionF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetSolution
- , sfMarkingF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking
- , sfMarkingText = sheetMarkingText
+ , sfSheetF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise
+ , sfHintFrom = sheetHintFrom
+ , sfHintF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint
+ , sfSolutionFrom = sheetSolutionFrom
+ , sfSolutionF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetSolution
+ , sfMarkingF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking
+ , sfMarkingText = sheetMarkingText
+ , sfAutoDistribute = sheetAutoDistribute
+ , sfCorrectors = currentLoads
}
+
let action = uniqueReplace sid -- More specific error message for edit old sheet could go here by using myReplaceUnique instead
handleSheetEdit tid ssh csh (Just sid) template action
postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
postSEditR = getSEditR
-handleSheetEdit :: TermId -> SchoolId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
+handleSheetEdit :: TermId -> SchoolId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodJobDB UniWorX (Maybe SheetId)) -> Handler Html
handleSheetEdit tid ssh csh msId template dbAction = do
let mbshn = sfName <$> template
aid <- requireAuthId
+ cid <- runDB $ getKeyBy404 $ TermSchoolCourseShort tid ssh csh
((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm msId template
case res of
(FormSuccess SheetForm{..}) -> do
- saveOkay <- runDB $ do
+ saveOkay <- runDBJobs $ do
actTime <- liftIO getCurrentTime
- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
- oldAutoDistribute <- fmap sheetAutoDistribute . join <$> traverse get msId
let newSheet = Sheet
{ sheetCourse = cid
, sheetName = sfName
@@ -577,7 +600,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
, sheetHintFrom = sfHintFrom
, sheetSolutionFrom = sfSolutionFrom
, sheetSubmissionMode = sfSubmissionMode
- , sheetAutoDistribute = fromMaybe False oldAutoDistribute
+ , sheetAutoDistribute = sfAutoDistribute
}
mbsid <- dbAction newSheet
case mbsid of
@@ -590,22 +613,36 @@ handleSheetEdit tid ssh csh msId template dbAction = do
insert_ $ SheetEdit aid actTime sid
addMessageI Success $ MsgSheetEditOk tid ssh csh sfName
-- Sanity checks generating warnings only, but not errors!
- warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
+ hoist lift . warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
[ (sfVisibleFrom, MsgSheetVisibleFrom)
- , (Just sfActiveFrom, MsgSheetActiveFrom)
- , (Just sfActiveTo, MsgSheetActiveTo)
+ , (sfActiveFrom, MsgSheetActiveFrom)
+ , (sfActiveTo, MsgSheetActiveTo)
, (sfHintFrom, MsgSheetSolutionFromTip)
, (sfSolutionFrom, MsgSheetSolutionFrom)
] ]
+
+ let
+ sheetCorrectors :: Set (Either (Invitation' SheetCorrector) SheetCorrector)
+ sheetCorrectors = Set.fromList . map f $ Map.toList sfCorrectors
+ where
+ f (Left email, invData) = Left (email, sid, invData)
+ f (Right uid, (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector)) = Right $ SheetCorrector uid sid load cState
+ (invites, adds) = partitionEithers $ Set.toList sheetCorrectors
+
+ deleteWhere [ SheetCorrectorSheet ==. sid ]
+ insertMany_ adds
+
+ deleteWhere [InvitationFor ==. invRef @SheetCorrector sid, InvitationEmail /<-. toListOf (folded . _1) invites]
+ sinkInvitationsF correctorInvitationConfig invites
+
return True
- when saveOkay $ redirect $ case msId of
- Just _ -> CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
- Nothing -> CSheetR tid ssh csh sfName SCorrR
+ when saveOkay $
+ redirect $ CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
(FormFailure msgs) -> forM_ msgs $ (addMessage Error) . toHtml
_ -> runDB $ warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
[(sfVisibleFrom =<< template, MsgSheetVisibleFrom)
- ,(sfActiveFrom <$> template, MsgSheetActiveFrom)
- ,(sfActiveTo <$> template, MsgSheetActiveTo)
+ ,(sfActiveFrom =<< template, MsgSheetActiveFrom)
+ ,(sfActiveTo =<< template, MsgSheetActiveTo)
,(sfHintFrom =<< template, MsgSheetSolutionFromTip)
,(sfSolutionFrom =<< template, MsgSheetSolutionFrom)
] ]
@@ -641,14 +678,14 @@ insertSheetFile sid ftype finfo = do
fid <- insert file
void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
-insertSheetFile' :: SheetId -> SheetFileType -> ConduitT () (Either FileId File) Handler () -> YesodDB UniWorX ()
+insertSheetFile' :: SheetId -> SheetFileType -> ConduitT () (Either FileId File) Handler () -> YesodJobDB UniWorX ()
insertSheetFile' sid ftype fs = do
oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype
return (file E.^. FileId)
- keep <- execWriterT . runConduit $ transPipe (lift . lift) fs .| C.mapM_ finsert
+ keep <- execWriterT . runConduit $ transPipe liftHandler fs .| C.mapM_ finsert
mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId)
where
finsert (Left fileId) = tell $ singleton fileId
@@ -657,22 +694,12 @@ insertSheetFile' sid ftype fs = do
void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
-data CorrectorForm = CorrectorForm
- { cfUserId :: UserId
- , cfUserName :: Text
- , cfResult :: FormResult (CorrectorState, Load)
- , cfViewByTut, cfViewProp, cfViewDel, cfViewState :: FieldView UniWorX
- }
-
-type Loads = Map (Either UserEmail UserId) (CorrectorState, Load)
-
-defaultLoads :: SheetId -> DB Loads
+defaultLoads :: CourseId -> DB Loads
-- ^ Generate `Loads` in such a way that minimal editing is required
--
-- For every user, that ever was a corrector for this course, return their last `Load`.
-- "Last `Load`" is taken to mean their `Load` on the `Sheet` with the most recent creation time (first edit).
-defaultLoads shid = do
- cId <- sheetCourse <$> getJust shid
+defaultLoads cId = do
fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> E.distinctOnOrderBy [E.asc (sheetCorrector E.^. SheetCorrectorUser)] $ do
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
@@ -687,37 +714,20 @@ defaultLoads shid = do
return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState)
where
toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads
- toMap = foldMap $ \(E.Value uid, E.Value cLoad, E.Value cState) -> Map.singleton (Right uid) (cState, cLoad)
+ toMap = foldMap $ \(E.Value uid, E.Value cLoad, E.Value cState) -> Map.singleton (Right uid) (InvDBDataSheetCorrector cLoad cState, InvTokenDataSheetCorrector)
-correctorForm :: SheetId -> AForm Handler (Set (Either (Invitation' SheetCorrector) SheetCorrector))
-correctorForm shid = wFormToAForm $ do
+correctorForm :: Loads -> AForm Handler Loads
+correctorForm loads' = wFormToAForm $ do
currentRoute <- fromMaybe (error "correctorForm called from 404-handler") <$> liftHandler getCurrentRoute
userId <- liftHandler requireAuthId
MsgRenderer mr <- getMsgRenderer
let
- currentLoads :: DB Loads
- currentLoads = Map.union
- <$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (sheetCorrectorState, sheetCorrectorLoad)) (selectList [ SheetCorrectorSheet ==. shid ] [])
- <*> fmap (fmap ((,) <$> invDBSheetCorrectorState <*> invDBSheetCorrectorLoad) . Map.mapKeysMonotonic Left) (sourceInvitationsF shid)
- (defaultLoads', currentLoads') <- liftHandler . runDB $ (,) <$> defaultLoads shid <*> currentLoads
-
- isWrite <- liftHandler $ isWriteRequest currentRoute
-
- let
- applyDefaultLoads = Map.null currentLoads' && not isWrite
loads :: Map (Either UserEmail UserId) (CorrectorState, Load)
- loads
- | applyDefaultLoads = defaultLoads'
- | otherwise = currentLoads'
+ loads = loads' <&> \(InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector) -> (cState, load)
- countTutRes <- wreq checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads
-
- -- when (not (Map.null loads) && applyDefaultLoads) $ -- Alert Message
- -- addMessageI Warning MsgCorrectorsDefaulted
- when (not (Map.null loads) && applyDefaultLoads) $ -- Alert Notification
- wformMessage =<< messageIconI Warning IconNoCorrectors MsgCorrectorsDefaulted
+ countTutRes <- wpopt checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads
let
@@ -804,51 +814,16 @@ correctorForm shid = wFormToAForm $ do
miIdent :: Text
miIdent = "correctors"
- postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Set (Either (Invitation' SheetCorrector) SheetCorrector)
- postProcess = Set.fromList . map postProcess' . Map.elems
- where
- sheetCorrectorSheet = shid
-
- postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either (Invitation' SheetCorrector) SheetCorrector
- postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..}
- postProcess' (Left email, (cState, load)) = Left (email, shid, (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector))
+ postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Loads
+ postProcess = Map.fromList . map postProcess' . Map.elems
+ where
+ postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> (Either UserEmail UserId, (InvitationDBData SheetCorrector, InvitationTokenData SheetCorrector))
+ postProcess' = over _2 $ \(cState, load) -> (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector)
filledData :: Maybe (Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)))
filledData = Just . Map.fromList . zip [0..] $ Map.toList loads -- TODO orderBy Name?!
- fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors & setTooltip MsgMassInputTip) True filledData
-
-getSCorrR, postSCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
-postSCorrR = getSCorrR
-getSCorrR tid ssh csh shn = do
- Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn
-
- ((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $
- (,) <$> areq checkBoxField (fslI MsgAutoAssignCorrs) (Just sheetAutoDistribute)
- <*> correctorForm shid
-
- case res of
- FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
- FormSuccess (autoDistribute, sheetCorrectors) -> runDBJobs $ do
- update shid [ SheetAutoDistribute =. autoDistribute ]
-
- let (invites, adds) = partitionEithers $ Set.toList sheetCorrectors
-
- deleteWhere [ SheetCorrectorSheet ==. shid ]
- insertMany_ adds
-
- deleteWhere [InvitationFor ==. invRef @SheetCorrector shid, InvitationEmail /<-. toListOf (folded . _1) invites]
- sinkInvitationsF correctorInvitationConfig invites
-
- addMessageI Success MsgCorrectorsUpdated
- FormMissing -> return ()
-
- defaultLayout $ do
- setTitleI $ MsgSheetCorrectorsTitle tid ssh csh shn
- wrapForm formWidget def
- { formAction = Just . SomeRoute $ CSheetR tid ssh csh shn SCorrR
- , formEncoding = formEnctype
- }
+ fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors & setTooltip MsgMassInputTip) False filledData
instance IsInvitableJunction SheetCorrector where
diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs
index ec5d7f5d2..dd9742e39 100644
--- a/src/Handler/Utils/Exam.hs
+++ b/src/Handler/Utils/Exam.hs
@@ -70,7 +70,7 @@ examBonus (Entity eId Exam{..}) = runConduit $
[ E.when_
( E.not_ . E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence )
E.then_
- ( E.just (sheet E.^. SheetActiveTo) E.<=. examOccurrence E.?. ExamOccurrenceStart
+ ( E.maybe E.true ((E.<=. examOccurrence E.?. ExamOccurrenceStart) . E.just) (sheet E.^. SheetActiveTo)
E.&&. sheet E.^. SheetVisibleFrom E.<=. examOccurrence E.?. ExamOccurrenceStart
)
]
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 3ab191e0a..85467b5f7 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -220,8 +220,17 @@ multiAction :: forall action a.
-> FieldSettings UniWorX
-> Maybe action
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
-multiAction acts fs@FieldSettings{..} defAction csrf = do
- (actionRes, actionView) <- mreq (selectField . optionsF $ Map.keysSet acts) fs defAction
+multiAction = multiAction' mpopt
+
+multiAction' :: forall action a.
+ ( RenderMessage UniWorX action, PathPiece action, Ord action )
+ => (Field Handler action -> FieldSettings UniWorX -> Maybe action -> MForm Handler (FormResult action, FieldView UniWorX))
+ -> Map action (AForm Handler a)
+ -> FieldSettings UniWorX
+ -> Maybe action
+ -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
+multiAction' minp acts fs@FieldSettings{..} defAction csrf = do
+ (actionRes, actionView) <- minp (selectField . optionsF $ Map.keysSet acts) fs defAction
results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
let actionResults = view _1 <$> results
diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs
index 58a873228..723461206 100644
--- a/src/Handler/Utils/Sheet.hs
+++ b/src/Handler/Utils/Sheet.hs
@@ -10,7 +10,7 @@ import qualified Database.Esqueleto.Internal.Sql as E
-- | Map sheet file types to their visibily dates of a given sheet, for convenience
sheetFileTypeDates :: Sheet -> SheetFileType -> Maybe UTCTime
sheetFileTypeDates Sheet{..} = \case
- SheetExercise -> Just sheetActiveFrom
+ SheetExercise -> sheetActiveFrom
SheetHint -> sheetHintFrom
SheetSolution -> sheetSolutionFrom
SheetMarking -> Nothing
diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs
index 29d8e0bf8..814a53407 100644
--- a/src/Jobs/Crontab.hs
+++ b/src/Jobs/Crontab.hs
@@ -163,39 +163,41 @@ determineCrontab = execWriterT $ do
let
sheetJobs (Entity nSheet Sheet{..}) = do
- tell $ HashMap.singleton
- (JobCtlQueue $ JobQueueNotification NotificationSheetActive{..})
- Cron
- { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveFrom
- , cronRepeat = CronRepeatNever
- , cronRateLimit = appNotificationRateLimit
- , cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
- }
- tell $ HashMap.singleton
- (JobCtlQueue $ JobQueueNotification NotificationSheetSoonInactive{..})
- Cron
- { cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max sheetActiveFrom $ addUTCTime (-nominalDay) sheetActiveTo
- , cronRepeat = CronRepeatOnChange -- Allow repetition of the notification (if something changes), but wait at least an hour
- , cronRateLimit = appNotificationRateLimit
- , cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
- }
- tell $ HashMap.singleton
- (JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..})
- Cron
- { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
- , cronRepeat = CronRepeatOnChange
- , cronRateLimit = appNotificationRateLimit
- , cronNotAfter = Left appNotificationExpiration
- }
- when sheetAutoDistribute $
+ for_ sheetActiveFrom $ \aFrom ->
tell $ HashMap.singleton
- (JobCtlQueue $ JobDistributeCorrections nSheet)
+ (JobCtlQueue $ JobQueueNotification NotificationSheetActive{..})
Cron
- { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
- , cronRepeat = CronRepeatNever
- , cronRateLimit = 3600 -- Irrelevant due to `cronRepeat`
- , cronNotAfter = Left nominalDay
+ { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ aFrom
+ , cronRepeat = CronRepeatNever
+ , cronRateLimit = appNotificationRateLimit
+ , cronNotAfter = Right $ maybe CronNotScheduled (CronTimestamp . utcToLocalTimeTZ appTZ) sheetActiveTo
}
+ for_ sheetActiveTo $ \aTo -> do
+ tell $ HashMap.singleton
+ (JobCtlQueue $ JobQueueNotification NotificationSheetSoonInactive{..})
+ Cron
+ { cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . maybe id max sheetActiveFrom $ addUTCTime (-nominalDay) aTo
+ , cronRepeat = CronRepeatOnChange -- Allow repetition of the notification (if something changes), but wait at least an hour
+ , cronRateLimit = appNotificationRateLimit
+ , cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ aTo
+ }
+ tell $ HashMap.singleton
+ (JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..})
+ Cron
+ { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ aTo
+ , cronRepeat = CronRepeatOnChange
+ , cronRateLimit = appNotificationRateLimit
+ , cronNotAfter = Left appNotificationExpiration
+ }
+ when sheetAutoDistribute $
+ tell $ HashMap.singleton
+ (JobCtlQueue $ JobDistributeCorrections nSheet)
+ Cron
+ { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ aTo
+ , cronRepeat = CronRepeatNever
+ , cronRateLimit = 3600 -- Irrelevant due to `cronRepeat`
+ , cronNotAfter = Left nominalDay
+ }
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs
diff --git a/src/Utils/Sheet.hs b/src/Utils/Sheet.hs
index 820def03d..31ee278d6 100644
--- a/src/Utils/Sheet.hs
+++ b/src/Utils/Sheet.hs
@@ -2,6 +2,7 @@ module Utils.Sheet where
import Import.NoFoundation
import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
-- DB Queries for Sheets that are used in several places
@@ -10,8 +11,8 @@ sheetCurrent tid ssh csh = do
now <- liftIO getCurrentTime
sheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
- E.where_ $ sheet E.^. SheetActiveTo E.>. E.val now
- E.&&. sheet E.^. SheetActiveFrom E.<=. E.val now
+ E.where_ $ E.maybe E.true (E.>. E.val now) (sheet E.^. SheetActiveTo)
+ E.&&. sheet E.^. SheetActiveFrom E.<=. E.just (E.val now)
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
@@ -29,7 +30,7 @@ sheetOldUnassigned tid ssh csh = do
now <- liftIO getCurrentTime
sheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
- E.where_ $ sheet E.^. SheetActiveTo E.<=. E.val now
+ E.where_ $ sheet E.^. SheetActiveTo E.<=. E.just (E.val now)
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
diff --git a/templates/corrections-overview.hamlet b/templates/corrections-overview.hamlet
index d6f118de5..da6dc8e8e 100644
--- a/templates/corrections-overview.hamlet
+++ b/templates/corrections-overview.hamlet
@@ -129,7 +129,7 @@
$maybe CorrectionInfo{ciSubmissions} <- Map.lookup shn sheetMap
| #{getLoadSum shn}
| #{ciSubmissions}
- | ^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)}
+ | ^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SEditR)}
|
|
diff --git a/templates/sheetShow.hamlet b/templates/sheetShow.hamlet
index 9f9ddd3e2..321fc573a 100644
--- a/templates/sheetShow.hamlet
+++ b/templates/sheetShow.hamlet
@@ -14,10 +14,21 @@ $maybe descr <- sheetDescription sheet
$nothing
#{isVisible False}
_{MsgSheetInvisible}
- _{MsgSheetActiveFrom}
- #{sheetFrom}
- _{MsgSheetActiveTo}
- #{sheetTo}
+
+ $if hasSubmission
+ _{MsgSheetActiveFromParticipant}
+ $else
+ _{MsgSheetActiveFromParticipantNoSubmit}
+ $maybe ts <- sheetFrom
+ #{ts}
+ $nothing
+ _{MsgSheetActiveFromUnset}
+ $if hasSubmission
+ _{MsgSheetActiveToParticipant}
+ $maybe ts <- sheetTo
+ #{ts}
+ $nothing
+ _{MsgSheetActiveToUnset}
$maybe hints <- hintsFrom <* guard hasHints
_{MsgSheetHintFrom}
#{hints}
|