From 57ea5fe329e3013bff83fffb2f8ad999cf9f5b6f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 17 Aug 2021 12:46:27 +0200 Subject: [PATCH] refactor(corrections-r): modernize --- src/Handler/Submission/List.hs | 244 ++++++++++++++++----------------- 1 file changed, 119 insertions(+), 125 deletions(-) diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index 72bce9202..a9959fdd1 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -337,144 +337,138 @@ filterUIComment mPrev = singletonMap "comment" . maybeToList <$> aopt (lift `hoi makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> PSValidator m x -> DBParams m x -> DB (DBResult m x) -makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams = do - let dbtSQLQuery = runReaderT $ do - course <- view queryCourse - sheet <- view querySheet - submission <- view querySubmission - corrector <- view queryCorrector +makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams + = let dbtSQLQuery = runReaderT $ do + course <- view queryCourse + sheet <- view querySheet + submission <- view querySubmission + corrector <- view queryCorrector - lift $ 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 + lift $ 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 - lastEdit <- view queryLastEdit + lastEdit <- view queryLastEdit - let crse = ( course E.^. CourseName - , course E.^. CourseShorthand - , course E.^. CourseTerm - , course E.^. CourseSchool - ) + let crse = ( course E.^. CourseName + , course E.^. CourseShorthand + , course E.^. CourseTerm + , course E.^. CourseSchool + ) - lift . E.where_ =<< whereClause + lift . E.where_ =<< whereClause - return (submission, sheet, crse, corrector, lastEdit) - dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do - (submission@(Entity sId _), sheet@(Entity shId Sheet{..}), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) <- view $ _dbtProjRow . _dbrOutput + return (submission, sheet, crse, corrector, lastEdit) + dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do + (submission@(Entity sId _), sheet@(Entity shId Sheet{..}), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) <- view $ _dbtProjRow . _dbrOutput - cid <- encrypt sId - forMM_ (view $ _dbtProjFilter . _corrProjFilterSubmission) $ \criteria -> - let haystack = map CI.mk . unpack $ toPathPiece cid - in guard $ any (`isInfixOf` haystack) criteria + cid <- encrypt sId + forMM_ (view $ _dbtProjFilter . _corrProjFilterSubmission) $ \criteria -> + let haystack = map CI.mk . unpack $ toPathPiece cid + in guard $ any (`isInfixOf` haystack) criteria - submittors <- lift . lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do - E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId) - E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId) - E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId - E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId - E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName] - let submissionGroup' = E.subSelectMaybe . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do - E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup - E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse - E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId - return . E.just $ submissionGroup E.^. SubmissionGroupName + submittors <- lift . lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do + E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId) + E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId) + E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId + E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId + E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName] + let submissionGroup' = E.subSelectMaybe . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do + E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup + E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse + E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId + return . E.just $ submissionGroup E.^. SubmissionGroupName - return (user, pseudonym E.?. SheetPseudonymPseudonym, submissionGroup') - let - submittorMap = List.foldr (\(Entity userId user, E.Value pseudo, E.Value sGroup) -> Map.insert userId (user, pseudo, sGroup)) Map.empty submittors + return (user, pseudonym E.?. SheetPseudonymPseudonym, submissionGroup') + let + submittorMap = List.foldr (\(Entity userId user, E.Value pseudo, E.Value sGroup) -> Map.insert userId (user, pseudo, sGroup)) Map.empty submittors - forMM_ (view $ _dbtProjFilter . _corrProjFilterPseudonym) $ \criteria -> - let haystacks = setOf (folded . resultUserPseudonym . re _PseudonymText . to (map CI.mk . unpack)) submittorMap - in guard $ any (\haystack -> any (`isInfixOf` haystack) criteria) haystacks + forMM_ (view $ _dbtProjFilter . _corrProjFilterPseudonym) $ \criteria -> + let haystacks = setOf (folded . resultUserPseudonym . re _PseudonymText . to (map CI.mk . unpack)) submittorMap + in guard $ any (\haystack -> any (`isInfixOf` haystack) criteria) haystacks - nonAnonymousAccess <- lift . lift $ or2M - (return $ not sheetAnonymousCorrection) - (hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR) + nonAnonymousAccess <- lift . lift $ or2M + (return $ not sheetAnonymousCorrection) + (hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR) - return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess) - dbtRowKey = views querySubmission (E.^. SubmissionId) - dbTable psValidator DBTable - { dbtSQLQuery - , dbtRowKey - , dbtColonnade - , dbtProj - , dbtSorting = mconcat - [ singletonMap "term" . SortColumn $ views queryCourse (E.^. CourseTerm) - , singletonMap "school" . SortColumn $ views queryCourse (E.^. CourseSchool) - , singletonMap "course" . SortColumn $ views queryCourse (E.^. CourseShorthand) - , singletonMap "sheet" . SortColumn $ views querySheet (E.^. SheetName) - , singletonMap "corrector" . SortColumns $ \x -> - [ SomeExprValue (views queryCorrector (E.?. UserSurname) x) - , SomeExprValue (views queryCorrector (E.?. UserDisplayName) x) + return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess) + dbtRowKey = views querySubmission (E.^. SubmissionId) + dbtSorting = mconcat + [ singletonMap "term" . SortColumn $ views queryCourse (E.^. CourseTerm) + , singletonMap "school" . SortColumn $ views queryCourse (E.^. CourseSchool) + , singletonMap "course" . SortColumn $ views queryCourse (E.^. CourseShorthand) + , singletonMap "sheet" . SortColumn $ views querySheet (E.^. SheetName) + , singletonMap "corrector" . SortColumns $ \x -> + [ SomeExprValue (views queryCorrector (E.?. UserSurname) x) + , SomeExprValue (views queryCorrector (E.?. UserDisplayName) x) + ] + , singletonMap "rating" . SortColumn $ views querySubmission (E.^. SubmissionRatingPoints) + , singletonMap "sheet-type" . SortColumns $ \(view querySheet -> sheet) -> + [ SomeExprValue ((sheet E.^. SheetType) E.->. "type" :: E.SqlExpr (E.Value Value)) + , SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "max" :: E.SqlExpr (E.Value Value)) + , SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "passing" :: E.SqlExpr (E.Value Value)) + ] + , singletonMap "israted" . SortColumn $ views querySubmission $ E.not_ . E.isNothing . (E.^. SubmissionRatingTime) + , singletonMap "ratingtime" . SortColumn $ views querySubmission (E.^. SubmissionRatingTime) + , singletonMap "assignedtime" . SortColumn $ views querySubmission (E.^. SubmissionRatingAssigned) + , singletonMap "submittors" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) x + , singletonMap "submittors-matriculation" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserUser . _userMatrikelnummer . _Just) x + , singletonMap "submittors-group" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserSubmissionGroup) x + , singletonMap "submittors-pseudonyms" . SortProjected . comparing $ \x -> setOf (resultSubmittors . resultUserPseudonym . re _PseudonymText) x + , singletonMap "comment" . SortColumn $ views querySubmission (E.^. SubmissionRatingComment) -- sorting by comment specifically requested by correctors to easily see submissions to be done + , singletonMap "last-edit" . SortColumn $ view queryLastEdit + , singletonMap "submission" . SortProjected . comparing $ toPathPiece . view resultCryptoID ] - , singletonMap "rating" . SortColumn $ views querySubmission (E.^. SubmissionRatingPoints) - , singletonMap "sheet-type" . SortColumns $ \(view querySheet -> sheet) -> - [ SomeExprValue ((sheet E.^. SheetType) E.->. "type" :: E.SqlExpr (E.Value Value)) - , SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "max" :: E.SqlExpr (E.Value Value)) - , SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "passing" :: E.SqlExpr (E.Value Value)) + dbtFilter = mconcat + [ singletonMap "term" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseTerm) + , singletonMap "school" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseSchool) + , singletonMap "course" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseShorthand) + , singletonMap "sheet" . FilterColumn . E.mkExactFilter $ views querySheet (E.^. SheetName) + , singletonMap "sheet-search" . FilterColumn . E.mkContainsFilter $ views querySheet (E.^. SheetName) + , singletonMap "corrector" . FilterColumn . E.mkExactFilterWith Just $ views queryCorrector (E.?. UserIdent) + , singletonMap "isassigned" . FilterColumn . E.mkExactFilterLast $ views querySubmission (E.isJust . (E.^. SubmissionRatingBy)) + , singletonMap "israted" . FilterColumn . E.mkExactFilterLast $ views querySubmission sqlSubmissionRatingDone + , singletonMap "corrector-name-email" . FilterColumn $ E.anyFilter + [ E.mkContainsFilterWith Just $ views queryCorrector (E.?. UserSurname) + , E.mkContainsFilterWith Just $ views queryCorrector (E.?. UserDisplayName) + , E.mkContainsFilterWith (Just . CI.mk) $ views queryCorrector (E.?. UserEmail) + , E.mkContainsFilterWith (Just . CI.mk) $ views queryCorrector (E.?. UserIdent) + , E.mkContainsFilterWith (Just . CI.mk) $ views queryCorrector (E.?. UserDisplayEmail) + ] + , singletonMap "user-name-email" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do + E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId + E.where_ $ dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission + E.where_ $ E.anyFilter + [ E.mkContainsFilter (E.^. UserSurname) + , E.mkContainsFilter (E.^. UserDisplayName) + , E.mkContainsFilterWith CI.mk (E.^. UserEmail) + , E.mkContainsFilterWith CI.mk (E.^. UserIdent) + , E.mkContainsFilterWith CI.mk (E.^. UserDisplayEmail) + ] user (Set.singleton needle) + , singletonMap "user-matriclenumber" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do + E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId + E.where_ $ dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission + E.where_ $ E.mkContainsFilterWith Just (E.^. UserMatrikelnummer) user (Set.singleton needle) + , singletonMap "submission-group" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser `E.InnerJoin` submissionUser) -> do + E.on $ submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser E.^. SubmissionGroupUserUser + E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup + E.where_ $ (row ^. queryCourse) E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse + E.&&. dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission + E.where_ $ E.mkContainsFilter (E.^. SubmissionGroupName) submissionGroup (Set.singleton needle) + , singletonMap "rating-visible" . FilterColumn . E.mkExactFilterLast $ views querySubmission sqlSubmissionRatingDone -- TODO: Identical with israted? + , singletonMap "rating" . FilterColumn . E.mkExactFilterWith Just $ views querySubmission (E.^. SubmissionRatingPoints) + , singletonMap "comment" . FilterColumn . E.mkContainsFilterWith Just $ views querySubmission (E.^. SubmissionRatingComment) + , singletonMap "submission" $ FilterProjected (_corrProjFilterSubmission ?~) + , singletonMap "pseudonym" $ FilterProjected (_corrProjFilterPseudonym ?~) ] - , singletonMap "israted" . SortColumn $ views querySubmission $ E.not_ . E.isNothing . (E.^. SubmissionRatingTime) - , singletonMap "ratingtime" . SortColumn $ views querySubmission (E.^. SubmissionRatingTime) - , singletonMap "assignedtime" . SortColumn $ views querySubmission (E.^. SubmissionRatingAssigned) - , singletonMap "submittors" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) x - , singletonMap "submittors-matriculation" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserUser . _userMatrikelnummer . _Just) x - , singletonMap "submittors-group" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserSubmissionGroup) x - , singletonMap "submittors-pseudonyms" . SortProjected . comparing $ \x -> setOf (resultSubmittors . resultUserPseudonym . re _PseudonymText) x - , singletonMap "comment" . SortColumn $ views querySubmission (E.^. SubmissionRatingComment) -- sorting by comment specifically requested by correctors to easily see submissions to be done - , singletonMap "last-edit" . SortColumn $ view queryLastEdit - , singletonMap "submission" . SortProjected . comparing $ toPathPiece . view resultCryptoID - ] - , dbtFilter = mconcat - [ singletonMap "term" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseTerm) - , singletonMap "school" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseSchool) - , singletonMap "course" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseShorthand) - , singletonMap "sheet" . FilterColumn . E.mkExactFilter $ views querySheet (E.^. SheetName) - , singletonMap "sheet-search" . FilterColumn . E.mkContainsFilter $ views querySheet (E.^. SheetName) - , singletonMap "corrector" . FilterColumn . E.mkExactFilterWith Just $ views queryCorrector (E.?. UserIdent) - , singletonMap "isassigned" . FilterColumn . E.mkExactFilterLast $ views querySubmission (E.isJust . (E.^. SubmissionRatingBy)) - , singletonMap "israted" . FilterColumn . E.mkExactFilterLast $ views querySubmission sqlSubmissionRatingDone - , singletonMap "corrector-name-email" . FilterColumn $ E.anyFilter - [ E.mkContainsFilterWith Just $ views queryCorrector (E.?. UserSurname) - , E.mkContainsFilterWith Just $ views queryCorrector (E.?. UserDisplayName) - , E.mkContainsFilterWith (Just . CI.mk) $ views queryCorrector (E.?. UserEmail) - , E.mkContainsFilterWith (Just . CI.mk) $ views queryCorrector (E.?. UserIdent) - , E.mkContainsFilterWith (Just . CI.mk) $ views queryCorrector (E.?. UserDisplayEmail) - ] - , singletonMap "user-name-email" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do - E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId - E.where_ $ dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission - E.where_ $ E.anyFilter - [ E.mkContainsFilter (E.^. UserSurname) - , E.mkContainsFilter (E.^. UserDisplayName) - , E.mkContainsFilterWith CI.mk (E.^. UserEmail) - , E.mkContainsFilterWith CI.mk (E.^. UserIdent) - , E.mkContainsFilterWith CI.mk (E.^. UserDisplayEmail) - ] user (Set.singleton needle) - , singletonMap "user-matriclenumber" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do - E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId - E.where_ $ dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission - E.where_ $ E.mkContainsFilterWith Just (E.^. UserMatrikelnummer) user (Set.singleton needle) - , singletonMap "submission-group" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser `E.InnerJoin` submissionUser) -> do - E.on $ submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser E.^. SubmissionGroupUserUser - E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup - E.where_ $ (row ^. queryCourse) E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse - E.&&. dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission - E.where_ $ E.mkContainsFilter (E.^. SubmissionGroupName) submissionGroup (Set.singleton needle) - , singletonMap "rating-visible" . FilterColumn . E.mkExactFilterLast $ views querySubmission sqlSubmissionRatingDone -- TODO: Identical with israted? - , singletonMap "rating" . FilterColumn . E.mkExactFilterWith Just $ views querySubmission (E.^. SubmissionRatingPoints) - , singletonMap "comment" . FilterColumn . E.mkContainsFilterWith Just $ views querySubmission (E.^. SubmissionRatingComment) - , singletonMap "submission" $ FilterProjected (_corrProjFilterSubmission ?~) - , singletonMap "pseudonym" $ FilterProjected (_corrProjFilterPseudonym ?~) - ] - , dbtFilterUI = fromMaybe mempty dbtFilterUI - , dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI } - , dbtParams - , dbtIdent = "corrections" :: Text - , dbtCsvEncode = noCsvEncode - , dbtCsvDecode = Nothing - , dbtExtraReps = [] - } + dbtFilterUI = fromMaybe mempty dbtFilterUI' + dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI' } + dbtIdent = "corrections" :: Text + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + in dbTable psValidator DBTable{..} data ActionCorrections = CorrDownload | CorrSetCorrector