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

Summary shown for all submission, but mislabelled

Browse Source
This commit is contained in:
SJost 2018-11-28 12:01:14 +01:00
parent dbb69e1817
commit fed70610f0
5 changed files with 69 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
src/Handler/Corrections.hs
View File

@ -56,25 +56,33 @@ import Data.Foldable (foldrM)
type CorrectionsWhere = forall query expr backend . (E.Esqueleto query expr backend) => type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
(expr (Entity Course), expr (Entity Sheet), expr (Entity Submission)) type CorrectionTableWhere = CorrectionTableExpr -> E.SqlExpr (E.Value Bool)
-> expr (E.Value Bool)
ratedBy :: Key User -> CorrectionsWhere
ratedBy uid (_course,_sheet,submission) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
courseIs :: Key Course -> CorrectionsWhere
courseIs cid (course,_sheet,_submission) = course E.^. CourseId E.==. E.val cid
sheetIs :: Key Sheet -> CorrectionsWhere
sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid
submissionModeIs :: SheetSubmissionMode -> CorrectionsWhere
submissionModeIs sMode (_course, sheet, _submission) = sheet E.^. SheetSubmissionMode E.==. E.val sMode
type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId (User, Maybe Pseudonym)) type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId (User, Maybe Pseudonym))
correctionsTableQuery :: CorrectionTableWhere -> (CorrectionTableExpr -> v) -> CorrectionTableExpr -> E.SqlQuery v
correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ whereClause t
return $ returnStatement t
-- Where Clauses
ratedBy :: UserId -> CorrectionTableWhere
ratedBy uid ((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
courseIs :: CourseId -> CorrectionTableWhere
courseIs cid (( course `E.InnerJoin` _sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = course E.^. CourseId E.==. E.val cid
sheetIs :: Key Sheet -> CorrectionTableWhere
sheetIs shid ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetId E.==. E.val shid
submissionModeIs :: SheetSubmissionMode -> CorrectionTableWhere
submissionModeIs sMode ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetSubmissionMode E.==. E.val sMode
-- Columns
colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colTerm = sortable (Just "term") (i18nCell MsgTerm) colTerm = sortable (Just "term") (i18nCell MsgTerm)
$ \DBRow{ dbrOutput=(_, _, course, _, _) } -> $ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
@ -176,23 +184,19 @@ colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell
(\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment)) (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment))
type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
=> _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (DBResult m x) => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (DBResult m x)
makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _ let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do dbtSQLQuery = correctionsTableQuery whereClause
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy (\((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) ->
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet let crse = ( course E.^. CourseName :: E.SqlExpr (E.Value CourseName)
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse , course E.^. CourseShorthand
E.where_ $ whereClause (course,sheet,submission) , course E.^. CourseTerm
let crse = ( course E.^. CourseName :: E.SqlExpr (E.Value CourseName) , course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId)
, course E.^. CourseShorthand )
, course E.^. CourseTerm in (submission, sheet, crse, corrector)
, course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId) )
)
return (submission, sheet, crse, corrector)
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData
dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do
submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
@ -356,9 +360,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr) addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
redirect currentRoute redirect currentRoute
SheetTypeSummary{..} <- runDB $ do
let getTypePoints ((_course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = (sheet E.^. SheetType, submission E.^. SubmissionRatingPoints, submission E.^. SubmissionRatingTime)
points <- E.select . E.from $ correctionsTableQuery whereClause getTypePoints
-- points <- E.select . E.from $ t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> (correctionsTableQuery whereClause getTypePoints t) <* E.distinctOn []
return $ foldMap (\(E.Value stype, E.Value srpoints, E.Value srtime) -> sheetTypeSum stype (srpoints <* srtime)) points
let statistics = $(widgetFile "widgets/sheetTypeSummary")
fmap toTypedContent . defaultLayout $ do fmap toTypedContent . defaultLayout $ do
setTitleI MsgCourseCorrectionsTitle setTitleI MsgCourseCorrectionsTitle
$(widgetFile "corrections") $(widgetFile "corrections")
where where
authorizedToAssign :: SubmissionId -> DB Bool authorizedToAssign :: SubmissionId -> DB Bool
authorizedToAssign sId = do authorizedToAssign sId = do
@ -639,7 +650,7 @@ postCorrectionsCreateR = do
FormFailure errs -> forM_ errs $ addMessage Error . toHtml FormFailure errs -> forM_ errs $ addMessage Error . toHtml
FormSuccess (sid, (pss, invalids)) -> do FormSuccess (sid, (pss, invalids)) -> do
forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Warning "templates/messages/ignoredInvalidPseudonym.hamlet") forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Warning "templates/messages/ignoredInvalidPseudonym.hamlet")
runDB $ do runDB $ do
Sheet{..} <- get404 sid Sheet{..} <- get404 sid
(sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p) (sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)

18
src/Handler/Sheet.hs
View File

@ -62,7 +62,7 @@ data SheetForm = SheetForm
{ sfName :: SheetName { sfName :: SheetName
, sfDescription :: Maybe Html , sfDescription :: Maybe Html
, sfType :: SheetType , sfType :: SheetType
, sfGrouping :: SheetGroup , sfGrouping :: SheetGroup
, sfVisibleFrom :: Maybe UTCTime , sfVisibleFrom :: Maybe UTCTime
, sfActiveFrom :: UTCTime , sfActiveFrom :: UTCTime
, sfActiveTo :: UTCTime , sfActiveTo :: UTCTime
@ -98,7 +98,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
<*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template) <*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
<*> sheetTypeAFormReq (fslI MsgSheetType <*> sheetTypeAFormReq (fslI MsgSheetType
& setTooltip MsgSheetTypeInfo) (sfType <$> template) & setTooltip MsgSheetTypeInfo) (sfType <$> template)
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template) <*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
<*> aopt utcTimeField (fslI MsgSheetVisibleFrom <*> aopt utcTimeField (fslI MsgSheetVisibleFrom
& setTooltip MsgSheetVisibleFromTip) & setTooltip MsgSheetVisibleFromTip)
((sfVisibleFrom <$> template) <|> pure (Just ctime)) ((sfVisibleFrom <$> template) <|> pure (Just ctime))
@ -118,7 +118,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
<*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template) <*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
<*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarking <*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarking
& setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template) & setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template) <*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
<* submitButton <* submitButton
return $ case result of return $ case result of
FormSuccess sheetResult FormSuccess sheetResult
@ -137,7 +137,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
] ] ] ]
getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetListR tid ssh csh = do getSheetListR tid ssh csh = do
muid <- maybeAuthId muid <- maybeAuthId
Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
let let
@ -180,7 +180,7 @@ getSheetListR tid ssh csh = do
cid' <- mkCid cid' <- mkCid
return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
in anchorCellM mkRoute $(widgetFile "widgets/rating") in anchorCellM mkRoute $(widgetFile "widgets/rating")
, sortable Nothing -- (Just "percent") , sortable Nothing -- (Just "percent")
(i18nCell MsgRatingPercent) (i18nCell MsgRatingPercent)
$ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of $ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of
(Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) -> (Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) ->
@ -188,7 +188,7 @@ getSheetListR tid ssh csh = do
Just maxPoints Just maxPoints
| maxPoints /= 0 -> | maxPoints /= 0 ->
let percent = sPoints / maxPoints let percent = sPoints / maxPoints
in textCell $ textPercent $ realToFrac percent in textCell $ textPercent $ realToFrac percent
_other -> mempty _other -> mempty
_other -> mempty _other -> mempty
] ]
@ -236,9 +236,9 @@ getSheetListR tid ssh csh = do
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
return (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints) return (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints)
return $ foldMap (\(E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) rows return $ foldMap (\(E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) rows
let statistics = $(widgetFile "widgets/sheetTypeSummary")
defaultLayout $ do defaultLayout $ do
$(widgetFile "sheetList") $(widgetFile "sheetList")
$(widgetFile "widgets/sheetTypeSummary")
data ButtonGeneratePseudonym = BtnGenerate data ButtonGeneratePseudonym = BtnGenerate
deriving (Enum, Eq, Ord, Bounded, Read, Show) deriving (Enum, Eq, Ord, Bounded, Read, Show)
@ -398,7 +398,7 @@ getSheetNewR tid ssh csh = do
{ sfName = stepTextCounterCI sheetName { sfName = stepTextCounterCI sheetName
, sfDescription = sheetDescription , sfDescription = sheetDescription
, sfType = sheetType , sfType = sheetType
, sfGrouping = sheetGrouping , sfGrouping = sheetGrouping
, sfVisibleFrom = addOneWeek <$> sheetVisibleFrom , sfVisibleFrom = addOneWeek <$> sheetVisibleFrom
, sfActiveFrom = addOneWeek sheetActiveFrom , sfActiveFrom = addOneWeek sheetActiveFrom
, sfActiveTo = addOneWeek sheetActiveTo , sfActiveTo = addOneWeek sheetActiveTo
@ -431,7 +431,7 @@ getSEditR tid ssh csh shn = do
{ 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

4
templates/corrections.hamlet
View File

@ -1,5 +1,7 @@
<div .container> <section>
<form method=POST enctype=#{tableEncoding} action=@{currentRoute}> <form method=POST enctype=#{tableEncoding} action=@{currentRoute}>
^{table} ^{table}
<button type=submit> <button type=submit>
_{MsgBtnSubmit} _{MsgBtnSubmit}
<section>
^{statistics}

5
templates/sheetList.hamlet
View File

@ -1 +1,4 @@
^{table} <section>
^{table}
<section>
^{statistics}

21
templates/widgets/sheetTypeSummary.hamlet
View File

@ -1,9 +1,8 @@
$with realGrades <- normalSummary <> bonusSummary $with realGrades <- normalSummary <> bonusSummary
$# $with allGrades <- realGrades <> informationalSummary $# $with allGrades <- realGrades <> informationalSummary
<div> <div>
<ul> $maybe realPoints <- positiveSum (sumGradePoints realGrades)
$maybe realPoints <- positiveSum (sumGradePoints realGrades) <p>
<li>
Gesamtpunktzahl #{display realPoints} Gesamtpunktzahl #{display realPoints}
$maybe nPts <- getSum <$> achievedPoints realGrades $maybe nPts <- getSum <$> achievedPoints realGrades
\ davon #{display nPts} erreicht \ davon #{display nPts} erreicht
@ -13,21 +12,21 @@ $with realGrades <- normalSummary <> bonusSummary
von #{display achievedBonus} erreichbaren # von #{display achievedBonus} erreichbaren #
Bonuspunkten) Bonuspunkten)
$if realPoints /= 0 $if realPoints /= 0
\ #{textPercent $ realToFrac $ nPts / realPoints} \ #{textPercent $ realToFrac $ nPts / realPoints}
\. \.
$maybe fakePoints <- positiveSum (sumGradePoints informationalSummary) $maybe fakePoints <- positiveSum (sumGradePoints informationalSummary)
<li> <p>
<em>Hinweis: <em>Hinweis:
\ #{display fakePoints} Punkte gab es für Aufgabenblätter, # \ #{display fakePoints} Punkte gab es für Aufgabenblätter, #
welche nicht gewertet wurden, sondern nur informativen Charakter besitzen welche nicht gewertet wurden, sondern nur informativen Charakter besitzen
$maybe achievedFakes <- getSum <$> achievedPoints informationalSummary $maybe achievedFakes <- getSum <$> achievedPoints informationalSummary
, davon wurden #{display achievedFakes} erreicht , davon wurden #{display achievedFakes} erreicht
$if fakePoints /= 0 $if fakePoints /= 0
\ #{textPercent $ realToFrac $ achievedFakes / fakePoints} \ #{textPercent $ realToFrac $ achievedFakes / fakePoints}
\. \.
$maybe reqPasses <- positiveSum (numGradePasses normalSummary) $maybe reqPasses <- positiveSum (numGradePasses normalSummary)
<li> <p>
Aufgaben zum Bestehen: #{display reqPasses} Aufgaben zum Bestehen: #{display reqPasses}
$maybe passed <- getSum <$> achievedPasses realGrades $maybe passed <- getSum <$> achievedPasses realGrades
\ davon #{display passed} bestanden \ davon #{display passed} bestanden
@ -36,6 +35,6 @@ $with realGrades <- normalSummary <> bonusSummary
\. \.
$maybe noGradeSheets <- positiveSum numNotGraded $maybe noGradeSheets <- positiveSum numNotGraded
<li> <p>
#{display noGradeSheets} unbewertete Aufgabenblätter. #{display noGradeSheets} unbewertete Aufgabenblätter.