{-# 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 , 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 , CorrectionTableCsvQualification(..), CorrectionTableCsvSettings(..) ) where import Import hiding (link) import Handler.Utils hiding (colSchool) import Handler.Utils.Submission import Handler.Utils.SheetType import Handler.Utils.Delete 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 qualified Data.Conduit.Combinators as C import Text.Hamlet (ihamletFile) import Database.Persist.Sql (updateWhereCount) import Data.List (genericLength) import qualified Data.Csv as Csv 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 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, Maybe AuthorshipStatementSubmissionState) type CorrectionTableData = DBRow ( Entity Submission , Entity Sheet , CorrectionTableCourseData , Maybe (Entity User) , Maybe UTCTime , Map UserId CorrectionTableUserData , CryptoFileNameSubmission , Bool {- Access to non-anonymous submission data -} , Maybe AuthorshipStatementSubmissionState ) 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 resultUserAuthorshipStatementState :: Traversal' CorrectionTableUserData AuthorshipStatementSubmissionState resultUserAuthorshipStatementState = _4 . _Just resultCryptoID :: Lens' CorrectionTableData CryptoFileNameSubmission resultCryptoID = _dbrOutput . _7 resultNonAnonymousAccess :: Lens' CorrectionTableData Bool resultNonAnonymousAccess = _dbrOutput . _8 resultASState :: Lens' CorrectionTableData (Maybe AuthorshipStatementSubmissionState) resultASState = _dbrOutput . _9 data CorrectionTableCsv = CorrectionTableCsv { csvCorrectionTerm :: Maybe TermIdentifier , csvCorrectionSchool :: Maybe SchoolShorthand , csvCorrectionCourse :: Maybe CourseShorthand , csvCorrectionSheet :: Maybe SheetName , csvCorrectionSubmission :: Maybe (CI Text) , csvCorrectionLastEdit :: Maybe UTCTime , csvCorrectionSurname :: Maybe [Maybe UserSurname] , csvCorrectionFirstName :: Maybe [Maybe UserFirstName] , csvCorrectionName :: Maybe [Maybe UserDisplayName] , csvCorrectionMatriculation :: Maybe [Maybe UserMatriculation] , csvCorrectionEmail :: Maybe [Maybe UserEmail] , csvCorrectionPseudonym :: Maybe [Maybe Pseudonym] , csvCorrectionSubmissionGroup :: Maybe [Maybe SubmissionGroupName] , csvCorrectionAuthorshipStatementState :: Maybe [Maybe AuthorshipStatementSubmissionState] , csvCorrectionAssigned :: Maybe UTCTime , csvCorrectionCorrectorName :: Maybe UserDisplayName , csvCorrectionCorrectorEmail :: Maybe UserEmail , csvCorrectionRatingDone :: Maybe Bool , csvCorrectionRatedAt :: Maybe UTCTime , csvCorrectionRatingPoints :: Maybe Points , csvCorrectionRatingComment :: Maybe Text } deriving (Generic) makeLenses_ ''CorrectionTableCsv correctionTableCsvOptions :: Csv.Options correctionTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 2 } instance Csv.ToNamedRecord CorrectionTableCsv where toNamedRecord CorrectionTableCsv{..} = Csv.namedRecord [ "term" Csv..= csvCorrectionTerm , "school" Csv..= csvCorrectionSchool , "course" Csv..= csvCorrectionCourse , "sheet" Csv..= csvCorrectionSheet , "submission" Csv..= csvCorrectionSubmission , "last-edit" Csv..= csvCorrectionLastEdit , "surname" Csv..= maybe mempty (Csv.toField . CsvSemicolonList) csvCorrectionSurname , "first-name" Csv..= maybe mempty (Csv.toField . CsvSemicolonList) csvCorrectionFirstName , "name" Csv..= maybe mempty (Csv.toField . CsvSemicolonList) csvCorrectionName , "matriculation" Csv..= maybe mempty (Csv.toField . CsvSemicolonList . mkEmpty) csvCorrectionMatriculation , "email" Csv..= maybe mempty (Csv.toField . CsvSemicolonList) csvCorrectionEmail , "pseudonym" Csv..= maybe mempty (Csv.toField . CsvSemicolonList . mkEmpty) csvCorrectionPseudonym , "submission-group" Csv..= maybe mempty (Csv.toField . CsvSemicolonList . mkEmpty) csvCorrectionSubmissionGroup , "authorship-statement-state" Csv..= maybe mempty (Csv.toField . CsvSemicolonList . mkEmpty) csvCorrectionAuthorshipStatementState , "assigned" Csv..= csvCorrectionAssigned , "corrector-name" Csv..= csvCorrectionCorrectorName , "corrector-email" Csv..= csvCorrectionCorrectorEmail , "rating-done" Csv..= csvCorrectionRatingDone , "rated-at" Csv..= csvCorrectionRatedAt , "rating-points" Csv..= csvCorrectionRatingPoints , "rating-comment" Csv..= csvCorrectionRatingComment ] where mkEmpty = \case [Nothing] -> [] x -> x instance Csv.DefaultOrdered CorrectionTableCsv where headerOrder = Csv.genericHeaderOrder correctionTableCsvOptions instance Csv.FromNamedRecord CorrectionTableCsv where parseNamedRecord csv = CorrectionTableCsv <$> csv .:?? "term" <*> csv .:?? "school" <*> csv .:?? "course" <*> csv .:?? "sheet" <*> csv .:?? "submission" <*> csv .:?? "last-edit" <*> fmap (fmap unCsvSemicolonList) (csv .:?? "surname") <*> fmap (fmap unCsvSemicolonList) (csv .:?? "first-name") <*> fmap (fmap unCsvSemicolonList) (csv .:?? "name") <*> fmap (fmap unCsvSemicolonList) (csv .:?? "matriculation") <*> fmap (fmap unCsvSemicolonList) (csv .:?? "email") <*> fmap (fmap unCsvSemicolonList) (csv .:?? "pseudonym") <*> fmap (fmap unCsvSemicolonList) (csv .:?? "submission-group") <*> fmap (fmap unCsvSemicolonList) (csv .:?? "authorship-statement-state") <*> csv .:?? "assigned" <*> csv .:?? "corrector-name" <*> csv .:?? "corrector-email" <*> csv .:?? "rating-done" <*> csv .:?? "rated-at" <*> csv .:?? "rating-points" <*> csv .:?? "rating-comment" instance CsvColumnsExplained CorrectionTableCsv where csvColumnsExplanations = genericCsvColumnsExplanations correctionTableCsvOptions $ Map.fromList [ ('csvCorrectionTerm , MsgCsvColumnCorrectionTerm) , ('csvCorrectionSchool , MsgCsvColumnCorrectionSchool) , ('csvCorrectionCourse , MsgCsvColumnCorrectionCourse) , ('csvCorrectionSheet , MsgCsvColumnCorrectionSheet) , ('csvCorrectionSubmission , MsgCsvColumnCorrectionSubmission) , ('csvCorrectionLastEdit , MsgCsvColumnCorrectionLastEdit) , ('csvCorrectionSurname , MsgCsvColumnCorrectionSurname) , ('csvCorrectionFirstName , MsgCsvColumnCorrectionFirstName) , ('csvCorrectionName , MsgCsvColumnCorrectionName) , ('csvCorrectionMatriculation , MsgCsvColumnCorrectionMatriculation) , ('csvCorrectionEmail , MsgCsvColumnCorrectionEmail) , ('csvCorrectionPseudonym , MsgCsvColumnCorrectionPseudonym) , ('csvCorrectionSubmissionGroup, MsgCsvColumnCorrectionSubmissionGroup) , ('csvCorrectionAuthorshipStatementState, MsgCsvColumnCorrectionAuthorshipStatementState) , ('csvCorrectionAssigned , MsgCsvColumnCorrectionAssigned) , ('csvCorrectionCorrectorName , MsgCsvColumnCorrectionCorrectorName) , ('csvCorrectionCorrectorEmail , MsgCsvColumnCorrectionCorrectorEmail) , ('csvCorrectionRatingDone , MsgCsvColumnCorrectionRatingDone) , ('csvCorrectionRatedAt , MsgCsvColumnCorrectionRatedAt) , ('csvCorrectionRatingPoints , MsgCsvColumnCorrectionRatingPoints) , ('csvCorrectionRatingComment , MsgCsvColumnCorrectionRatingComment) ] data CorrectionTableCsvQualification = CorrectionTableCsvNoQualification | CorrectionTableCsvQualifySheet | CorrectionTableCsvQualifyCourse deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving anyclass (Universe, Finite) correctionTableCsvHeader :: Bool -- ^ @showCorrector@ -> CorrectionTableCsvQualification -> Csv.Header correctionTableCsvHeader showCorrector qual = Csv.header $ catMaybes [ guardOn (qual >= CorrectionTableCsvQualifyCourse) "term" , guardOn (qual >= CorrectionTableCsvQualifyCourse) "school" , guardOn (qual >= CorrectionTableCsvQualifyCourse) "course" , guardOn (qual >= CorrectionTableCsvQualifySheet) "sheet" , pure "submission" , pure "last-edit" , pure "surname" , pure "first-name" , pure "name" , pure "matriculation" , pure "email" , pure "pseudonym" , pure "submission-group" , pure "authorship-statement-state" , pure "assigned" , guardOn showCorrector "corrector-name" , guardOn showCorrector "corrector-email" , pure "rating-done" , pure "rated-at" , pure "rating-points" , pure "rating-comment" ] data CorrectionTableCsvSettings = forall filename sheetName. ( RenderMessage UniWorX filename, RenderMessage UniWorX sheetName ) => CorrectionTableCsvSettings { cTableCsvQualification :: CorrectionTableCsvQualification , cTableCsvName :: filename , cTableCsvSheetName :: sheetName , cTableShowCorrector :: Bool } newtype CorrectionTableCsvExportData = CorrectionTableCsvExportData { csvCorrectionSingleSubmittors :: Bool } deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Default CorrectionTableCsvExportData where def = CorrectionTableCsvExportData False data CorrectionTableJson = CorrectionTableJson { jsonCorrectionTerm :: TermIdentifier , jsonCorrectionSchool :: SchoolShorthand , jsonCorrectionCourse :: CourseShorthand , jsonCorrectionSheet :: SheetName , jsonCorrectionLastEdit :: Maybe UTCTime , jsonCorrectionSubmittors :: Maybe [CorrectionTableSubmittorJson] , jsonCorrectionAssigned :: Maybe UTCTime , jsonCorrectionCorrectorName :: Maybe UserDisplayName , jsonCorrectionCorrectorEmail :: Maybe UserEmail , jsonCorrectionRatingDone :: Bool , jsonCorrectionRatedAt :: Maybe UTCTime , jsonCorrectionRatingPoints :: Maybe Points , jsonCorrectionRatingComment :: Maybe Text } deriving (Generic) data CorrectionTableSubmittorJson = CorrectionTableSubmittorJson { jsonCorrectionSurname :: UserSurname , jsonCorrectionFirstName :: UserFirstName , jsonCorrectionName :: UserDisplayName , jsonCorrectionMatriculation :: Maybe UserMatriculation , jsonCorrectionEmail :: UserEmail , jsonCorrectionPseudonym :: Maybe Pseudonym , jsonCorrectionSubmissionGroup :: Maybe SubmissionGroupName , jsonCorrectionAuthorshipStatementState :: Maybe AuthorshipStatementSubmissionState } deriving (Generic) deriveToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 } ''CorrectionTableSubmittorJson deriveToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 } ''CorrectionTableJson -- 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 (guardOnM (x ^. resultNonAnonymousAccess) $ 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 (guardOnM (x ^. resultNonAnonymousAccess) $ 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) 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 "submission-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)) 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) -> _ -> Maybe CorrectionTableCsvSettings -> PSValidator m x -> DBParams m x -> DB (DBResult m x) makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' mCSVSettings 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') mASDefinition <- lift . lift . $cachedHereBinary shId $ getSheetAuthorshipStatement sheet (submittorMap, fmap getMax -> asState) <- runWriterT . flip foldMapM submittors $ \(Entity userId user, E.Value pseudo, E.Value sGroup) -> do asState <- for mASDefinition $ \_ -> lift . lift . lift $ getUserAuthorshipStatement mASDefinition sId userId tell $ Max <$> asState return $ Map.singleton userId (user, pseudo, sGroup, asState) forMM_ (preview $ _dbtProjFilter . _corrProjFilterAuthorshipStatementState . _Wrapped . _Just) $ \criterion -> guard $ asState == Just criterion 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, asState) 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 $ views resultCryptoID toPathPiece , singletonMap "as-state" . SortProjected . comparing $ view resultASState ] 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 "as-state" $ FilterProjected (_corrProjFilterAuthorshipStatementState <>~) ] dbtFilterUI = fromMaybe mempty dbtFilterUI' dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI' } dbtIdent = "corrections" :: Text dbtCsvEncode = do CorrectionTableCsvSettings{..} <- mCSVSettings return DBTCsvEncode { dbtCsvExportForm = CorrectionTableCsvExportData <$> apopt checkBoxField (fslI MsgCorrectionCsvSingleSubmittors & setTooltip MsgCorrectionCsvSingleSubmittorsTip) (Just $ csvCorrectionSingleSubmittors def) , dbtCsvNoExportData = Nothing , dbtCsvDoEncode = \CorrectionTableCsvExportData{..} -> awaitForever $ \(_, row) -> runReaderC row $ do submittors <- asks $ sortOn (view $ resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) . toListOf resultSubmittors forM_ (bool pure (map pure) csvCorrectionSingleSubmittors submittors) $ \submittors' -> transPipe (withReaderT (, submittors')) $ do let guardNonAnonymous = runMaybeT . guardMOnM (view $ _1 . resultNonAnonymousAccess) . MaybeT yieldM $ CorrectionTableCsv <$> preview (_1 . resultCourseTerm . _TermId) <*> preview (_1 . resultCourseSchool . _SchoolId) <*> preview (_1 . resultCourseShorthand) <*> preview (_1 . resultSheet . _entityVal . _sheetName) <*> preview (_1 . resultCryptoID . re (_CI . _PathPiece)) <*> guardNonAnonymous (preview $ _1 . resultLastEdit) <*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userSurname . re _Just)) <*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userFirstName . re _Just)) <*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userDisplayName . re _Just)) <*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userMatrikelnummer)) <*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userEmail . re _Just)) <*> guardNonAnonymous (previews _2 (toListOf $ folded . pre resultUserPseudonym)) <*> guardNonAnonymous (previews _2 (toListOf $ folded . pre resultUserSubmissionGroup)) <*> guardNonAnonymous (previews _2 (toListOf $ folded . pre resultUserAuthorshipStatementState)) <*> preview (_1 . resultSubmission . _entityVal . _submissionRatingAssigned . _Just) <*> preview (_1 . resultCorrector . _entityVal . _userDisplayName) <*> preview (_1 . resultCorrector . _entityVal . _userEmail) <*> preview (_1 . resultSubmission . _entityVal . to submissionRatingDone) <*> preview (_1 . resultSubmission . _entityVal . _submissionRatingTime . _Just) <*> preview (_1 . resultSubmission . _entityVal . _submissionRatingPoints . _Just) <*> preview (_1 . resultSubmission . _entityVal . _submissionRatingComment . _Just) , dbtCsvName = cTableCsvName, dbtCsvSheetName = cTableCsvSheetName , dbtCsvHeader = \_ -> return $ correctionTableCsvHeader cTableShowCorrector cTableCsvQualification , dbtCsvExampleData = Nothing } dbtCsvDecode = Nothing dbtExtraReps = maybe id (\CorrectionTableCsvSettings{..} -> withCsvExtraRep cTableCsvSheetName (def :: CorrectionTableCsvExportData) dbtCsvEncode) mCSVSettings [ DBTExtraRep $ toPrettyJSON <$> repCorrectionJson, DBTExtraRep $ toYAML <$> repCorrectionJson ] repCorrectionJson :: ConduitT (E.Value SubmissionId, CorrectionTableData) Void DB (Map CryptoFileNameSubmission CorrectionTableJson) repCorrectionJson = C.foldMap $ \(_, res) -> Map.singleton (res ^. resultCryptoID) $ mkCorrectionTableJson res where mkCorrectionTableJson :: CorrectionTableData -> CorrectionTableJson mkCorrectionTableJson res' = flip runReader res' $ do let guardNonAnonymous :: Reader CorrectionTableData (Maybe a) -> Reader CorrectionTableData (Maybe a) guardNonAnonymous = runMaybeT . guardMOnM (view resultNonAnonymousAccess) . MaybeT mkCorrectionTableSubmittorJson :: Reader CorrectionTableData (Maybe [CorrectionTableSubmittorJson]) mkCorrectionTableSubmittorJson = Just <$> do submittors <- asks $ sortOn (view $ resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) . toListOf resultSubmittors forM submittors $ \submittor -> lift . flip runReaderT submittor $ CorrectionTableSubmittorJson <$> view (resultUserUser . _userSurname) <*> view (resultUserUser . _userFirstName) <*> view (resultUserUser . _userDisplayName) <*> view (resultUserUser . _userMatrikelnummer) <*> view (resultUserUser . _userEmail) <*> preview resultUserPseudonym <*> preview resultUserSubmissionGroup <*> preview resultUserAuthorshipStatementState CorrectionTableJson <$> view (resultCourseTerm . _TermId) <*> view (resultCourseSchool . _SchoolId) <*> view resultCourseShorthand <*> view (resultSheet . _entityVal . _sheetName) <*> guardNonAnonymous (preview resultLastEdit) <*> guardNonAnonymous mkCorrectionTableSubmittorJson <*> preview (resultSubmission . _entityVal . _submissionRatingAssigned . _Just) <*> preview (resultCorrector . _entityVal . _userDisplayName) <*> preview (resultCorrector . _entityVal . _userEmail) <*> view (resultSubmission . _entityVal . to submissionRatingDone) <*> preview (resultSubmission . _entityVal . _submissionRatingTime . _Just) <*> preview (resultSubmission . _entityVal . _submissionRatingPoints . _Just) <*> preview (resultSubmission . _entityVal . _submissionRatingComment . _Just) in dbTable psValidator DBTable{..} data ActionCorrections = CorrDownload | CorrSetCorrector | CorrAutoSetCorrector | CorrSetCorrectionsDone | 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 | CorrSetCorrectionsDoneData Bool | CorrDeleteData correctionsR :: CorrectionTableWhere -> _ -> _ -> Maybe CorrectionTableCsvSettings -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent correctionsR whereClause displayColumns dbtFilterUI csvSettings psValidator actions = do (table, statistics) <- correctionsR' whereClause displayColumns dbtFilterUI csvSettings psValidator actions fmap toTypedContent . defaultLayout $ do setTitleI MsgCourseCorrectionsTitle $(widgetFile "corrections") correctionsR' :: CorrectionTableWhere -> _ -> _ -> Maybe CorrectionTableCsvSettings -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary SqlBackendKey) correctionsR' whereClause displayColumns dbtFilterUI csvSettings 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 csvSettings 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 (CorrSetCorrectionsDoneData isDone, subs') -> do now <- liftIO getCurrentTime subs <- mapM decrypt $ Set.toList subs' runDB $ do _ <- updateWhere [SubmissionId <-. subs] [SubmissionRatingTime =. bool Nothing (Just now) isDone] addMessageI Success $ MsgSetCorrectionsDone isDone auditAllSubEdit subs 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") . restrictFilter (\k _ -> k /= "as-state") . restrictSorting (\k _ -> k /= "submittors") . restrictSorting (\k _ -> k /= "submittors-matriculation") . restrictSorting (\k _ -> k /= "submittors-group") . restrictSorting (\k _ -> k /= "last-edit") . restrictSorting (\k _ -> k /= "as-state") 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 ) setCorrectionsDoneAction :: ActionCorrections' setCorrectionsDoneAction = ( CorrSetCorrectionsDone , CorrSetCorrectionsDoneData <$> apopt checkBoxField (fslI MsgCorrSetCorrectionsDone) (Just True) ) 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 ] 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 [SortAscBy "assignedtime", SortDescBy "ratingtime"] & defaultFilter (singletonMap "israted" [toPathPiece False]) csvSettings = Just CorrectionTableCsvSettings { cTableCsvQualification = CorrectionTableCsvQualifyCourse , cTableCsvName = MsgCorrectionTableCsvNameCorrections , cTableCsvSheetName = MsgCorrectionTableCsvSheetNameCorrections , cTableShowCorrector = False } correctionsR whereClause colonnade filterUI csvSettings psValidator $ Map.fromList [ downloadAction ] getCCorrectionsR, postCCorrectionsR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent getCCorrectionsR = postCCorrectionsR postCCorrectionsR tid ssh csh = do (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 $ 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 [ filterUISheetSearch , filterUIUserNameEmail , filterUIUserMatrikelnummer , filterUIPseudonym , filterUISubmissionGroup , filterUIAuthorshipStatementState , filterUICorrectorNameEmail , filterUIIsAssigned , filterUIIsRated , filterUISubmission ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway csvSettings = Just CorrectionTableCsvSettings { cTableCsvQualification = CorrectionTableCsvQualifySheet , cTableCsvName = MsgCorrectionTableCsvNameCourseCorrections tid ssh csh , cTableCsvSheetName = MsgCorrectionTableCsvSheetNameCourseCorrections tid ssh csh , cTableShowCorrector = True } correctionsR whereClause colonnade filterUI csvSettings psValidator $ Map.fromList [ downloadAction , assignAction (Left cid) , setCorrectionsDoneAction , deleteAction ] getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent getSSubsR = postSSubsR postSSubsR tid ssh csh shn = do (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 $ 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 , filterUISubmission ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway csvSettings = Just CorrectionTableCsvSettings { cTableCsvQualification = CorrectionTableCsvNoQualification , cTableCsvName = MsgCorrectionTableCsvNameSheetCorrections tid ssh csh shn , cTableCsvSheetName = MsgCorrectionTableCsvSheetNameSheetCorrections tid ssh csh shn , cTableShowCorrector = True } correctionsR whereClause colonnade filterUI csvSettings psValidator $ Map.fromList [ downloadAction , assignAction (Right shid) , autoAssignAction shid , setCorrectionsDoneAction , deleteAction ]