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

refactor(corrections-r): modernize

Browse Source
This commit is contained in:
Gregor Kleen 2021-08-17 12:46:27 +02:00
parent 153af8c6b4
commit 57ea5fe329
1 changed files with 119 additions and 125 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

244
src/Handler/Submission/List.hs
View File

@ -337,144 +337,138 @@ filterUIComment mPrev = singletonMap "comment" . maybeToList <$> aopt (lift `hoi
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) 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) => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> PSValidator m x -> DBParams m x -> DB (DBResult m x)
makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams = do makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams
let dbtSQLQuery = runReaderT $ do = let dbtSQLQuery = runReaderT $ do
course <- view queryCourse course <- view queryCourse
sheet <- view querySheet sheet <- view querySheet
submission <- view querySubmission submission <- view querySubmission
corrector <- view queryCorrector corrector <- view queryCorrector
lift $ do lift $ do
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
lastEdit <- view queryLastEdit lastEdit <- view queryLastEdit
let crse = ( course E.^. CourseName let crse = ( course E.^. CourseName
, course E.^. CourseShorthand , course E.^. CourseShorthand
, course E.^. CourseTerm , course E.^. CourseTerm
, course E.^. CourseSchool , course E.^. CourseSchool
) )
lift . E.where_ =<< whereClause lift . E.where_ =<< whereClause
return (submission, sheet, crse, corrector, lastEdit) return (submission, sheet, crse, corrector, lastEdit)
dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do 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 (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 cid <- encrypt sId
forMM_ (view $ _dbtProjFilter . _corrProjFilterSubmission) $ \criteria -> forMM_ (view $ _dbtProjFilter . _corrProjFilterSubmission) $ \criteria ->
let haystack = map CI.mk . unpack $ toPathPiece cid let haystack = map CI.mk . unpack $ toPathPiece cid
in guard $ any (`isInfixOf` haystack) criteria in guard $ any (`isInfixOf` haystack) criteria
submittors <- lift . lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do 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.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId)
E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId) E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId)
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId
E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName] E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
let submissionGroup' = E.subSelectMaybe . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do let submissionGroup' = E.subSelectMaybe . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId
return . E.just $ submissionGroup E.^. SubmissionGroupName return . E.just $ submissionGroup E.^. SubmissionGroupName
return (user, pseudonym E.?. SheetPseudonymPseudonym, submissionGroup') return (user, pseudonym E.?. SheetPseudonymPseudonym, submissionGroup')
let let
submittorMap = List.foldr (\(Entity userId user, E.Value pseudo, E.Value sGroup) -> Map.insert userId (user, pseudo, sGroup)) Map.empty submittors 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 -> forMM_ (view $ _dbtProjFilter . _corrProjFilterPseudonym) $ \criteria ->
let haystacks = setOf (folded . resultUserPseudonym . re _PseudonymText . to (map CI.mk . unpack)) submittorMap let haystacks = setOf (folded . resultUserPseudonym . re _PseudonymText . to (map CI.mk . unpack)) submittorMap
in guard $ any (\haystack -> any (`isInfixOf` haystack) criteria) haystacks in guard $ any (\haystack -> any (`isInfixOf` haystack) criteria) haystacks
nonAnonymousAccess <- lift . lift $ or2M nonAnonymousAccess <- lift . lift $ or2M
(return $ not sheetAnonymousCorrection) (return $ not sheetAnonymousCorrection)
(hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR) (hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR)
return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess) return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess)
dbtRowKey = views querySubmission (E.^. SubmissionId) dbtRowKey = views querySubmission (E.^. SubmissionId)
dbTable psValidator DBTable dbtSorting = mconcat
{ dbtSQLQuery [ singletonMap "term" . SortColumn $ views queryCourse (E.^. CourseTerm)
, dbtRowKey , singletonMap "school" . SortColumn $ views queryCourse (E.^. CourseSchool)
, dbtColonnade , singletonMap "course" . SortColumn $ views queryCourse (E.^. CourseShorthand)
, dbtProj , singletonMap "sheet" . SortColumn $ views querySheet (E.^. SheetName)
, dbtSorting = mconcat , singletonMap "corrector" . SortColumns $ \x ->
[ singletonMap "term" . SortColumn $ views queryCourse (E.^. CourseTerm) [ SomeExprValue (views queryCorrector (E.?. UserSurname) x)
, singletonMap "school" . SortColumn $ views queryCourse (E.^. CourseSchool) , SomeExprValue (views queryCorrector (E.?. UserDisplayName) x)
, singletonMap "course" . SortColumn $ views queryCourse (E.^. CourseShorthand) ]
, singletonMap "sheet" . SortColumn $ views querySheet (E.^. SheetName) , singletonMap "rating" . SortColumn $ views querySubmission (E.^. SubmissionRatingPoints)
, singletonMap "corrector" . SortColumns $ \x -> , singletonMap "sheet-type" . SortColumns $ \(view querySheet -> sheet) ->
[ SomeExprValue (views queryCorrector (E.?. UserSurname) x) [ SomeExprValue ((sheet E.^. SheetType) E.->. "type" :: E.SqlExpr (E.Value Value))
, SomeExprValue (views queryCorrector (E.?. UserDisplayName) x) , 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) dbtFilter = mconcat
, singletonMap "sheet-type" . SortColumns $ \(view querySheet -> sheet) -> [ singletonMap "term" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseTerm)
[ SomeExprValue ((sheet E.^. SheetType) E.->. "type" :: E.SqlExpr (E.Value Value)) , singletonMap "school" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseSchool)
, SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "max" :: E.SqlExpr (E.Value Value)) , singletonMap "course" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseShorthand)
, SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "passing" :: E.SqlExpr (E.Value Value)) , 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) dbtFilterUI = fromMaybe mempty dbtFilterUI'
, singletonMap "ratingtime" . SortColumn $ views querySubmission (E.^. SubmissionRatingTime) dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI' }
, singletonMap "assignedtime" . SortColumn $ views querySubmission (E.^. SubmissionRatingAssigned) dbtIdent = "corrections" :: Text
, singletonMap "submittors" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) x dbtCsvEncode = noCsvEncode
, singletonMap "submittors-matriculation" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserUser . _userMatrikelnummer . _Just) x dbtCsvDecode = Nothing
, singletonMap "submittors-group" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserSubmissionGroup) x dbtExtraReps = []
, singletonMap "submittors-pseudonyms" . SortProjected . comparing $ \x -> setOf (resultSubmittors . resultUserPseudonym . re _PseudonymText) x in dbTable psValidator DBTable{..}
, 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 = []
}
data ActionCorrections = CorrDownload data ActionCorrections = CorrDownload
| CorrSetCorrector | CorrSetCorrector