{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} module Handler.Submission.List ( getCorrectionsR, postCorrectionsR , getCCorrectionsR, postCCorrectionsR , getSSubsR, postSSubsR , correctionsR' , restrictAnonymous, restrictCorrector , ratedBy, courseIs, sheetIs, userIs , colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit, colSGroups , filterUICourse, filterUITerm, filterUISchool, filterUISheetSearch, filterUIIsRated, filterUISubmission, filterUIUserNameEmail, filterUIUserMatrikelnummer, filterUICorrectorNameEmail, filterUIIsAssigned, filterUISubmissionGroup, filterUIRating, filterUIComment, filterUIPseudonym , makeCorrectionsTable , CorrectionTableData, CorrectionTableWhere , ActionCorrections(..), downloadAction, deleteAction, assignAction, autoAssignAction ) where import Import hiding (link) import Handler.Utils hiding (colSchool) import Handler.Utils.Submission import Handler.Utils.SheetType import Handler.Utils.Delete import Data.List as List (foldr) import qualified Data.Set as Set import qualified Data.Map.Strict as Map import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI import Database.Esqueleto.Utils.TH import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Text.Hamlet (ihamletFile) import Database.Persist.Sql (updateWhereCount) import Data.List (genericLength) data CorrectionTableFilterProj = CorrectionTableFilterProj { corrProjFilterSubmission :: Maybe (Set [CI Char]) , corrProjFilterPseudonym :: Maybe (Set [CI Char]) } instance Default CorrectionTableFilterProj where def = CorrectionTableFilterProj { corrProjFilterSubmission = Nothing , corrProjFilterPseudonym = Nothing } makeLenses_ ''CorrectionTableFilterProj 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)) type CorrectionTableWhere = forall m. MonadReader CorrectionTableExpr m => m (E.SqlExpr (E.Value Bool)) type CorrectionTableCourseData = (CourseName, CourseShorthand, TermId, SchoolId) type CorrectionTableUserData = (User, Maybe Pseudonym, Maybe SubmissionGroupName) type CorrectionTableData = DBRow ( Entity Submission , Entity Sheet , CorrectionTableCourseData , Maybe (Entity User) , Maybe UTCTime , Map UserId CorrectionTableUserData , CryptoFileNameSubmission , Bool {- Access to non-anonymous submission data -} ) queryCourse :: Getter CorrectionTableExpr (E.SqlExpr (Entity Course)) queryCourse = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 2 1) querySheet :: Getter CorrectionTableExpr (E.SqlExpr (Entity Sheet)) querySheet = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 2 1) querySubmission :: Getter CorrectionTableExpr (E.SqlExpr (Entity Submission)) querySubmission = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 2 1) queryCorrector :: Getter CorrectionTableExpr (E.SqlExpr (Maybe (Entity User))) queryCorrector = to $(sqlLOJproj 2 2) queryLastEdit :: Getter CorrectionTableExpr (E.SqlExpr (E.Value (Maybe UTCTime))) queryLastEdit = querySubmission . submissionLastEdit where submissionLastEdit = to $ \submission -> E.subSelectMaybe . E.from $ \edit -> do E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId return $ E.max_ $ edit E.^. SubmissionEditTime resultSubmission :: Lens' CorrectionTableData (Entity Submission) resultSubmission = _dbrOutput . _1 resultSheet :: Lens' CorrectionTableData (Entity Sheet) resultSheet = _dbrOutput . _2 resultCourseName :: Lens' CorrectionTableData CourseName resultCourseName = _dbrOutput . _3 . _1 resultCourseShorthand :: Lens' CorrectionTableData CourseShorthand resultCourseShorthand = _dbrOutput . _3 . _2 resultCourseTerm :: Lens' CorrectionTableData TermId resultCourseTerm = _dbrOutput . _3 . _3 resultCourseSchool :: Lens' CorrectionTableData SchoolId resultCourseSchool = _dbrOutput . _3 . _4 resultCorrector :: Traversal' CorrectionTableData (Entity User) resultCorrector = _dbrOutput . _4 . _Just resultLastEdit :: Traversal' CorrectionTableData UTCTime resultLastEdit = _dbrOutput . _5 . _Just resultSubmittors :: IndexedTraversal' UserId CorrectionTableData CorrectionTableUserData resultSubmittors = _dbrOutput . _6 . itraversed resultUserUser :: Lens' CorrectionTableUserData User resultUserUser = _1 resultUserPseudonym :: Traversal' CorrectionTableUserData Pseudonym resultUserPseudonym = _2 . _Just resultUserSubmissionGroup :: Traversal' CorrectionTableUserData SubmissionGroupName resultUserSubmissionGroup = _3 . _Just resultCryptoID :: Lens' CorrectionTableData CryptoFileNameSubmission resultCryptoID = _dbrOutput . _7 resultNonAnonymousAccess :: Lens' CorrectionTableData Bool resultNonAnonymousAccess = _dbrOutput . _8 -- Where Clauses ratedBy :: UserId -> CorrectionTableWhere ratedBy uid = views querySubmission $ (E.==. E.justVal uid) . (E.^. SubmissionRatingBy) courseIs :: CourseId -> CorrectionTableWhere courseIs cid = views queryCourse $ (E.==. E.val cid) . (E.^. CourseId) sheetIs :: Key Sheet -> CorrectionTableWhere sheetIs shid = views querySheet $ (E.==. E.val shid) . (E.^. SheetId) userIs :: Key User -> CorrectionTableWhere userIs uid = views querySubmission $ \submission -> E.exists . E.from $ \submissionUser -> E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId E.&&. submissionUser E.^. SubmissionUserUser E.==. E.val uid -- Columns colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colTerm = sortable (Just "term") (i18nCell MsgTableTerm) . views (resultCourseTerm . _TermId) $ textCell . termToText colSchool :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSchool = sortable (Just "school") (i18nCell MsgTableCourseSchool) $ \x -> let tid = x ^. resultCourseTerm ssh = x ^. resultCourseSchool in anchorCell (TermSchoolCourseListR tid ssh) (ssh ^. _SchoolId) colCourse :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgTableCourse) $ views ($(multifocusG 3) resultCourseTerm resultCourseSchool resultCourseShorthand) courseCellCL colSheet :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSheet = sortable (Just "sheet") (i18nCell MsgTableSheet) $ \x -> let tid = x ^. resultCourseTerm ssh = x ^. resultCourseSchool csh = x ^. resultCourseShorthand shn = x ^. resultSheet . _entityVal . _sheetName in anchorCell (CSheetR tid ssh csh shn SShowR) shn colCorrector :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colCorrector = sortable (Just "corrector") (i18nCell MsgTableCorrector) $ \x -> maybeCell (x ^? resultCorrector) $ \(Entity _ User{..}) -> userCell userDisplayName userSurname colSubmissionLink :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSubmissionLink = sortable (Just "submission") (i18nCell MsgTableSubmission) $ \x -> let tid = x ^. resultCourseTerm ssh = x ^. resultCourseSchool csh = x ^. resultCourseShorthand shn = x ^. resultSheet . _entityVal . _sheetName subCID = x ^. resultCryptoID in anchorCellC $cacheIdentHere (CSubmissionR tid ssh csh shn subCID SubShowR) (toPathPiece subCID) colSelect :: forall act h epId. (Semigroup act, Monoid act, Headedness h, Ord epId) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary epId)) colSelect = dbSelect (_1 . applying _2) id $ views resultCryptoID return colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \x -> let tid = x ^. resultCourseTerm ssh = x ^. resultCourseSchool csh = x ^. resultCourseShorthand link uCID = CourseR tid ssh csh $ CUserR uCID protoCell = listCell (sortOn (view $ _2 . resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) $ itoListOf resultSubmittors x) $ \((encrypt -> mkUCID), u) -> let User{..} = u ^. resultUserUser mPseudo = u ^? resultUserPseudonym in anchorCellCM $cacheIdentHere (link <$> mkUCID) $ [whamlet| $newline never ^{nameWidget userDisplayName userSurname} $maybe p <- mPseudo \ (#{review _PseudonymText p}) |] in guardMonoid (x ^. resultNonAnonymousAccess) $ protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgTableMatrikelNr) $ \x -> let protoCell = listCell (sort $ x ^.. resultSubmittors . resultUserUser . _userMatrikelnummer . _Just) wgtCell in guardMonoid (x ^. resultNonAnonymousAccess) $ protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colSGroups :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSGroups = sortable (Just "submittors-group") (i18nCell MsgTableSubmissionGroup) $ \x -> let protoCell = listCell (setOf (resultSubmittors . resultUserSubmissionGroup) x) wgtCell in guardMonoid (x ^. resultNonAnonymousAccess) $ protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colRating :: forall m a a'. (IsDBTable m a, a ~ (a', SheetTypeSummary SqlBackendKey)) => Colonnade Sortable CorrectionTableData (DBCell m a) colRating = colRating' _2 colRating' :: forall m a. IsDBTable m a => ASetter' a (SheetTypeSummary SqlBackendKey) -> Colonnade Sortable CorrectionTableData (DBCell m a) colRating' l = sortable (Just "rating") (i18nCell MsgTableRating) $ \x -> let tid = x ^. resultCourseTerm ssh = x ^. resultCourseSchool csh = x ^. resultCourseShorthand shn = x ^. resultSheet . _entityVal . _sheetName cID = x ^. resultCryptoID sub@Submission{..} = x ^. resultSubmission . _entityVal Sheet{..} = x ^. resultSheet . _entityVal mkRoute = return $ CSubmissionR tid ssh csh shn cID CorrectionR in mconcat [ anchorCellCM $cacheIdentHere mkRoute $(widgetFile "widgets/rating/rating") , writerCell $ do let summary :: SheetTypeSummary SqlBackendKey summary = sheetTypeSum sheetType $ submissionRatingPoints <* guard (submissionRatingDone sub) scribe l summary ] colAssigned :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingAssigned . _Just) dateTimeCell colRated :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colRated = sortable (Just "ratingtime") (i18nCell MsgTableRatingTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingTime . _Just) dateTimeCell colPseudonyms :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \x -> let protoCell = listCell (sort $ x ^.. resultSubmittors . resultUserPseudonym . re _PseudonymText) wgtCell in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colRatedField :: a' ~ (Bool, a, b) => Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a' CorrectionTableData))) colRatedField = colRatedField' _1 colRatedField' :: ASetter' a Bool -> Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a CorrectionTableData))) colRatedField' l = sortable Nothing (i18nCell MsgRatingDone) $ formCell id (views (resultSubmission . _entityKey) return) (\(views (resultSubmission . _entityVal) submissionRatingDone -> done) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done)) colPointsField :: a' ~ (a, Maybe Points, b) => Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a' CorrectionTableData))) colPointsField = colPointsField' _2 colPointsField' :: ASetter' a (Maybe Points) -> Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a CorrectionTableData))) colPointsField' l = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id (views (resultSubmission . _entityKey) return) (\(view $ $(multifocusG 2) (resultSubmission . _entityVal) (resultSheet . _entityVal) -> (Submission{..}, Sheet{..})) mkUnique -> case sheetType of NotGraded -> pure $ over (_1.mapped) (l .~) (FormSuccess Nothing, mempty) _other -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints) ) colMaxPointsField :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgTableSheetType) $ \x -> cell $ do let Sheet{..} = x ^. resultSheet . _entityVal sheetTypeDesc <- liftHandler . runDB $ sheetTypeDescription sheetCourse sheetType toWidget . sheetTypeDesc =<< getTranslate colCommentField :: a' ~ (a, b, Maybe Text) => Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a' CorrectionTableData))) colCommentField = colCommentField' _3 colCommentField' :: ASetter' a (Maybe Text) -> Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a CorrectionTableData))) colCommentField' l = sortable (Just "comment") (i18nCell MsgRatingComment) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id (views (resultSubmission . _entityKey) return) (\(view (resultSubmission . _entityVal) -> Submission{..}) mkUnique -> over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment)) colLastEdit :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colLastEdit = sortable (Just "last-edit") (i18nCell MsgTableLastEdit) $ \x -> maybeCell (x ^? resultLastEdit) dateTimeCell filterUICourse :: Handler (OptionList Text) -> DBFilterUI filterUICourse courseOptions = flip (prismAForm $ singletonFilter "course") $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgTableCourse) filterUITerm :: Handler (OptionList Text) -> DBFilterUI filterUITerm termOptions = flip (prismAForm $ singletonFilter "term") $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTableTerm) filterUISchool :: Handler (OptionList Text) -> DBFilterUI filterUISchool schoolOptions = flip (prismAForm $ singletonFilter "school") $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgTableCourseSchool) filterUISheetSearch :: DBFilterUI filterUISheetSearch mPrev = singletonMap "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgTableSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev))) filterUIIsRated :: DBFilterUI filterUIIsRated = flip (prismAForm $ singletonFilter "israted" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableRatingTime) filterUISubmission :: DBFilterUI filterUISubmission = flip (prismAForm $ singletonFilter "submission") $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission) filterUIPseudonym :: DBFilterUI filterUIPseudonym = flip (prismAForm $ singletonFilter "pseudonym") $ aopt (lift `hoistField` textField) (fslI MsgSubmissionPseudonym) filterUIUserNameEmail :: DBFilterUI filterUIUserNameEmail = flip (prismAForm $ singletonFilter "user-name-email") $ aopt textField (fslI MsgTableCourseMembers) filterUIUserMatrikelnummer :: DBFilterUI filterUIUserMatrikelnummer = flip (prismAForm $ singletonFilter "user-matriclenumber") $ aopt textField (fslI MsgTableMatrikelNr) filterUICorrectorNameEmail :: DBFilterUI filterUICorrectorNameEmail = flip (prismAForm $ singletonFilter "corrector-name-email") $ aopt textField (fslI MsgTableCorrector) filterUIIsAssigned :: DBFilterUI filterUIIsAssigned = flip (prismAForm $ singletonFilter "isassigned" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableHasCorrector) filterUISubmissionGroup :: DBFilterUI filterUISubmissionGroup = flip (prismAForm $ singletonFilter "submittors-group") $ aopt textField (fslI MsgTableSubmissionGroup) filterUIRating :: DBFilterUI filterUIRating = flip (prismAForm $ singletonFilter "rating" . maybePrism _PathPiece) $ aopt (lift `hoistField` pointsField) (fslI MsgColumnRatingPoints) filterUIComment :: DBFilterUI filterUIComment mPrev = singletonMap "comment" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgRatingComment) (Just <$> listToMaybe =<< (Map.lookup "comment" =<< mPrev)) 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 = 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 lastEdit <- view queryLastEdit let crse = ( course E.^. CourseName , course E.^. CourseShorthand , course E.^. CourseTerm , course E.^. CourseSchool ) 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 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 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 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) 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 ] 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' } dbtIdent = "corrections" :: Text dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] in dbTable psValidator DBTable{..} data ActionCorrections = CorrDownload | CorrSetCorrector | CorrAutoSetCorrector | CorrDelete deriving (Eq, Ord, Read, Show, Enum, Bounded) instance Universe ActionCorrections instance Finite ActionCorrections nullaryPathPiece ''ActionCorrections $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''ActionCorrections id data ActionCorrectionsData = CorrDownloadData SubmissionDownloadAnonymous SubmissionFileType | CorrSetCorrectorData (Maybe UserId) | CorrAutoSetCorrectorData SheetId | CorrDeleteData correctionsR :: CorrectionTableWhere -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do (table, statistics) <- correctionsR' whereClause displayColumns dbtFilterUI psValidator actions fmap toTypedContent . defaultLayout $ do setTitleI MsgCourseCorrectionsTitle $(widgetFile "corrections") correctionsR' :: CorrectionTableWhere -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary SqlBackendKey) correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler postDeleteR $ \drRecords -> (submissionDeleteRoute drRecords) { drAbort = SomeRoute currentRoute , drSuccess = SomeRoute currentRoute } ((actionRes', statistics), table) <- runDB $ makeCorrectionsTable whereClause displayColumns dbtFilterUI psValidator DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Just $ SomeRoute currentRoute , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional = \frag -> do (actionRes, action) <- multiActionM actions "" Nothing mempty return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = _1 , dbParamsFormIdent = def } -- -- Similar Query for Statistics over alle possible Table elements (not just the ones shown) -- gradingSummary <- 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 = gradeSummaryWidget MsgSubmissionGradingSummaryTitle gradingSummary -- return (tableRes, statistics) let actionRes = actionRes' <&> _2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False) <&> _1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast auditAllSubEdit = mapM_ $ \sId -> getJust sId >>= \sub -> audit $ TransactionSubmissionEdit sId $ sub ^. _submissionSheet formResult actionRes $ \case (CorrDownloadData nonAnonymous sft, subs) -> do ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable MsgRenderer mr <- getMsgRenderer setContentDisposition' $ Just ((addExtension `on` unpack) (mr MsgSubmissionArchiveName) extensionZip) sendResponse =<< submissionMultiArchive nonAnonymous sft ids (CorrSetCorrectorData (Just uid), subs') -> do subs <- mapM decrypt $ Set.toList subs' now <- liftIO getCurrentTime runDB $ do alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] [] unless (null alreadyAssigned) $ do mr <- (toHtml . ) <$> getMessageRender alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr) let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned) (unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned unless (null unassignedUnauth) $ do let submissionEncrypt = encrypt :: SubmissionId -> DB CryptoFileNameSubmission unassignedUnauth' <- mapM submissionEncrypt $ Set.toList unassignedUnauth let numUnassignedUnauth = fromIntegral $ length unassignedUnauth' trigger = [whamlet|_{MsgSubmissionsAssignUnauthorized numUnassignedUnauth}|] content = Right $(widgetFile "messages/submissionsAssignUnauthorized") addMessageModal Warning trigger content unless (null unassignedAuth) $ do let sIds = Set.toList unassignedAuth num <- updateWhereCount [SubmissionId <-. sIds] [ SubmissionRatingBy =. Just uid , SubmissionRatingAssigned =. Just now -- save, since only applies to unassigned ] addMessageI Success $ MsgUpdatedAssignedCorrectorSingle num auditAllSubEdit sIds selfCorrectors <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe) . E.select . E.from $ \(submission `E.InnerJoin` subuser) -> do E.on $ submission E.^. SubmissionId E.==. subuser E.^. SubmissionUserSubmission E.where_ $ submission E.^. SubmissionId `E.in_` E.valList subs E.&&. submission E.^. SubmissionRatingBy E.==. E.just (subuser E.^. SubmissionUserUser) return (E.countRows :: E.SqlExpr (E.Value Int64)) when (selfCorrectors > 0) $ addMessageI Warning $ MsgSelfCorrectors selfCorrectors redirect currentRoute (CorrSetCorrectorData Nothing, subs') -> do -- delete corrections subs <- mapM decrypt $ Set.toList subs' runDB $ do num <- updateWhereCount [SubmissionId <-. subs] [ SubmissionRatingBy =. Nothing , SubmissionRatingAssigned =. Nothing , SubmissionRatingTime =. Nothing -- , SubmissionRatingPoints =. Nothing -- Kept for easy reassignment by 2nd corrector -- , SubmissionRatingComment =. Nothing -- Kept for easy reassignment by 2nd corrector ] addMessageI Success $ MsgRemovedCorrections num auditAllSubEdit subs redirect currentRoute (CorrAutoSetCorrectorData shid, subs') -> do subs <- mapM decrypt $ Set.toList subs' let assignExceptions :: AssignSubmissionException -> Handler () assignExceptions NoCorrectors = addMessageI Error MsgAssignSubmissionExceptionNoCorrectors assignExceptions NoCorrectorsByProportion = addMessageI Error MsgAssignSubmissionExceptionNoCorrectorsByProportion assignExceptions (SubmissionsNotFound subIds) = do subCIDs <- mapM encrypt . Set.toList $ toNullable subIds :: Handler [CryptoFileNameSubmission] let errorModal = msgModal [whamlet|_{MsgAssignSubmissionExceptionSubmissionsNotFound (length subCIDs)}|] (Right $(widgetFile "messages/submissionsAssignNotFound")) addMessageWidget Error errorModal handle assignExceptions . runDB $ do alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] [] unless (null alreadyAssigned) $ do mr <- (toHtml . ) <$> getMessageRender alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr) let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned) (unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned unless (null unassignedUnauth) $ do let submissionEncrypt = encrypt :: SubmissionId -> DB CryptoFileNameSubmission unassignedUnauth' <- mapM submissionEncrypt $ Set.toList unassignedUnauth let numUnassignedUnauth = fromIntegral $ length unassignedUnauth' trigger = [whamlet|_{MsgSubmissionsAssignUnauthorized numUnassignedUnauth}|] content = Right $(widgetFile "messages/submissionsAssignUnauthorized") addMessageModal Warning trigger content unless (null unassignedAuth) $ do (assigned, stillUnassigned) <- assignSubmissions shid (Just unassignedAuth) unless (null assigned) $ addMessageI Success $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned) unless (null stillUnassigned) $ do mr <- (toHtml . ) <$> getMessageRender unassigned' <- forM (Set.toList stillUnassigned) $ \sid -> encrypt sid :: DB CryptoFileNameSubmission addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr) redirect currentRoute (CorrDeleteData, subs) -> do subs' <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable getDeleteR (submissionDeleteRoute subs') { drAbort = SomeRoute currentRoute , drSuccess = SomeRoute currentRoute } return (table, statistics) where authorizedToAssign :: SubmissionId -> DB Bool authorizedToAssign sId = do (E.Value tid, E.Value ssh, E.Value csh, E.Value shn) <- maybe notFound return . listToMaybe <=< E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission ) -> do E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.where_ $ submission E.^. SubmissionId E.==. E.val sId return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, sheet E.^. SheetName) cID <- encrypt sId let route = CSubmissionR tid ssh csh shn cID SubAssignR (== Authorized) <$> evalAccessDB route True restrictAnonymous :: PSValidator m x -> PSValidator m x restrictAnonymous = restrictFilter (\k _ -> k /= "user-matriclenumber") . restrictFilter (\k _ -> k /= "user-name-email") . restrictFilter (\k _ -> k /= "submission-group") . restrictSorting (\k _ -> k /= "last-edit") restrictCorrector :: PSValidator m x -> PSValidator m x restrictCorrector = restrictFilter (\k _ -> k /= "corrector") . restrictFilter (\k _ -> k /= "corrector-name-email") . restrictSorting (\k _ -> k /= "corrector") type ActionCorrections' = (ActionCorrections, AForm (HandlerFor UniWorX) ActionCorrectionsData) downloadAction, deleteAction :: ActionCorrections' downloadAction = ( CorrDownload , CorrDownloadData <$> apopt (selectField optionsFinite) (fslI MsgCorrDownloadAnonymous & setTooltip MsgCorrDownloadAnonymousTip) (Just SubmissionDownloadAnonymous) <*> apopt (selectField optionsFinite) (fslI MsgCorrDownloadVersion) (Just SubmissionCorrected) ) deleteAction = ( CorrDelete , pure CorrDeleteData ) assignAction :: Either CourseId SheetId -> ActionCorrections' assignAction selId = ( CorrSetCorrector , wFormToAForm $ do correctors <- liftHandler . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.where_ $ either (\cId -> course E.^. CourseId E.==. E.val cId) (\shId -> sheet E.^. SheetId E.==. E.val shId) selId E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName] E.distinct $ return user correctors' <- forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (SomeMessage userDisplayName, ) <$> encrypt entityKey cId <- wopt (selectFieldList correctors' :: Field (HandlerFor UniWorX) CryptoUUIDUser) (fslI MsgTableCorrector & setTooltip MsgCorrSetCorrectorTooltip) Nothing fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId ) autoAssignAction :: SheetId -> ActionCorrections' autoAssignAction shid = ( CorrAutoSetCorrector , pure $ CorrAutoSetCorrectorData shid ) getCorrectionsR, postCorrectionsR :: Handler TypedContent getCorrectionsR = postCorrectionsR postCorrectionsR = do uid <- requireAuthId let whereClause :: CorrectionTableWhere whereClause = ratedBy uid colonnade = mconcat [ colSelect , colSchool , colTerm , colCourse , colSheet , colSMatrikel , colSubmittors , colSGroups , colPseudonyms , colSubmissionLink , colAssigned , colRating , colRated ] -- Continue here filterUI = Just $ mconcat [ filterUIPseudonym , filterUICourse courseOptions , filterUITerm termOptions , filterUISchool schoolOptions , filterUISheetSearch , filterUIIsRated , filterUISubmission ] courseOptions = runDB $ do courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) optionsPairs . map (id &&& id) . nubOrd $ map (CI.original . courseShorthand . entityVal) courses termOptions = runDB $ do courses <- selectList [] [Desc CourseTerm] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) optionsPairs . map (id &&& id) . nubOrd $ map (termToText . unTermKey . courseTerm . entityVal) courses schoolOptions = runDB $ do courses <- selectList [] [Asc CourseSchool] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) optionsPairs . map (id &&& id) . nubOrd $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses psValidator = def & restrictCorrector & restrictAnonymous & defaultSorting [SortDescBy "ratingtime", SortAscBy "assignedtime" ] & defaultFilter (singletonMap "israted" [toPathPiece False]) correctionsR whereClause colonnade filterUI psValidator $ Map.fromList [ downloadAction ] getCCorrectionsR, postCCorrectionsR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent getCCorrectionsR = postCCorrectionsR postCCorrectionsR tid ssh csh = do Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh let whereClause :: CorrectionTableWhere whereClause = courseIs cid colonnade = mconcat -- should match getSSubsR for consistent UX [ colSelect , colSheet , colSMatrikel , colSubmittors , colSGroups , colSubmissionLink , colLastEdit , colRating , colRated , colCorrector , colAssigned ] -- Continue here filterUI = Just $ mconcat [ filterUIUserNameEmail , filterUIUserMatrikelnummer , filterUIPseudonym , filterUISheetSearch , filterUICorrectorNameEmail , filterUIIsAssigned , filterUIIsRated , filterUISubmissionGroup , filterUISubmission ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway correctionsR whereClause colonnade filterUI psValidator $ Map.fromList [ downloadAction , assignAction (Left cid) , deleteAction ] getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent getSSubsR = postSSubsR postSSubsR tid ssh csh shn = do shid <- runDB $ fetchSheetId tid ssh csh shn let whereClause :: CorrectionTableWhere whereClause = sheetIs shid colonnade = mconcat -- should match getCCorrectionsR for consistent UX [ colSelect , colSMatrikel , colSubmittors , colSubmissionLink , colLastEdit , colRating , colRated , colCorrector , colAssigned ] filterUI = Just $ mconcat [ filterUIUserNameEmail , filterUIUserMatrikelnummer , filterUIPseudonym , filterUICorrectorNameEmail , filterUIIsAssigned , filterUIIsRated , filterUISubmissionGroup , filterUISubmission ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway correctionsR whereClause colonnade filterUI psValidator $ Map.fromList [ downloadAction , assignAction (Right shid) , autoAssignAction shid , deleteAction ]