diff --git a/src/Handler/Submission/Grade.hs b/src/Handler/Submission/Grade.hs index e848d2901..1ddb8019e 100644 --- a/src/Handler/Submission/Grade.hs +++ b/src/Handler/Submission/Grade.hs @@ -62,7 +62,7 @@ postCorrectionsGradeR = do & restrictAnonymous & restrictCorrector & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData)) - unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment) + unFormResult = getDBFormResult $ \(view $ resultSubmission . _entityVal -> sub@Submission{..}) -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment) (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI psValidator $ def { dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs index c78335edf..3b6521f1b 100644 --- a/src/Handler/Submission/Helper.hs +++ b/src/Handler/Submission/Helper.hs @@ -31,18 +31,6 @@ import Handler.Submission.SubmissionUserInvite import qualified Data.Conduit.Combinators as C -data AuthorshipStatementSubmissionState - = ASExists - | ASOldStatement - | ASMissing - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - deriving anyclass (Universe, Finite) - -nullaryPathPiece ''AuthorshipStatementSubmissionState $ camelToPathPiece' 1 - -embedRenderMessage ''UniWorX ''AuthorshipStatementSubmissionState $ concat . ("SubmissionAuthorshipStatementState" :) . drop 1 . splitCamel - - makeSubmissionForm :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => CourseId -> SheetId -> Maybe (Entity AuthorshipStatementDefinition) -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Maybe FileUploads -> Bool -> Set (Either UserEmail UserId) -> (Markup -> MForm (ReaderT SqlBackend m) (FormResult (Maybe FileUploads, Set (Either UserEmail UserId), Maybe AuthorshipStatementDefinitionId), Widget)) @@ -606,28 +594,10 @@ submissionHelper tid ssh csh shn mcid = do subUsers <- maybeT (return []) $ do subId <- hoistMaybe msmid - let - getUserAuthorshipStatement :: UserId - -> DB AuthorshipStatementSubmissionState - getUserAuthorshipStatement uid = runConduit $ - getStmts - .| fmap toRes (execWriterC . C.mapM_ $ tell . toPoint) - where - getStmts = E.selectSource . E.from $ \authorshipStatementSubmission -> do - E.where_ $ authorshipStatementSubmission E.^. AuthorshipStatementSubmissionSubmission E.==. E.val subId - E.&&. authorshipStatementSubmission E.^. AuthorshipStatementSubmissionUser E.==. E.val uid - return authorshipStatementSubmission - toPoint :: Entity AuthorshipStatementSubmission -> Maybe Any - toPoint (Entity _ AuthorshipStatementSubmission{..}) = Just . Any $ fmap entityKey mASDefinition == Just authorshipStatementSubmissionStatement - toRes :: Maybe Any -> AuthorshipStatementSubmissionState - toRes = \case - Just (Any True) -> ASExists - Just (Any False) -> ASOldStatement - Nothing -> ASMissing lift $ buddies & bool id (maybe id (Set.insert . Right) muid) isOwner & Set.toList - & mapMOf (traverse . _Right) (\uid -> (,,) <$> (encrypt uid :: DB CryptoUUIDUser) <*> getJust uid <*> getUserAuthorshipStatement uid) + & mapMOf (traverse . _Right) (\uid -> (,,) <$> (encrypt uid :: DB CryptoUUIDUser) <*> getJust uid <*> getUserAuthorshipStatement mASDefinition subId uid) & fmap (sortOn . over _Right $ (,,,) <$> views _2 userSurname <*> views _2 userDisplayName <*> views _2 userEmail <*> view _1) subUsersVisible <- orM diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index a9959fdd1..14f1fdb29 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -8,8 +8,9 @@ module Handler.Submission.List , 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 + , resultSubmission + , colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit, colSGroups, colAuthorshipStatementState + , filterUICourse, filterUITerm, filterUISchool, filterUISheetSearch, filterUIIsRated, filterUISubmission, filterUIUserNameEmail, filterUIUserMatrikelnummer, filterUICorrectorNameEmail, filterUIIsAssigned, filterUISubmissionGroup, filterUIRating, filterUIComment, filterUIPseudonym, filterUIAuthorshipStatementState , makeCorrectionsTable , CorrectionTableData, CorrectionTableWhere , ActionCorrections(..), downloadAction, deleteAction, assignAction, autoAssignAction @@ -33,6 +34,8 @@ import Database.Esqueleto.Utils.TH import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E +import qualified Data.Conduit.Combinators as C + import Text.Hamlet (ihamletFile) import Database.Persist.Sql (updateWhereCount) @@ -43,12 +46,14 @@ import Data.List (genericLength) data CorrectionTableFilterProj = CorrectionTableFilterProj { corrProjFilterSubmission :: Maybe (Set [CI Char]) , corrProjFilterPseudonym :: Maybe (Set [CI Char]) + , corrProjFilterAuthorshipStatementState :: Last AuthorshipStatementSubmissionState } instance Default CorrectionTableFilterProj where def = CorrectionTableFilterProj { corrProjFilterSubmission = Nothing , corrProjFilterPseudonym = Nothing + , corrProjFilterAuthorshipStatementState = Last Nothing } makeLenses_ ''CorrectionTableFilterProj @@ -70,6 +75,7 @@ type CorrectionTableData = DBRow ( Entity Submission , Map UserId CorrectionTableUserData , CryptoFileNameSubmission , Bool {- Access to non-anonymous submission data -} + , Maybe AuthorshipStatementSubmissionState ) @@ -135,6 +141,9 @@ resultCryptoID = _dbrOutput . _7 resultNonAnonymousAccess :: Lens' CorrectionTableData Bool resultNonAnonymousAccess = _dbrOutput . _8 +resultASState :: Lens' CorrectionTableData (Maybe AuthorshipStatementSubmissionState) +resultASState = _dbrOutput . _9 + -- Where Clauses ratedBy :: UserId -> CorrectionTableWhere @@ -291,6 +300,22 @@ colCommentField' l = sortable (Just "comment") (i18nCell MsgRatingComment) $ (ce colLastEdit :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colLastEdit = sortable (Just "last-edit") (i18nCell MsgTableLastEdit) $ \x -> maybeCell (x ^? resultLastEdit) dateTimeCell +colAuthorshipStatementState :: forall m a. IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) +colAuthorshipStatementState = sortable (Just "as-state") (i18nCell MsgSubmissionUserAuthorshipStatementState) $ \x -> + let heatC :: AuthorshipStatementSubmissionState -> DBCell m a -> DBCell m a + heatC s c + = c + & cellAttrs %~ addAttrsClass "heated" + & cellAttrs <>~ pure ("style", [st|--hotness: #{tshow (boolHeat (s /= ASExists))}|]) + tid = x ^. resultCourseTerm + ssh = x ^. resultCourseSchool + csh = x ^. resultCourseShorthand + shn = x ^. resultSheet . _entityVal . _sheetName + cID = x ^. resultCryptoID + + asRoute = CSubmissionR tid ssh csh shn cID SubAuthorshipStatementsR + in maybeCell (x ^. resultASState) (\s -> heatC s $ anchorCell asRoute (i18n s :: Widget)) + filterUICourse :: Handler (OptionList Text) -> DBFilterUI filterUICourse courseOptions = flip (prismAForm $ singletonFilter "course") $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgTableCourse) @@ -326,7 +351,7 @@ 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) +filterUISubmissionGroup = flip (prismAForm $ singletonFilter "submission-group") $ aopt textField (fslI MsgTableSubmissionGroup) filterUIRating :: DBFilterUI filterUIRating = flip (prismAForm $ singletonFilter "rating" . maybePrism _PathPiece) $ aopt (lift `hoistField` pointsField) (fslI MsgColumnRatingPoints) @@ -334,6 +359,9 @@ filterUIRating = flip (prismAForm $ singletonFilter "rating" . maybePrism _PathP filterUIComment :: DBFilterUI filterUIComment mPrev = singletonMap "comment" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgRatingComment) (Just <$> listToMaybe =<< (Map.lookup "comment" =<< mPrev)) +filterUIAuthorshipStatementState :: DBFilterUI +filterUIAuthorshipStatementState = flip (prismAForm $ singletonFilter "as-state" . maybePrism _PathPiece) $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) optionsFinite :: Field _ AuthorshipStatementSubmissionState) (fslI MsgSubmissionUserAuthorshipStatementState) + 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) @@ -368,6 +396,13 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams let haystack = map CI.mk . unpack $ toPathPiece cid in guard $ any (`isInfixOf` haystack) criteria + mASDefinition <- lift . lift . $cachedHereBinary shId $ getSheetAuthorshipStatement sheet + asState <- for mASDefinition $ \_ -> + lift . lift . $cachedHereBinary sId $ getSubmissionAuthorshipStatement mASDefinition sId + + forMM_ (preview $ _dbtProjFilter . _corrProjFilterAuthorshipStatementState . _Wrapped . _Just) $ \criterion -> + guard $ asState == Just criterion + 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) @@ -392,7 +427,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams (return $ not sheetAnonymousCorrection) (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, asState) dbtRowKey = views querySubmission (E.^. SubmissionId) dbtSorting = mconcat [ singletonMap "term" . SortColumn $ views queryCourse (E.^. CourseTerm) @@ -418,7 +453,8 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams , 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 "submission" . SortProjected . comparing $ views resultCryptoID toPathPiece + , singletonMap "as-state" . SortProjected . comparing $ view resultASState ] dbtFilter = mconcat [ singletonMap "term" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseTerm) @@ -461,6 +497,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams , singletonMap "comment" . FilterColumn . E.mkContainsFilterWith Just $ views querySubmission (E.^. SubmissionRatingComment) , singletonMap "submission" $ FilterProjected (_corrProjFilterSubmission ?~) , singletonMap "pseudonym" $ FilterProjected (_corrProjFilterPseudonym ?~) + , singletonMap "as-state" $ FilterProjected (_corrProjFilterAuthorshipStatementState <>~) ] dbtFilterUI = fromMaybe mempty dbtFilterUI' dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI' } @@ -742,31 +779,41 @@ postCorrectionsR = do getCCorrectionsR, postCCorrectionsR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent getCCorrectionsR = postCCorrectionsR postCCorrectionsR tid ssh csh = do - Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh + (Entity cid _, doSubmissionGroups, doAuthorshipStatements) <- runDB $ do + course@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh + doSubmissionGroups <- exists [SubmissionGroupCourse ==. cid] + doAuthorshipStatements <- runConduit $ + (E.selectSource . E.from $ \sheet -> sheet <$ E.where_ (sheet E.^. SheetCourse E.==. E.val cid)) + .| C.mapM getSheetAuthorshipStatement + .| C.map (is _Just) + .| C.or + return (course, doSubmissionGroups, doAuthorshipStatements) 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 + colonnade = mconcat $ catMaybes -- should match getSSubsR for consistent UX + [ pure colSelect + , pure colSheet + , pure colSMatrikel + , pure colSubmittors + , guardOn doSubmissionGroups colSGroups + , pure colSubmissionLink + , pure colLastEdit + , guardOn doAuthorshipStatements colAuthorshipStatementState + , pure colRating + , pure colRated + , pure colCorrector + , pure colAssigned ] -- Continue here filterUI = Just $ mconcat - [ filterUIUserNameEmail + [ filterUISheetSearch + , filterUIUserNameEmail , filterUIUserMatrikelnummer , filterUIPseudonym - , filterUISheetSearch + , filterUISubmissionGroup + , filterUIAuthorshipStatementState , filterUICorrectorNameEmail , filterUIIsAssigned , filterUIIsRated - , filterUISubmissionGroup , filterUISubmission ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway @@ -779,28 +826,35 @@ postCCorrectionsR tid ssh csh = do getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent getSSubsR = postSSubsR postSSubsR tid ssh csh shn = do - shid <- runDB $ fetchSheetId tid ssh csh shn + (shid, doSubmissionGroups, doAuthorshipStatements) <- runDB $ do + sheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn + doSubmissionGroups <- exists [SubmissionGroupCourse ==. sheetCourse] + doAuthorshipStatements <- is _Just <$> getSheetAuthorshipStatement sheet + return (shid, doSubmissionGroups, doAuthorshipStatements) let whereClause :: CorrectionTableWhere whereClause = sheetIs shid - colonnade = mconcat -- should match getCCorrectionsR for consistent UX - [ colSelect - , colSMatrikel - , colSubmittors - , colSubmissionLink - , colLastEdit - , colRating - , colRated - , colCorrector - , colAssigned + colonnade = mconcat $ catMaybes -- should match getCCorrectionsR for consistent UX + [ pure colSelect + , pure colSMatrikel + , pure colSubmittors + , guardOn doSubmissionGroups colSGroups + , pure colSubmissionLink + , pure colLastEdit + , guardOn doAuthorshipStatements colAuthorshipStatementState + , pure colRating + , pure colRated + , pure colCorrector + , pure colAssigned ] filterUI = Just $ mconcat [ filterUIUserNameEmail , filterUIUserMatrikelnummer , filterUIPseudonym + , filterUISubmissionGroup + , filterUIAuthorshipStatementState , filterUICorrectorNameEmail , filterUIIsAssigned , filterUIIsRated - , filterUISubmissionGroup , filterUISubmission ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 1d5e5ab7a..96a0710f9 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -11,6 +11,8 @@ module Handler.Utils.Submission , submissionMatchesSheet , submissionDeleteRoute , correctionInvisibleWidget + , AuthorshipStatementSubmissionState(..) + , getUserAuthorshipStatement, getSubmissionAuthorshipStatement ) where import Import hiding (joinPath) @@ -36,6 +38,7 @@ import Handler.Utils import qualified Handler.Utils.Rating as Rating (extractRatings) import Handler.Utils.Delete +import Database.Persist.Sql (SqlBackendCanRead) import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils.TH as E @@ -976,3 +979,58 @@ correctionInvisibleWidget tid ssh csh shn cID (Entity subId sub) = runMaybeT $ d tellPoint CorrectionInvisibleExamUnfinished return $ notification NotificationBroad =<< messageIconWidget Warning IconInvisible $(widgetFile "submission-correction-invisible") + + +data AuthorshipStatementSubmissionState + = ASMissing + | ASOldStatement + | ASExists + deriving (Eq, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +deriving stock instance Ord AuthorshipStatementSubmissionState -- ^ Larger roughly encodes better; summaries are taken with `max` + +nullaryPathPiece ''AuthorshipStatementSubmissionState $ camelToPathPiece' 1 + +embedRenderMessage ''UniWorX ''AuthorshipStatementSubmissionState $ concat . ("SubmissionAuthorshipStatementState" :) . drop 1 . splitCamel + + +getUserAuthorshipStatement :: ( MonadResource m + , IsSqlBackend backend, SqlBackendCanRead backend + ) + => Maybe (Entity AuthorshipStatementDefinition) -- ^ Currently expected authorship statement; see `getSheetAuthorshipStatement` + -> SubmissionId + -> UserId + -> ReaderT backend m AuthorshipStatementSubmissionState +getUserAuthorshipStatement mASDefinition subId uid = runConduit $ + getStmts + .| fmap toRes (execWriterC . C.mapM_ $ tell . toPoint) + where + getStmts = E.selectSource . E.from $ \authorshipStatementSubmission -> do + E.where_ $ authorshipStatementSubmission E.^. AuthorshipStatementSubmissionSubmission E.==. E.val subId + E.&&. authorshipStatementSubmission E.^. AuthorshipStatementSubmissionUser E.==. E.val uid + return authorshipStatementSubmission + toPoint :: Entity AuthorshipStatementSubmission -> Maybe Any + toPoint (Entity _ AuthorshipStatementSubmission{..}) = Just . Any $ fmap entityKey mASDefinition == Just authorshipStatementSubmissionStatement + toRes :: Maybe Any -> AuthorshipStatementSubmissionState + toRes = \case + Just (Any True) -> ASExists + Just (Any False) -> ASOldStatement + Nothing -> ASMissing + +getSubmissionAuthorshipStatement :: ( MonadResource m + , IsSqlBackend backend, SqlBackendCanRead backend + ) + => Maybe (Entity AuthorshipStatementDefinition) -- ^ Currently expected authorship statement; see `getSheetAuthorshipStatement` + -> SubmissionId + -> ReaderT backend m AuthorshipStatementSubmissionState +getSubmissionAuthorshipStatement mASDefinition subId = fmap (fromMaybe ASMissing) . runConduit $ + sourceSubmissionUsers + .| C.map E.unValue + .| C.mapM getUserAuthorshipStatement' + .| C.maximum + where + getUserAuthorshipStatement' = getUserAuthorshipStatement mASDefinition subId + sourceSubmissionUsers = E.selectSource . E.from $ \submissionUser -> do + E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val subId + return $ submissionUser E.^. SubmissionUserUser