fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(sheets): integrate corrector interface into SheetEdit

Browse Source
This commit is contained in:
Gregor Kleen 2019-11-05 16:19:10 +01:00
parent b9734953cf
commit acfd3129ec
14 changed files with 231 additions and 267 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
messages/uniworx/de-de-formal.msg
View File

@ -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

12
messages/uniworx/en-eu.msg
View File

@ -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

4
models/sheets.model
View File

@ -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?

1
routes
View File

@ -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

53
src/Foundation.hs
View File

@ -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

10
src/Handler/Home.hs
View File

@ -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

299
src/Handler/Sheet.hs
View File

@ -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

2
src/Handler/Utils/Exam.hs
View File

@ -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
)
]

13
src/Handler/Utils/Form.hs
View File

@ -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

2
src/Handler/Utils/Sheet.hs
View File

@ -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

62
src/Jobs/Crontab.hs
View File

@ -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

7
src/Utils/Sheet.hs
View File

@ -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

2
templates/corrections-overview.hamlet
View File

@ -129,7 +129,7 @@
$maybe CorrectionInfo{ciSubmissions} <- Map.lookup shn sheetMap
<td .table__th>#{getLoadSum shn}
<td .table__th>#{ciSubmissions}
<td .table__td colspan=3>^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)}
<td .table__td colspan=3>^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SEditR)}
<tr .table__row .table__row--head>
<th>

19
templates/sheetShow.hamlet
View File

@ -14,10 +14,21 @@ $maybe descr <- sheetDescription sheet
$nothing
#{isVisible False}
_{MsgSheetInvisible}
<dt .deflist__dt>_{MsgSheetActiveFrom}
<dd .deflist__dd>#{sheetFrom}
<dt .deflist__dt>_{MsgSheetActiveTo}
<dd .deflist__dd>#{sheetTo}
<dt .deflist__dt>
$if hasSubmission
_{MsgSheetActiveFromParticipant}
$else
_{MsgSheetActiveFromParticipantNoSubmit}
$maybe ts <- sheetFrom
<dd .deflist__dd>#{ts}
$nothing
<dd .deflist__dd>_{MsgSheetActiveFromUnset}
$if hasSubmission
<dt .deflist__dt>_{MsgSheetActiveToParticipant}
$maybe ts <- sheetTo
<dd .deflist__dd>#{ts}
$nothing
<dd .deflist__dd>_{MsgSheetActiveToUnset}
$maybe hints <- hintsFrom <* guard hasHints
<dt .deflist__dt>_{MsgSheetHintFrom}
<dd .deflist__dd>#{hints}