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

Profile-Data: Submissions shown

Browse Source
This commit is contained in:
SJost 2018-09-10 17:24:43 +02:00
parent f426739868
commit c4c5a6b05c
5 changed files with 110 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/de.msg
View File

@ -127,6 +127,7 @@ SubmissionArchive: Zip-Archiv der Abgabedatei(en)
SubmissionFile: Datei zur Abgabe SubmissionFile: Datei zur Abgabe
SubmissionFiles: Abgegebene Dateien SubmissionFiles: Abgegebene Dateien
SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem bÜbungsblatt. SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem bÜbungsblatt.
SubmissionEditUser: Ihre letzte Bearbeitung
CorrectionsTitle: Zugewiesene Korrekturen CorrectionsTitle: Zugewiesene Korrekturen
CourseCorrectionsTitle: Korrekturen für diesen Kurs CourseCorrectionsTitle: Korrekturen für diesen Kurs

8
src/Handler/Corrections.hs
View File

@ -86,17 +86,17 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm)
colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgCourse) colCourse = sortable (Just "course") (i18nCell MsgCourse)
$ \DBRow{ dbrOutput=(_, _, course, _, _) } -> $ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
let csh = course ^. _2 let tid = course ^. _3
tid = course ^. _3
ssh = course ^. _4 ssh = course ^. _4
csh = course ^. _2
in anchorCell (CourseR tid ssh csh CShowR) [whamlet|#{display csh}|] in anchorCell (CourseR tid ssh csh CShowR) [whamlet|#{display csh}|]
colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSheet = sortable (Just "sheet") (i18nCell MsgSheet) colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
$ \DBRow{ dbrOutput=(_, sheet, course, _, _) } -> $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } ->
let csh = course ^. _2 let tid = course ^. _3
tid = course ^. _3
ssh = course ^. _4 ssh = course ^. _4
csh = course ^. _2
shn = sheetName $ entityVal sheet shn = sheetName $ entityVal sheet
in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|] in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|]

110
src/Handler/Profile.hs
View File

@ -187,7 +187,7 @@ instance HasCourse a => HasCourse (DBRow a) where
-- --
-- type CourseTableData = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant) -- 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 :: Handler Html
getProfileDataR = do getProfileDataR = do
@ -196,9 +196,9 @@ getProfileDataR = do
-- Tabelle mit eigenen Kursen -- Tabelle mit eigenen Kursen
ownCourseTable <- do -- TODO: only display when non-empty 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) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a)
procData = id withType = id
dbTableWidget' def $ DBTable dbTableWidget' def $ DBTable
{ dbtIdent = "courseOwnership" :: Text { dbtIdent = "courseOwnership" :: Text
, dbtStyle = def , dbtStyle = def
@ -212,27 +212,27 @@ getProfileDataR = do
) )
, dbtColonnade = mconcat , dbtColonnade = mconcat
[ colsCourseLink' $ _dbrOutput [ colsCourseLink' $ _dbrOutput
-- [ colsCourseLink $ (over each _unValue) . o_dbrOutput -- [ colsCourseLink $ (over each _unValue) . _dbrOutput -- different types in Tupel prevents "over each"
] ]
, dbtProj = return , dbtProj = return
, dbtSorting = Map.fromList , dbtSorting = Map.fromList
[ ( "course", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand) [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand)
, ( "term" , SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm )
, ( "school", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool ) , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool )
] ]
, dbtFilter = Map.fromList , dbtFilter = Map.fromList
[ ( "course", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
, ( "term", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) , ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
, ( "school", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
] ]
} }
-- Tabelle mit allen Teilnehmer: Kurs (link), Datum -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
courseTable <- do courseTable <- do
let 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) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
procData = id withType = id
-- should be inlined -- should be inlined
-- courseCol :: IsDBTable m a => Colonnade Sortable (DBRow (Entity Course, E.Value UTCTime)) (DBCell m a) -- courseCol :: IsDBTable m a => Colonnade Sortable (DBRow (Entity Course, E.Value UTCTime)) (DBCell m a)
@ -262,15 +262,15 @@ getProfileDataR = do
] ]
, dbtProj = return , dbtProj = return
, dbtSorting = Map.fromList , dbtSorting = Map.fromList
[ ( "course", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName ) [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName )
, ( "term" , SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm )
, ( "school", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool) , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool)
, ( "time" , SortColumn $ \(_ `E.InnerJoin` participant) -> participant E.^. CourseParticipantRegistration) , ( "time" , SortColumn $ \(_ `E.InnerJoin` participant) -> participant E.^. CourseParticipantRegistration)
] ]
, dbtFilter = Map.fromList , dbtFilter = Map.fromList
[ ( "course", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseName ) [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseName )
, ( "term" , FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) , ( "term" , FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
, ( "school", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool) , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool)
-- , ( "time" , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration ) -- , ( "time" , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration )
] ]
, dbtStyle = def , dbtStyle = def
@ -278,10 +278,76 @@ getProfileDataR = do
-- Tabelle mit allen Abgaben und Abgabe-Gruppen -- Tabelle mit allen Abgaben und Abgabe-Gruppen
submissionTable <- do submissionTable <- do
let procData :: ((_)->a) 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)
-> ((_)->a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a)
procData = id withType = id
return () 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 -- Tabelle mit allen Tutorials
tutorialTable <- return [whamlet| TOOD: Tutorials anzeigen |] -- TODO tutorialTable <- return [whamlet| TOOD: Tutorials anzeigen |] -- TODO
-- Tabelle mit allen Korrektor-Aufgaben -- Tabelle mit allen Korrektor-Aufgaben

10
src/Utils.hs
View File

@ -113,6 +113,9 @@ str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
String -> WidgetT site m () String -> WidgetT site m ()
str2widget s = [whamlet|#{s}|] str2widget s = [whamlet|#{s}|]
display2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, DisplayAble a) =>
a -> WidgetT site m ()
display2widget = text2widget . display
withFragment :: ( Monad m withFragment :: ( Monad m
) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ()) ) => 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 True = Just
toMaybe False = const Nothing 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 :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap
maybeAdd (Just x) (Just y) = Just (x + y) maybeAdd (Just x) (Just y) = Just (x + y)
maybeAdd Nothing y = 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 :: 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 x <- mx
case sc x of case sc x of
True -> return x True -> return x
False -> op <$> pure x <*> my False -> bop <$> pure x <*> my
guardM :: MonadPlus m => m Bool -> m () guardM :: MonadPlus m => m Bool -> m ()

10
templates/profileData.hamlet
View File

@ -24,7 +24,15 @@
^{tutorialTable} ^{tutorialTable}
<div .container> <div .container>
<h2> Korrekturen <h2> Abgaben
<div .container>
^{submissionTable}
<em>Hinweis:
Bei Gruppenabgaben wird kein Datum angezeigt,
falls Sie die Gruppenabgabe nie selbst hochgeladen haben.
<div .container>
<h2> _{MsgCorrector}
<div .container> <div .container>
^{correctorTable} ^{correctorTable}