From c4c5a6b05c07686158afb8da6d7741ad6bab5c7f Mon Sep 17 00:00:00 2001 From: SJost Date: Mon, 10 Sep 2018 17:24:43 +0200 Subject: [PATCH] Profile-Data: Submissions shown --- messages/uniworx/de.msg | 1 + src/Handler/Corrections.hs | 8 +-- src/Handler/Profile.hs | 110 ++++++++++++++++++++++++++++------- src/Utils.hs | 10 +++- templates/profileData.hamlet | 10 +++- 5 files changed, 110 insertions(+), 29 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index e3576c5e4..ab2333d6d 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -127,6 +127,7 @@ SubmissionArchive: Zip-Archiv der Abgabedatei(en) SubmissionFile: Datei zur Abgabe SubmissionFiles: Abgegebene Dateien SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem bÜbungsblatt. +SubmissionEditUser: Ihre letzte Bearbeitung CorrectionsTitle: Zugewiesene Korrekturen CourseCorrectionsTitle: Korrekturen für diesen Kurs diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 5e587c624..cf548a8df 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -86,17 +86,17 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm) colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(_, _, course, _, _) } -> - let csh = course ^. _2 - tid = course ^. _3 + let tid = course ^. _3 ssh = course ^. _4 + csh = course ^. _2 in anchorCell (CourseR tid ssh csh CShowR) [whamlet|#{display csh}|] colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSheet = sortable (Just "sheet") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } -> - let csh = course ^. _2 - tid = course ^. _3 + let tid = course ^. _3 ssh = course ^. _4 + csh = course ^. _2 shn = sheetName $ entityVal sheet in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|] diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 20fd64af5..4312f138c 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -187,7 +187,7 @@ instance HasCourse a => HasCourse (DBRow a) where -- -- type CourseTableData = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant) --- NOTE: use procData instead as a flexible inlines Type signature +-- NOTE: use withType instead as a flexible inlines Type signature getProfileDataR :: Handler Html getProfileDataR = do @@ -196,9 +196,9 @@ getProfileDataR = do -- Tabelle mit eigenen Kursen ownCourseTable <- do -- TODO: only display when non-empty - let procData :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a) + let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a) - procData = id + withType = id dbTableWidget' def $ DBTable { dbtIdent = "courseOwnership" :: Text , dbtStyle = def @@ -212,27 +212,27 @@ getProfileDataR = do ) , dbtColonnade = mconcat [ colsCourseLink' $ _dbrOutput --- [ colsCourseLink $ (over each _unValue) . o_dbrOutput +-- [ colsCourseLink $ (over each _unValue) . _dbrOutput -- different types in Tupel prevents "over each" ] , dbtProj = return , dbtSorting = Map.fromList - [ ( "course", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand) - , ( "term" , SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) - , ( "school", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool ) + [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand) + , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) + , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool ) ] , dbtFilter = Map.fromList - [ ( "course", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) - , ( "term", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) - , ( "school", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) + [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) + , ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) + , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) ] } -- Tabelle mit allen Teilnehmer: Kurs (link), Datum courseTable <- do let - procData :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) + withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) - procData = id + withType = id -- should be inlined -- courseCol :: IsDBTable m a => Colonnade Sortable (DBRow (Entity Course, E.Value UTCTime)) (DBCell m a) @@ -262,15 +262,15 @@ getProfileDataR = do ] , dbtProj = return , dbtSorting = Map.fromList - [ ( "course", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName ) - , ( "term" , SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) - , ( "school", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool) + [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName ) + , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) + , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool) , ( "time" , SortColumn $ \(_ `E.InnerJoin` participant) -> participant E.^. CourseParticipantRegistration) ] , dbtFilter = Map.fromList - [ ( "course", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseName ) - , ( "term" , FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) - , ( "school", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool) + [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseName ) + , ( "term" , FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) + , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool) -- , ( "time" , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration ) ] , dbtStyle = def @@ -278,10 +278,76 @@ getProfileDataR = do -- Tabelle mit allen Abgaben und Abgabe-Gruppen submissionTable <- do - let procData :: ((_)->a) - -> ((_)->a) - procData = id - return () + let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a) + -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a) + withType = id + let validator = def -- DUPLICATED CODE: Handler.Corrections + & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information + & restrictSorting (\name _ -> name /= "corrector") + dbTableWidget' validator $ DBTable + { dbtIdent = "submissions" :: Text + , dbtStyle = def + , dbtSQLQuery = \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` subUser) -> do + E.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission + E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid + let subEdit = E.sub_select . E.from $ \subEdit -> do + E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId + E.&&. subEdit E.^. SubmissionEditUser E.==. E.val uid + return . E.max_ $ subEdit E.^. SubmissionEditTime + let crse = ( course E.^. CourseTerm + , course E.^. CourseSchool + , course E.^. CourseId + , course E.^. CourseShorthand + ) + let sht = ( sheet E.^. SheetName + ) + return (crse, sht, submission, subEdit) + , dbtColonnade = mconcat + [ colsCourseLink' $ _dbrOutput . _1 + , sortable (Just "sheet") (i18nCell MsgSheet) $ do + shn <- view $ _dbrOutput . _2 . _unValue + crse <- view $ _dbrOutput . _1 + let tid = crse ^. _1 . _unValue + ssh = crse ^. _2 . _unValue + csh = crse ^. _4 . _unValue + link= CSheetR tid ssh csh shn SShowR + return $ anchorCell link $ display2widget shn + + , sortable (toNothing "submission") (i18nCell MsgSubmission) $ do + shn <- view $ _dbrOutput . _2 . _unValue + sid <- view $ _dbrOutput . _3 . _entityKey + crse <- view $ _dbrOutput . _1 + let tid = crse ^. _1 . _unValue + ssh = crse ^. _2 . _unValue + csh = crse ^. _4 . _unValue + mkCid = encrypt (sid :: SubmissionId) -- TODO: executed twice + mkRoute = do + cid <- mkCid + return $ CSubmissionR tid ssh csh shn cid SubShowR + return $ anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) + , sortable (const Nothing $ Just "edit") (i18nCell MsgSubmissionEditUser) $ do + regTime <- view $ _dbrOutput . _4 . _unValue + return $ maybe mempty timeCell regTime + ] + , dbtProj = return + , dbtSorting = Map.fromList + [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseShorthand) + , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseTerm ) + , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseSchool ) +-- , ( "time" , error "Time Sorting not yet supported") -- TODO + , ( "sheet" , SortColumn $ withType $ \(_ `E.InnerJoin` sheet `E.InnerJoin` _ `E.InnerJoin` _) -> sheet E.^. SheetName ) + ] + , dbtFilter = Map.fromList + [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) + , ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) + , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) + ] + } + + -- Tabelle mit allen Abgabegruppen + --TODO -- Tabelle mit allen Tutorials tutorialTable <- return [whamlet| TOOD: Tutorials anzeigen |] -- TODO -- Tabelle mit allen Korrektor-Aufgaben diff --git a/src/Utils.hs b/src/Utils.hs index 7bef82270..d1beb0f31 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -113,6 +113,9 @@ str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => String -> WidgetT site m () str2widget s = [whamlet|#{s}|] +display2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, DisplayAble a) => + a -> WidgetT site m () +display2widget = text2widget . display withFragment :: ( Monad m ) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ()) @@ -228,6 +231,9 @@ toMaybe :: Bool -> a -> Maybe a toMaybe True = Just toMaybe False = const Nothing +toNothing :: a -> Maybe b +toNothing = const Nothing + maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap maybeAdd (Just x) (Just y) = Just (x + y) maybeAdd Nothing y = y @@ -296,11 +302,11 @@ catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err) ------------ shortCircuitM :: Monad m => (a -> Bool) -> m a -> m a -> (a -> a -> a) -> m a -shortCircuitM sc mx my op = do +shortCircuitM sc mx my bop = do x <- mx case sc x of True -> return x - False -> op <$> pure x <*> my + False -> bop <$> pure x <*> my guardM :: MonadPlus m => m Bool -> m () diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 6b74fb278..a74a762a3 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -24,7 +24,15 @@ ^{tutorialTable}
-

Korrekturen +

Abgaben +
+ ^{submissionTable} + Hinweis: + Bei Gruppenabgaben wird kein Datum angezeigt, + falls Sie die Gruppenabgabe nie selbst hochgeladen haben. + +
+

_{MsgCorrector}
^{correctorTable}