fraport/fradrive-old
Archived
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 SheetGroup: Gruppenabgabe
SheetVisibleFrom: Sichtbar für Teilnehmer ab 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 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 SheetActiveFrom: Aktiv ab/Beginn Abgabezeitraum
SheetActiveFromTip: Download der Aufgabenstellung erst ab diesem Datum möglich SheetActiveFromParticipant: Beginn Abgabezeitraum
SheetActiveTo: Ende 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 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 SheetSolutionFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen
SheetMarkingTip: Hinweise zur Korrektur, sichtbar nur für Korrektoren 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 SheetGroup: Group submission
SheetVisibleFrom: Visible from (for participants) 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 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 SheetActiveFrom: Active from/Submission period start
SheetActiveFromTip: The exercise sheet will only be available for download starting at this time SheetActiveFromParticipant: Submission period start
SheetActiveTo: Submission period end 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 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 SheetSolutionFromTip: Always invisible for participants if left empty; correctors can always download solutions
SheetMarkingTip: Instructions for correction, visible only to correctors 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? grouping SheetGroup -- May participants submit in groups of certain sizes?
markingText Html Maybe -- Instructons for correctors, included in marking templates markingText Html Maybe -- Instructons for correctors, included in marking templates
visibleFrom UTCTime Maybe -- Invisible to enrolled participants before visibleFrom UTCTime Maybe -- Invisible to enrolled participants before
activeFrom UTCTime -- Download of questions and submission is permitted afterwards activeFrom UTCTime Maybe -- Download of questions and submission is permitted afterwards
activeTo UTCTime -- Submission is only permitted before activeTo UTCTime Maybe -- Submission is only permitted before
hintFrom UTCTime Maybe -- Additional files are made available hintFrom UTCTime Maybe -- Additional files are made available
solutionFrom UTCTime Maybe -- Solution is made available solutionFrom UTCTime Maybe -- Solution is made available
submissionMode SubmissionMode -- Submission upload by students and/or through tutors? submissionMode SubmissionMode -- Submission upload by students and/or through tutors?

1
routes
View File

@ -143,7 +143,6 @@
/invite SInviteR GET POST !ownerANDtimeANDuser-submissions /invite SInviteR GET POST !ownerANDtimeANDuser-submissions
!/#SubmissionFileType SubArchiveR GET !owner !corrector !/#SubmissionFileType SubArchiveR GET !owner !corrector
!/#SubmissionFileType/*FilePath SubDownloadR 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 /iscorrector SIsCorrR GET !corrector -- Route is used to check for corrector access to this sheet
/pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions /pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions
/corrector-invite/ SCorrInviteR GET POST /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 cTime <- liftIO getCurrentTime
let let
visible = NTop sheetVisibleFrom <= NTop (Just cTime) visible = NTop sheetVisibleFrom <= NTop (Just cTime)
active = sheetActiveFrom <= cTime && cTime <= sheetActiveTo active = NTop sheetActiveFrom <= NTop (Just cTime) && NTop (Just cTime) <= NTop sheetActiveTo
marking = cTime > sheetActiveTo marking = NTop (Just cTime) > NTop sheetActiveTo
guard visible guard visible
case subRoute of case subRoute of
-- Single Files -- Single Files
SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime SFileR SheetExercise _ -> guard $ NTop sheetActiveFrom <= NTop (Just cTime)
SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom
SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
SFileR _ _ -> mzero SFileR _ _ -> mzero
-- Archives of SheetFileType -- Archives of SheetFileType
SZipR SheetExercise -> guard $ sheetActiveFrom <= cTime SZipR SheetExercise -> guard $ NTop sheetActiveFrom <= NTop (Just cTime)
SZipR SheetHint -> guard $ maybe False (<= cTime) sheetHintFrom SZipR SheetHint -> guard $ maybe False (<= cTime) sheetHintFrom
SZipR SheetSolution -> guard $ maybe False (<= cTime) sheetSolutionFrom SZipR SheetSolution -> guard $ maybe False (<= cTime) sheetSolutionFrom
SZipR _ -> mzero SZipR _ -> mzero
@ -2192,7 +2192,6 @@ instance YesodBreadcrumbs UniWorX where
SInviteR -> i18nCrumb MsgBreadcrumbSubmissionUserInvite . Just $ CSubmissionR tid ssh csh shn cid SubShowR SInviteR -> i18nCrumb MsgBreadcrumbSubmissionUserInvite . Just $ CSubmissionR tid ssh csh shn cid SubShowR
SubArchiveR sft -> i18nCrumb sft . 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 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 SArchiveR -> i18nCrumb MsgBreadcrumbSheetArchive . Just $ CSheetR tid ssh csh shn SShowR
SIsCorrR -> i18nCrumb MsgBreadcrumbSheetIsCorrector . 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 SPseudonymR -> i18nCrumb MsgBreadcrumbSheetPseudonym . Just $ CSheetR tid ssh csh shn SShowR
@ -3120,14 +3119,6 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh , 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 , MenuItem
{ menuItemType = PageActionPrime { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSubmissions , menuItemLabel = MsgMenuSubmissions
@ -3178,14 +3169,6 @@ pageActions (CSheetR tid ssh csh shn SSubsR) =
, menuItemModal = True , menuItemModal = True
, menuItemAccessCallback' = return 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 , MenuItem
{ menuItemType = PageActionPrime { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectionsAssign , menuItemLabel = MsgMenuCorrectionsAssign
@ -3231,32 +3214,6 @@ pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) =
, menuItemAccessCallback' = return True , 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) = pageActions (CourseR tid ssh csh CApplicationsR) =
[ MenuItem [ MenuItem
{ menuItemType = PageActionPrime { 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) pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR)
= Just $ i18nHeading $ MsgCorrectionHead tid ssh csh shn cid = Just $ i18nHeading $ MsgCorrectionHead tid ssh csh shn cid
-- (CSubmissionR tid csh shn cid SubDownloadR) -- just a download -- (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 -- (CSheetR tid ssh csh shn SFileR) -- just for Downloads
pageHeading CorrectionsR 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 SchoolId)
, E.SqlExpr (E.Value CourseShorthand) , E.SqlExpr (E.Value CourseShorthand)
, E.SqlExpr (E.Value SheetName) , E.SqlExpr (E.Value SheetName)
, E.SqlExpr (E.Value UTCTime) , E.SqlExpr (E.Value (Maybe UTCTime))
, E.SqlExpr (E.Value (Maybe SubmissionId))) , E.SqlExpr (E.Value (Maybe SubmissionId)))
tableData ((participant `E.InnerJoin` course `E.InnerJoin` sheet) `E.LeftOuterJoin` (submission `E.InnerJoin` subuser)) = do tableData ((participant `E.InnerJoin` course `E.InnerJoin` sheet) `E.LeftOuterJoin` (submission `E.InnerJoin` subuser)) = do
E.on $ submission E.?. SubmissionId E.==. subuser E.?. SubmissionUserSubmission 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.==. sheet E.^. SheetCourse
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid 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 return
( course E.^. CourseTerm ( course E.^. CourseTerm
, course E.^. CourseSchool , course E.^. CourseSchool
@ -55,7 +55,7 @@ homeUpcomingSheets uid = do
, E.Value SchoolId , E.Value SchoolId
, E.Value CourseShorthand , E.Value CourseShorthand
, E.Value SheetName , E.Value SheetName
, E.Value UTCTime , E.Value (Maybe UTCTime)
, E.Value (Maybe SubmissionId) , E.Value (Maybe SubmissionId)
)) ))
(DBCell Handler ()) (DBCell Handler ())
@ -70,8 +70,8 @@ homeUpcomingSheets uid = do
anchorCell (CourseR tid ssh csh CShowR) csh 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, _, _) } -> , 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 anchorCell (CSheetR tid ssh csh shn SShowR) shn
, sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } -> , sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value mDeadline, _) } ->
cell $ formatTime SelFormatDateTime deadline >>= toWidget 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) } -> , 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 case mbsid of
Nothing -> cell $ do Nothing -> cell $ do

297
src/Handler/Sheet.hs
View File

@ -55,6 +55,8 @@ import Text.Hamlet (ihamlet)
import System.FilePath (addExtension) import System.FilePath (addExtension)
import Data.Time.Clock.System (systemEpochDay)
{- {-
* Implement Handlers * Implement Handlers
@ -62,22 +64,38 @@ import System.FilePath (addExtension)
* Implement Access in Foundation * Implement Access in Foundation
-} -}
type Loads = Map (Either UserEmail UserId) (InvitationData SheetCorrector)
data SheetForm = SheetForm data SheetForm = SheetForm
{ sfName :: SheetName { sfName :: SheetName
, sfDescription :: Maybe Html
, sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe (ConduitT () (Either FileId File) Handler ())
, sfVisibleFrom :: Maybe UTCTime , sfVisibleFrom :: Maybe UTCTime
, sfActiveFrom :: UTCTime , sfActiveFrom :: Maybe UTCTime
, sfActiveTo :: UTCTime , sfActiveTo :: Maybe UTCTime
, sfHintFrom :: Maybe UTCTime , sfHintFrom :: Maybe UTCTime
, sfSolutionFrom :: Maybe UTCTime , sfSolutionFrom :: Maybe UTCTime
, sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe (ConduitT () (Either FileId File) Handler ())
, sfType :: SheetType , sfType :: SheetType
, sfGrouping :: SheetGroup , sfGrouping :: SheetGroup
, sfSubmissionMode :: SubmissionMode , sfSubmissionMode :: SubmissionMode
, sfDescription :: Maybe Html , sfAutoDistribute :: Bool
, sfMarkingText :: Maybe Html , sfMarkingText :: Maybe Html
, sfCorrectors :: Loads
-- Keine SheetId im Formular! -- 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 :: Key Sheet -> DB (SheetFileType -> Set FileId)
getFtIdMap sId = do getFtIdMap sId = do
allfIds <- E.select . E.from $ \(sheetFile `E.InnerJoin` file) -> 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 ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
(result, widget) <- flip (renderAForm FormStandard) html $ SheetForm (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
<$> areq (textField & cfStrip & cfCI) (fslI MsgSheetName) (sfName <$> template) <$> areq (textField & cfStrip & cfCI) (fslI MsgSheetName) (sfName <$> template)
<* aformSection MsgSheetFormTimes <*> aopt htmlField (fslpI MsgSheetDescription "Html") (sfDescription <$> template)
<*> 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)
<* aformSection MsgSheetFormFiles <* aformSection MsgSheetFormFiles
<*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template) <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
<*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template) <*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template)
<*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template) <*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
<*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarkingFiles <*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarkingFiles
& setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template) & 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 <* aformSection MsgSheetFormType
<*> sheetTypeAFormReq (fslI MsgSheetType <*> sheetTypeAFormReq (fslI MsgSheetType
& setTooltip (uniworxMessages [MsgSheetTypeInfoBonus, MsgSheetTypeInfoInformational, MsgSheetTypeInfoNotGraded])) & setTooltip (uniworxMessages [MsgSheetTypeInfoBonus, MsgSheetTypeInfoInformational, MsgSheetTypeInfoNotGraded]))
(sfType <$> template) (sfType <$> template)
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template) <*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
<*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction)) <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction))
<*> aopt htmlField (fslpI MsgSheetDescription "Html") <*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template)
(sfDescription <$> template)
<*> aopt htmlField (fslpI MsgSheetMarking "Html") (sfMarkingText <$> template) <*> aopt htmlField (fslpI MsgSheetMarking "Html") (sfMarkingText <$> template)
<*> correctorForm (fromMaybe mempty $ sfCorrectors <$> template)
return $ case result of return $ case result of
FormSuccess sheetResult FormSuccess sheetResult
| errorMsgs <- validateSheet mr' sheetResult | errorMsgs <- validateSheet mr' sheetResult
@ -132,10 +151,10 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
validateSheet :: MsgRenderer -> SheetForm -> [Text] validateSheet :: MsgRenderer -> SheetForm -> [Text]
validateSheet (MsgRenderer {..}) (SheetForm{..}) = validateSheet (MsgRenderer {..}) (SheetForm{..}) =
[ msg | (False, msg) <- [ msg | (False, msg) <-
[ ( sfVisibleFrom <= Just sfActiveFrom , render MsgSheetErrVisibility) [ ( NTop sfVisibleFrom <= NTop sfActiveFrom , render MsgSheetErrVisibility)
, ( sfActiveFrom <= sfActiveTo , render MsgSheetErrDeadlineEarly) , ( NTop sfActiveFrom <= NTop sfActiveTo , render MsgSheetErrDeadlineEarly)
, ( NTop sfHintFrom >= NTop (Just sfActiveFrom) , render MsgSheetErrHintEarly) , ( NTop sfHintFrom >= NTop sfActiveFrom , render MsgSheetErrHintEarly)
, ( NTop sfSolutionFrom >= NTop (Just sfActiveTo) , render MsgSheetErrSolutionEarly) , ( NTop sfSolutionFrom >= NTop sfActiveTo , render MsgSheetErrSolutionEarly)
] ] ] ]
@ -216,9 +235,9 @@ getSheetListR tid ssh csh = do
else spacerCell else spacerCell
] id & cellAttrs <>~ [("class","list--inline list--space-separated")] ] id & cellAttrs <>~ [("class","list--inline list--space-separated")]
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom) , 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) , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> dateTimeCell sheetActiveTo $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> maybe mempty dateTimeCell sheetActiveTo
, sortable Nothing (i18nCell MsgSheetType) , sortable Nothing (i18nCell MsgSheetType)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> i18nCell sheetType $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> i18nCell sheetType
, sortable Nothing (i18nCell MsgSubmission) , sortable Nothing (i18nCell MsgSubmission)
@ -319,17 +338,6 @@ getSheetListR tid ssh csh = do
defaultLayout $ do defaultLayout $ do
$(widgetFile "sheetList") $(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 -- Show single sheet
getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSShowR tid ssh csh shn = do getSShowR tid ssh csh shn = do
@ -422,8 +430,9 @@ getSShowR tid ssh csh shn = do
setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn
let zipLink = CSheetR tid ssh csh shn SArchiveR let zipLink = CSheetR tid ssh csh shn SArchiveR
visibleFrom = visibleUTCTime SelFormatDateTime <$> sheetVisibleFrom sheet visibleFrom = visibleUTCTime SelFormatDateTime <$> sheetVisibleFrom sheet
sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet hasSubmission = classifySubmissionMode (sheetSubmissionMode sheet) /= SubmissionModeNone
sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet sheetFrom <- traverse (formatTime SelFormatDateTime) $ sheetActiveFrom sheet
sheetTo <- traverse (formatTime SelFormatDateTime) $ sheetActiveTo sheet
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
markingText <- runMaybeT $ assertM_ (Authorized ==) (evalAccessCorrector tid ssh csh) >> hoistMaybe (sheetMarkingText 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 (FormSuccess (Just shn)) -> E.where_ $ sheet E.^. SheetName E.==. E.val shn
-- (FormFailure msgs) -> -- not in MonadHandler anymore -- forM_ msgs (addMessage Error . toHtml) -- (FormFailure msgs) -> -- not in MonadHandler anymore -- forM_ msgs (addMessage Error . toHtml)
_other -> return () _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.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ course E.^. CourseTerm E.==. E.val tid E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh 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 lastSheetEdit, E.desc (sheet E.^. SheetActiveFrom)]
E.orderBy [E.desc (sheet E.^. SheetActiveFrom)] E.orderBy [E.desc (sheet E.^. SheetActiveFrom)]
E.limit 1 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 now <- liftIO getCurrentTime
let template = case lastSheets of let template = case lastSheets of
((Entity {entityVal=Sheet{..}}):_) -> ((Entity {entityVal=Sheet{..}}, E.Value fEdit):_) ->
let addTime = addWeeks $ max 1 $ weeksToAdd sheetActiveTo now let addTime = addWeeks $ max 1 $ weeksToAdd (fromMaybe (UTCTime systemEpochDay 0) $ sheetActiveTo <|> fEdit) now
in Just $ SheetForm in Just $ SheetForm
{ sfName = stepTextCounterCI sheetName { sfName = stepTextCounterCI sheetName
, sfDescription = sheetDescription , sfDescription = sheetDescription
, sfType = sheetType , sfType = sheetType
, sfGrouping = sheetGrouping , sfGrouping = sheetGrouping
, sfVisibleFrom = addTime <$> sheetVisibleFrom , sfVisibleFrom = addTime <$> sheetVisibleFrom
, sfActiveFrom = addTime sheetActiveFrom , sfActiveFrom = addTime <$> sheetActiveFrom
, sfActiveTo = addTime sheetActiveTo , sfActiveTo = addTime <$> sheetActiveTo
, sfSubmissionMode = sheetSubmissionMode , sfSubmissionMode = sheetSubmissionMode
, sfSheetF = Nothing , sfSheetF = Nothing
, sfHintFrom = addTime <$> sheetHintFrom , sfHintFrom = addTime <$> sheetHintFrom
, sfHintF = Nothing , sfHintF = Nothing
, sfSolutionFrom = addTime <$> sheetSolutionFrom , sfSolutionFrom = addTime <$> sheetSolutionFrom
, sfSolutionF = Nothing , sfSolutionF = Nothing
, sfMarkingF = Nothing , sfMarkingF = Nothing
, sfMarkingText = sheetMarkingText , sfMarkingText = sheetMarkingText
, sfAutoDistribute = sheetAutoDistribute
, sfCorrectors = loads
} }
_other -> Nothing _other -> Nothing
let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns 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 :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSEditR tid ssh csh shn = do getSEditR tid ssh csh shn = do
(Entity sid Sheet{..}, sheetFileIds) <- runDB $ do (Entity sid Sheet{..}, sheetFileIds, currentLoads) <- runDB $ do
ent <- fetchSheet tid ssh csh shn ent@(Entity sid _) <- fetchSheet tid ssh csh shn
fti <- getFtIdMap $ entityKey ent 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 let template = Just $ SheetForm
{ sfName = sheetName { sfName = sheetName
, sfDescription = sheetDescription , sfDescription = sheetDescription
, sfType = sheetType , sfType = sheetType
, sfGrouping = sheetGrouping , sfGrouping = sheetGrouping
, sfVisibleFrom = sheetVisibleFrom , sfVisibleFrom = sheetVisibleFrom
, sfActiveFrom = sheetActiveFrom , sfActiveFrom = sheetActiveFrom
, sfActiveTo = sheetActiveTo , sfActiveTo = sheetActiveTo
, sfSubmissionMode = sheetSubmissionMode , sfSubmissionMode = sheetSubmissionMode
, sfSheetF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise , sfSheetF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise
, sfHintFrom = sheetHintFrom , sfHintFrom = sheetHintFrom
, sfHintF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint , sfHintF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint
, sfSolutionFrom = sheetSolutionFrom , sfSolutionFrom = sheetSolutionFrom
, sfSolutionF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetSolution , sfSolutionF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetSolution
, sfMarkingF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking , sfMarkingF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking
, sfMarkingText = sheetMarkingText , 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 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 handleSheetEdit tid ssh csh (Just sid) template action
postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
postSEditR = getSEditR 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 handleSheetEdit tid ssh csh msId template dbAction = do
let mbshn = sfName <$> template let mbshn = sfName <$> template
aid <- requireAuthId aid <- requireAuthId
cid <- runDB $ getKeyBy404 $ TermSchoolCourseShort tid ssh csh
((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm msId template ((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm msId template
case res of case res of
(FormSuccess SheetForm{..}) -> do (FormSuccess SheetForm{..}) -> do
saveOkay <- runDB $ do saveOkay <- runDBJobs $ do
actTime <- liftIO getCurrentTime actTime <- liftIO getCurrentTime
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
oldAutoDistribute <- fmap sheetAutoDistribute . join <$> traverse get msId
let newSheet = Sheet let newSheet = Sheet
{ sheetCourse = cid { sheetCourse = cid
, sheetName = sfName , sheetName = sfName
@ -577,7 +600,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
, sheetHintFrom = sfHintFrom , sheetHintFrom = sfHintFrom
, sheetSolutionFrom = sfSolutionFrom , sheetSolutionFrom = sfSolutionFrom
, sheetSubmissionMode = sfSubmissionMode , sheetSubmissionMode = sfSubmissionMode
, sheetAutoDistribute = fromMaybe False oldAutoDistribute , sheetAutoDistribute = sfAutoDistribute
} }
mbsid <- dbAction newSheet mbsid <- dbAction newSheet
case mbsid of case mbsid of
@ -590,22 +613,36 @@ handleSheetEdit tid ssh csh msId template dbAction = do
insert_ $ SheetEdit aid actTime sid insert_ $ SheetEdit aid actTime sid
addMessageI Success $ MsgSheetEditOk tid ssh csh sfName addMessageI Success $ MsgSheetEditOk tid ssh csh sfName
-- Sanity checks generating warnings only, but not errors! -- 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) [ (sfVisibleFrom, MsgSheetVisibleFrom)
, (Just sfActiveFrom, MsgSheetActiveFrom) , (sfActiveFrom, MsgSheetActiveFrom)
, (Just sfActiveTo, MsgSheetActiveTo) , (sfActiveTo, MsgSheetActiveTo)
, (sfHintFrom, MsgSheetSolutionFromTip) , (sfHintFrom, MsgSheetSolutionFromTip)
, (sfSolutionFrom, MsgSheetSolutionFrom) , (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 return True
when saveOkay $ redirect $ case msId of when saveOkay $
Just _ -> CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB redirect $ CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
Nothing -> CSheetR tid ssh csh sfName SCorrR
(FormFailure msgs) -> forM_ msgs $ (addMessage Error) . toHtml (FormFailure msgs) -> forM_ msgs $ (addMessage Error) . toHtml
_ -> runDB $ warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <- _ -> runDB $ warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
[(sfVisibleFrom =<< template, MsgSheetVisibleFrom) [(sfVisibleFrom =<< template, MsgSheetVisibleFrom)
,(sfActiveFrom <$> template, MsgSheetActiveFrom) ,(sfActiveFrom =<< template, MsgSheetActiveFrom)
,(sfActiveTo <$> template, MsgSheetActiveTo) ,(sfActiveTo =<< template, MsgSheetActiveTo)
,(sfHintFrom =<< template, MsgSheetSolutionFromTip) ,(sfHintFrom =<< template, MsgSheetSolutionFromTip)
,(sfSolutionFrom =<< template, MsgSheetSolutionFrom) ,(sfSolutionFrom =<< template, MsgSheetSolutionFrom)
] ] ] ]
@ -641,14 +678,14 @@ insertSheetFile sid ftype finfo = do
fid <- insert file fid <- insert file
void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step 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 insertSheetFile' sid ftype fs = do
oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> 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.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype
return (file E.^. FileId) 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) mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId)
where where
finsert (Left fileId) = tell $ singleton fileId 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 void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
data CorrectorForm = CorrectorForm defaultLoads :: CourseId -> DB Loads
{ 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
-- ^ Generate `Loads` in such a way that minimal editing is required -- ^ 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`. -- 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). -- "Last `Load`" is taken to mean their `Load` on the `Sheet` with the most recent creation time (first edit).
defaultLoads shid = do defaultLoads cId = do
cId <- sheetCourse <$> getJust shid
fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> E.distinctOnOrderBy [E.asc (sheetCorrector E.^. SheetCorrectorUser)] $ 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 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) return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState)
where where
toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads 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 :: Loads -> AForm Handler Loads
correctorForm shid = wFormToAForm $ do correctorForm loads' = wFormToAForm $ do
currentRoute <- fromMaybe (error "correctorForm called from 404-handler") <$> liftHandler getCurrentRoute currentRoute <- fromMaybe (error "correctorForm called from 404-handler") <$> liftHandler getCurrentRoute
userId <- liftHandler requireAuthId userId <- liftHandler requireAuthId
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
let 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 :: Map (Either UserEmail UserId) (CorrectorState, Load)
loads loads = loads' <&> \(InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector) -> (cState, load)
| applyDefaultLoads = defaultLoads'
| otherwise = currentLoads'
countTutRes <- wreq checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads countTutRes <- wpopt 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
let let
@ -804,51 +814,16 @@ correctorForm shid = wFormToAForm $ do
miIdent :: Text miIdent :: Text
miIdent = "correctors" miIdent = "correctors"
postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Set (Either (Invitation' SheetCorrector) SheetCorrector) postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Loads
postProcess = Set.fromList . map postProcess' . Map.elems postProcess = Map.fromList . map postProcess' . Map.elems
where where
sheetCorrectorSheet = shid postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> (Either UserEmail UserId, (InvitationDBData SheetCorrector, InvitationTokenData SheetCorrector))
postProcess' = over _2 $ \(cState, load) -> (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector)
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))
filledData :: Maybe (Map ListPosition (Either UserEmail UserId, (CorrectorState, Load))) filledData :: Maybe (Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)))
filledData = Just . Map.fromList . zip [0..] $ Map.toList loads -- TODO orderBy Name?! filledData = Just . Map.fromList . zip [0..] $ Map.toList loads -- TODO orderBy Name?!
fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors & setTooltip MsgMassInputTip) True filledData fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors & setTooltip MsgMassInputTip) False 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
}
instance IsInvitableJunction SheetCorrector where instance IsInvitableJunction SheetCorrector where

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

@ -70,7 +70,7 @@ examBonus (Entity eId Exam{..}) = runConduit $
[ E.when_ [ E.when_
( E.not_ . E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence ) ( E.not_ . E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence )
E.then_ 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 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 -> FieldSettings UniWorX
-> Maybe action -> Maybe action
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
multiAction acts fs@FieldSettings{..} defAction csrf = do multiAction = multiAction' mpopt
(actionRes, actionView) <- mreq (selectField . optionsF $ Map.keysSet acts) fs defAction
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 results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
let actionResults = view _1 <$> results 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 -- | Map sheet file types to their visibily dates of a given sheet, for convenience
sheetFileTypeDates :: Sheet -> SheetFileType -> Maybe UTCTime sheetFileTypeDates :: Sheet -> SheetFileType -> Maybe UTCTime
sheetFileTypeDates Sheet{..} = \case sheetFileTypeDates Sheet{..} = \case
SheetExercise -> Just sheetActiveFrom SheetExercise -> sheetActiveFrom
SheetHint -> sheetHintFrom SheetHint -> sheetHintFrom
SheetSolution -> sheetSolutionFrom SheetSolution -> sheetSolutionFrom
SheetMarking -> Nothing SheetMarking -> Nothing

62
src/Jobs/Crontab.hs
View File

@ -163,39 +163,41 @@ determineCrontab = execWriterT $ do
let let
sheetJobs (Entity nSheet Sheet{..}) = do sheetJobs (Entity nSheet Sheet{..}) = do
tell $ HashMap.singleton for_ sheetActiveFrom $ \aFrom ->
(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 $
tell $ HashMap.singleton tell $ HashMap.singleton
(JobCtlQueue $ JobDistributeCorrections nSheet) (JobCtlQueue $ JobQueueNotification NotificationSheetActive{..})
Cron Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ aFrom
, cronRepeat = CronRepeatNever , cronRepeat = CronRepeatNever
, cronRateLimit = 3600 -- Irrelevant due to `cronRepeat` , cronRateLimit = appNotificationRateLimit
, cronNotAfter = Left nominalDay , 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 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 Import.NoFoundation
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
-- DB Queries for Sheets that are used in several places -- DB Queries for Sheets that are used in several places
@ -10,8 +11,8 @@ sheetCurrent tid ssh csh = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
sheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do sheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ sheet E.^. SheetActiveTo E.>. E.val now E.where_ $ E.maybe E.true (E.>. E.val now) (sheet E.^. SheetActiveTo)
E.&&. sheet E.^. SheetActiveFrom E.<=. E.val now E.&&. sheet E.^. SheetActiveFrom E.<=. E.just (E.val now)
E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
@ -29,7 +30,7 @@ sheetOldUnassigned tid ssh csh = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
sheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do sheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId 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.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh 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 $maybe CorrectionInfo{ciSubmissions} <- Map.lookup shn sheetMap
<td .table__th>#{getLoadSum shn} <td .table__th>#{getLoadSum shn}
<td .table__th>#{ciSubmissions} <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> <tr .table__row .table__row--head>
<th> <th>

19
templates/sheetShow.hamlet
View File

@ -14,10 +14,21 @@ $maybe descr <- sheetDescription sheet
$nothing $nothing
#{isVisible False} #{isVisible False}
_{MsgSheetInvisible} _{MsgSheetInvisible}
<dt .deflist__dt>_{MsgSheetActiveFrom} <dt .deflist__dt>
<dd .deflist__dd>#{sheetFrom} $if hasSubmission
<dt .deflist__dt>_{MsgSheetActiveTo} _{MsgSheetActiveFromParticipant}
<dd .deflist__dd>#{sheetTo} $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 $maybe hints <- hintsFrom <* guard hasHints
<dt .deflist__dt>_{MsgSheetHintFrom} <dt .deflist__dt>_{MsgSheetHintFrom}
<dd .deflist__dd>#{hints} <dd .deflist__dd>#{hints}