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

Corrector duties shown in ProfileDataR page now.

Browse Source
This commit is contained in:
SJost 2018-09-14 19:51:13 +02:00
parent cc4c8a897e
commit fe926b116f
6 changed files with 85 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/de.msg
View File

@ -169,7 +169,9 @@ Corrector: Korrektor
Correctors: Korrektoren Correctors: Korrektoren
CorState: Status CorState: Status
CorByTut: Nach Tutorium CorByTut: Nach Tutorium
Tutorial: Tutorium
CorProportion: Anteil CorProportion: Anteil
CorrectionProportion: Anteile
DeleteRow: Zeile entfernen DeleteRow: Zeile entfernen
ProportionNegative: Anteile dürfen nicht negativ sein ProportionNegative: Anteile dürfen nicht negativ sein
CorrectorsUpdated: Korrektoren erfolgreich aktualisiert CorrectorsUpdated: Korrektoren erfolgreich aktualisiert

19
src/Foundation.hs
View File

@ -205,6 +205,25 @@ instance RenderMessage UniWorX CorrectorState where
CorrectorExcused -> renderMessage' MsgCorrectorExcused CorrectorExcused -> renderMessage' MsgCorrectorExcused
where renderMessage' = renderMessage foundation ls where renderMessage' = renderMessage foundation ls
instance RenderMessage UniWorX Load where
renderMessage foundation ls (Load {..}) = loadText <> tutorialText
where
loadText = if byProportion > 0
then (tshow $ fromRational byProportion) <> " " <> renderMessage' MsgCorrectionProportion
else mempty
tutorialText = case byTutorial of
Nothing -> mempty
(Just plusLoad) ->
let connector = if
| loadText == mempty -> mempty
| plusLoad -> " - "
| otherwise -> " + "
in connector <> renderMessage' MsgTutorial
renderMessage' = renderMessage foundation ls
instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route) renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)

70
src/Handler/Profile.hs
View File

@ -113,11 +113,10 @@ getProfileR = do
return (course E.^. CourseTerm, course E.^.CourseSchool, course E.^. CourseShorthand) return (course E.^. CourseTerm, course E.^.CourseSchool, course E.^. CourseShorthand)
) )
<*> <*>
(E.select $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do (E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand) return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
) )
<*> <*>
@ -205,7 +204,7 @@ mkOwnedCoursesTable =
schoolCell <$> view (_dbrOutput . _1 . re _Just) schoolCell <$> view (_dbrOutput . _1 . re _Just)
<*> view (_dbrOutput . _2 ) <*> view (_dbrOutput . _2 )
, sortable (Just "course") (i18nCell MsgCourse) $ , sortable (Just "course") (i18nCell MsgCourse) $
courseLinkCell <$> view (_dbrOutput) courseCellCL <$> view (_dbrOutput)
] ]
validator = def & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc)] validator = def & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc)]
@ -312,7 +311,7 @@ mkSubmissionTable =
schoolCell <$> view ( _1. re _Just) schoolCell <$> view ( _1. re _Just)
<*> view ( _2 ) <*> view ( _2 )
, sortable (Just "course") (i18nCell MsgCourse) $ , sortable (Just "course") (i18nCell MsgCourse) $
courseLinkCell <$> view (_dbrOutput . _1) courseCellCL <$> view (_dbrOutput . _1)
, sortable (Just "sheet") (i18nCell MsgSheet) . magnify _dbrOutput $ , sortable (Just "sheet") (i18nCell MsgSheet) . magnify _dbrOutput $
sheetCell <$> view _1 sheetCell <$> view _1
<*> view _2 <*> view _2
@ -389,7 +388,7 @@ mkSubmissionGroupTable =
schoolCell <$> view ( _1. re _Just) schoolCell <$> view ( _1. re _Just)
<*> view ( _2 ) <*> view ( _2 )
, sortable (Just "course") (i18nCell MsgCourse) $ , sortable (Just "course") (i18nCell MsgCourse) $
courseLinkCell <$> view (_dbrOutput . _1) courseCellCL <$> view (_dbrOutput . _1)
, sortable (Just "submissiongroup") (i18nCell MsgSubmissionGroupName) . magnify (_dbrOutput . _2 . _entityVal) $ , sortable (Just "submissiongroup") (i18nCell MsgSubmissionGroupName) . magnify (_dbrOutput . _2 . _entityVal) $
maybe mempty textCell <$> view _submissionGroupName maybe mempty textCell <$> view _submissionGroupName
, sortable (Just "edit") (i18nCell MsgLastEdit) $ , sortable (Just "edit") (i18nCell MsgLastEdit) $
@ -423,60 +422,53 @@ mkCorrectionsTable =
let dbtIdent = "corrections" :: Text let dbtIdent = "corrections" :: Text
dbtStyle = def dbtStyle = def
-- TODO Continue here -- TODO Continue here
withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a) withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a)
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a)
withType = id withType = id
dbtSQLQuery' uid = \(course `E.InnerJoin` sgroup `E.InnerJoin` sguser) -> do dbtSQLQuery' uid = \(course `E.InnerJoin` sheet `E.InnerJoin` corrector) -> do
E.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.on $ sgroup E.^. SubmissionGroupCourse E.==. course E.^. CourseId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ sguser E.^. SubmissionGroupUserUser E.==. E.val uid E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
let crse = ( course E.^. CourseTerm let crse = ( course E.^. CourseTerm
, course E.^. CourseSchool , course E.^. CourseSchool
, course E.^. CourseShorthand , course E.^. CourseShorthand
) )
return (crse, sgroup, lastSGEdit sgroup) return (crse, sheet E.^. SheetName, corrector)
lastSGEdit sgroup = -- latest Edit-Time of this Submission Group by a user
E.sub_select . E.from $ \(user `E.InnerJoin` sgEdit) -> do
E.on $ user E.^. UserId E.==. sgEdit E.^. SubmissionGroupEditUser
E.where_ $ sgEdit E.^. SubmissionGroupEditSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
return . E.max_ $ sgEdit E.^. SubmissionGroupEditTime
dbtProj = \x -> return $ x dbtProj = \x -> return $ x
& _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
& _dbrOutput . _3 %~ E.unValue & _dbrOutput . _2 %~ E.unValue
dbtColonnade = mconcat dbtColonnade = mconcat
[ dbRow [ dbRow
, sortable (Just "term") (i18nCell MsgTerm) $ , sortable (Just "term") (i18nCell MsgTerm) $
termCell <$> view (_dbrOutput . _1 . _1) termCellCL <$> view (_dbrOutput . _1)
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $ , sortable (Just "school") (i18nCell MsgCourseSchool) $
schoolCell <$> view ( _1. re _Just) schoolCellCL <$> view (_dbrOutput . _1)
<*> view ( _2 )
, sortable (Just "course") (i18nCell MsgCourse) $ , sortable (Just "course") (i18nCell MsgCourse) $
courseLinkCell <$> view (_dbrOutput . _1) courseCellCL <$> view (_dbrOutput . _1)
, sortable (Just "submissiongroup") (i18nCell MsgSubmissionGroupName) . magnify (_dbrOutput . _2 . _entityVal) $ , sortable (Just "sheet") (i18nCell MsgSheet) . magnify _dbrOutput $
maybe mempty textCell <$> view _submissionGroupName sheetCell <$> view _1 <*> view _2
, sortable (Just "edit") (i18nCell MsgLastEdit) $ , sortable (Just "cstate") (i18nCell MsgCorState) $
maybe mempty timeCell <$> view (_dbrOutput . _3) correctorStateCell <$> view (_dbrOutput . _3 . _entityVal)
, sortable (Just "cload") (i18nCell MsgCorProportion) $
correctorLoadCell <$> view (_dbrOutput . _3 . _entityVal)
] ]
validator = def -- DUPLICATED CODE: Handler.Corrections validator = def & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc),("sheet",SortAsc)]
& restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
& restrictSorting (\name _ -> name /= "corrector")
& defaultSorting [("edit",SortDesc)]
dbtSorting = Map.fromList dbtSorting = Map.fromList
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand) [ ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm )
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm ) , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseSchool )
, ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseSchool ) , ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand)
, ( "submissiongroup" , SortColumn $ withType $ \(_ `E.InnerJoin` sgroup `E.InnerJoin` _) -> sgroup E.^. SubmissionGroupName ) , ( "sheet" , SortColumn $ withType $ \(_ `E.InnerJoin` sheet `E.InnerJoin` _) -> sheet E.^. SheetName )
, ( "edit" , SortColumn $ withType $ \(_ `E.InnerJoin` sgroup `E.InnerJoin` _ ) -> lastSGEdit sgroup) , ( "cstate", SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.InnerJoin` cs) -> cs E.^. SheetCorrectorState )
, ( "cload" , SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.InnerJoin` cs) -> cs E.^. SheetCorrectorLoad )
] ]
dbtFilter = Map.fromList dbtFilter = Map.fromList
[ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) [ ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
, ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
, ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
] ]
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
in dbTableWidget' validator $ DBTable {..} in dbTableWidget' validator $ DBTable {..}

6
src/Handler/Submission.hs
View File

@ -157,8 +157,8 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
E.orderBy [E.asc $ user E.^. UserEmail] E.orderBy [E.asc $ user E.^. UserEmail]
return $ (user E.^. UserId, user E.^. UserEmail) return $ (user E.^. UserId, user E.^. UserEmail)
let breakUserFromBuddies (E.Value userID, E.Value email) let breakUserFromBuddies (E.Value userID, E.Value email)
| uid == userID = (Any True , []) | uid == userID = (Any True , [])
| otherwise = (Any False, [email]) | otherwise = (Any False, [email])
return $ foldMap breakUserFromBuddies submittors return $ foldMap breakUserFromBuddies submittors
lastEdits <- do lastEdits <- do
@ -167,7 +167,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid
E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime] E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
-- E.limit numberOfSubmissionEditDates -- DEPRECATED we always show all edit times -- E.limit numberOfSubmissionEditDates -- DEPRECATED we always show all edit times
let userName = if maySubmit || isOwner let userName = if isOwner || maySubmit
then E.just $ user E.^. UserDisplayName then E.just $ user E.^. UserDisplayName
else E.nothing else E.nothing
return $ (userName, submissionEdit E.^. SubmissionEditTime) return $ (userName, submissionEdit E.^. SubmissionEditTime)

17
src/Handler/Utils/Table/Cells.hs
View File

@ -38,6 +38,9 @@ termCell tid = anchorCell link name
link = TermCourseListR tid link = TermCourseListR tid
name = text2widget $ display tid name = text2widget $ display tid
termCellCL :: IsDBTable m a => CourseLink -> DBCell m a
termCellCL (tid,_,_) = termCell tid
schoolCell :: IsDBTable m a => Maybe TermId -> SchoolId -> DBCell m a schoolCell :: IsDBTable m a => Maybe TermId -> SchoolId -> DBCell m a
schoolCell (Just tid) ssh = anchorCell link name schoolCell (Just tid) ssh = anchorCell link name
where where
@ -48,8 +51,11 @@ schoolCell Nothing ssh = anchorCell link name
link = SchoolShowR ssh link = SchoolShowR ssh
name = text2widget $ display ssh name = text2widget $ display ssh
courseLinkCell :: IsDBTable m a => CourseLink -> DBCell m a schoolCellCL :: IsDBTable m a => CourseLink -> DBCell m a
courseLinkCell (tid,ssh,csh) = anchorCell link name schoolCellCL (tid,ssh,_) = schoolCell (Just tid) ssh
courseCellCL :: IsDBTable m a => CourseLink -> DBCell m a
courseCellCL (tid,ssh,csh) = anchorCell link name
where where
link = CourseR tid ssh csh CShowR link = CourseR tid ssh csh CShowR
name = citext2widget csh name = citext2widget csh
@ -81,3 +87,10 @@ submissionCell crse shn sid =
mkText cid = display2widget cid mkText cid = display2widget cid
in anchorCellM' mkCid mkRoute mkText in anchorCellM' mkCid mkRoute mkText
correctorStateCell :: IsDBTable m a => SheetCorrector -> DBCell m a
correctorStateCell sc =
i18nCell $ sheetCorrectorState sc
correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a
correctorLoadCell sc =
i18nCell $ sheetCorrectorLoad sc

30
templates/correction-user.hamlet
View File

@ -1,39 +1,39 @@
<div .scrolltable> <div .scrolltable>
<table .table .table--striped .table--hover .table--vertical> <table .table .table--striped .table--hover .table--vertical>
<tr .table__row> <tr .table__row>
<th .table__th> _{MsgSubmission} <th .table__th>_{MsgSubmission}
<td .table__td> #{display cid} <td .table__td>#{display cid}
$maybe Entity _ User{..} <- corrector $maybe Entity _ User{..} <- corrector
<tr .table__row> <tr .table__row>
<th .table__th> _{MsgRatingBy} <th .table__th>_{MsgRatingBy}
<td .table__td> #{display userDisplayName} <td .table__td>#{display userDisplayName}
$maybe time <- submissionRatingTime $maybe time <- submissionRatingTime
<tr .table__row> <tr .table__row>
<th .table__th> _{MsgRatingTime} <th .table__th>_{MsgRatingTime}
<td .table__td> #{display time} <td .table__td>#{display time}
$maybe points <- submissionRatingPoints $maybe points <- submissionRatingPoints
$case sheetType $case sheetType
$of Bonus{..} $of Bonus{..}
<tr .table__row> <tr .table__row>
<th .table__th> _{MsgAchievedBonusPoints} <th .table__th>_{MsgAchievedBonusPoints}
<td .table__td> _{MsgAchievedOf points maxPoints} <td .table__td>_{MsgAchievedOf points maxPoints}
$of Normal{..} $of Normal{..}
<tr .table__row> <tr .table__row>
<th .table__th> _{MsgAchievedNormalPoints} <th .table__th>_{MsgAchievedNormalPoints}
<td .table__td> _{MsgAchievedOf points maxPoints} <td .table__td>_{MsgAchievedOf points maxPoints}
$of Pass{..} $of Pass{..}
<tr .table__row> <tr .table__row>
<th .table__th> _{MsgPassedResult} <th .table__th>_{MsgPassedResult}
<td .table__td> <td .table__td>
$if points >= passingPoints $if points >= passingPoints
_{MsgPassed} _{MsgPassed}
$else $else
_{MsgNotPassed} _{MsgNotPassed}
<tr .table__row> <tr .table__row>
<th .table__th> _{MsgAchievedPassPoints} <th .table__th>_{MsgAchievedPassPoints}
<td .table__td> _{MsgPassAchievedOf points passingPoints maxPoints} <td .table__td>_{MsgPassAchievedOf points passingPoints maxPoints}
$of NotGraded $of NotGraded
$maybe comment <- ratingComment $maybe comment <- ratingComment
<tr .table__row> <tr .table__row>
<th .table__th> _{MsgRatingComment} <th .table__th>_{MsgRatingComment}
<td .table__td style="white-space: pre;"> #{comment} <td .table__td style="white-space: pre;">#{comment}