diff --git a/messages/uniworx/categories/courses/submission/de-de-formal.msg b/messages/uniworx/categories/courses/submission/de-de-formal.msg index 165cfe9a9..145768cc4 100644 --- a/messages/uniworx/categories/courses/submission/de-de-formal.msg +++ b/messages/uniworx/categories/courses/submission/de-de-formal.msg @@ -68,6 +68,7 @@ Corrected: Korrigiert HeadingSubmissionEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{tid}-#{ssh}-#{csh} #{sheetName}: Abgabe editieren/anlegen SubmissionUsers: Studenten AssignedTime: Zuteilung +SubmissionPseudonym !ident-ok: Pseudonym Pseudonyms: Pseudonyme CourseCorrectionsTitle: Korrekturen für diesen Kurs SubmissionArchiveName: abgaben @@ -227,4 +228,37 @@ SubmissionColumnAuthorshipStatementTime: Zeitstempel SubmissionColumnAuthorshipStatementWording: Wortlaut SubmissionFilterAuthorshipStatementCurrent: Aktueller Wortlaut -SubmissionNoUsers: Diese Abgabe hat keine assoziierten Benutzer! \ No newline at end of file +SubmissionNoUsers: Diese Abgabe hat keine assoziierten Benutzer! + +CsvColumnCorrectionTerm: Semester des Kurses der Abgabe +CsvColumnCorrectionSchool: Institut des Kurses der Abgabe +CsvColumnCorrectionCourse: Kürzel des Kurses der Abgabe +CsvColumnCorrectionSheet: Name des Übungsblatts der Abgabe +CsvColumnCorrectionSubmission: Nummer der Abgabe (uwa…) +CsvColumnCorrectionSurname: Nachnamen der Abgebenden als Semikolon (;) separierte Liste +CsvColumnCorrectionFirstName: Vornamen der Abgebenden als Semikolon (;) separierte Liste +CsvColumnCorrectionName: Volle Namen der Abgebenden als Semikolon (;) separierte Liste +CsvColumnCorrectionMatriculation: Matrikelnummern der Abgebenden als Semikolon (;) separierte Liste +CsvColumnCorrectionEmail: E-Mail Adressen der Abgebenden als Semikolon (;) separierte Liste +CsvColumnCorrectionPseudonym: Abgabe-Pseudonyme der Abgebenden als Semikolon (;) separierte Liste +CsvColumnCorrectionSubmissionGroup: Feste Abgabegruppen der Abgebenden als Semikolon (;) separierte Liste +CsvColumnCorrectionAuthorshipStatementState: Zustände der Eigenständigkeitserklärungen ("#{toPathPiece ASMissing}", "#{toPathPiece ASOldStatement}" oder "#{toPathPiece ASExists}") als Semikolon (;) separierte Liste +CsvColumnCorrectionCorrectorName: Voller Name des Korrektors der Abgabe +CsvColumnCorrectionCorrectorEmail: E-Mail Adresse des Korrektors der Abgabe +CsvColumnCorrectionRatingDone: Bewertung abgeschlossen ("t"/"f") +CsvColumnCorrectionRatedAt: Zeitpunkt der Bewertung (ISO 8601) +CsvColumnCorrectionAssigned: Zeitpunkt der Zuteilung des Korrektors (ISO 8601) +CsvColumnCorrectionLastEdit: Zeitpunkt der letzten Änderung der Abgabe (ISO 8601) +CsvColumnCorrectionRatingPoints: Erreichte Punktezahl (Für “_{MsgSheetGradingPassBinary}” entspricht 0 “_{MsgRatingNotPassed}” und alles andere “_{MsgRatingPassed}”) +CsvColumnCorrectionRatingComment: Bewertungskommentar +CorrectionCsvSingleSubmittors: Eine Zeile pro Abgebende:n +CorrectionCsvSingleSubmittorsTip: Sollen Abgaben mit mehreren Abgebenden mehrfach vorkommen, sodass jeweils eine Zeile pro Abgebende:n enthalten ist, statt mehrere Abgebende in einer Zeile zusammenzufassen? + +CorrectionTableCsvNameSheetCorrections tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn}-abgaben +CorrectionTableCsvSheetNameSheetCorrections tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn} Abgaben +CorrectionTableCsvNameCourseCorrections tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-abgaben +CorrectionTableCsvSheetNameCourseCorrections tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh} Abgaben +CorrectionTableCsvNameCorrections: abgaben +CorrectionTableCsvSheetNameCorrections: Abgaben +CorrectionTableCsvNameCourseUserCorrections tid@TermId ssh@SchoolId csh@CourseShorthand displayName@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase displayName}-abgaben +CorrectionTableCsvSheetNameCourseUserCorrections tid@TermId ssh@SchoolId csh@CourseShorthand displayName@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase displayName} Abgaben \ No newline at end of file diff --git a/messages/uniworx/categories/courses/submission/en-eu.msg b/messages/uniworx/categories/courses/submission/en-eu.msg index f9efeb3a0..0574c4a9d 100644 --- a/messages/uniworx/categories/courses/submission/en-eu.msg +++ b/messages/uniworx/categories/courses/submission/en-eu.msg @@ -66,6 +66,7 @@ Corrected: Marked HeadingSubmissionEditHead tid ssh csh sheetName: #{tid}-#{ssh}-#{csh} #{sheetName}: Edit/Create submission SubmissionUsers: Submittors AssignedTime: Assigned +SubmissionPseudonym !ident-ok: Pseudonym Pseudonyms: Pseudonyms CourseCorrectionsTitle: Corrections for this course SubmissionArchiveName: submissions @@ -227,3 +228,36 @@ SubmissionColumnAuthorshipStatementWording: Wording SubmissionFilterAuthorshipStatementCurrent: Current wording SubmissionNoUsers: This submission has no associated users! + +CsvColumnCorrectionTerm: Term of the course of the submission +CsvColumnCorrectionSchool: School of the course of the submission +CsvColumnCorrectionCourse: Shorthand of the course of the submission +CsvColumnCorrectionSheet: Name of the sheet of the submission +CsvColumnCorrectionSubmission: Number of the submission (uwa…) +CsvColumnCorrectionSurname: Submittor's surnames, separated by semicolon (;) +CsvColumnCorrectionFirstName: Submittor's first names, separated by semicolon (;) +CsvColumnCorrectionName: Submittor's full names, separated by semicolon (;) +CsvColumnCorrectionMatriculation: Submittor's matriculations, separated by semicolon (;) +CsvColumnCorrectionEmail: Submittor's email addresses, separated by semicolon (;) +CsvColumnCorrectionPseudonym: Submittor's submission pseudonyms, separated by semicolon (;) +CsvColumnCorrectionSubmissionGroup: Submittor's submisson groups, separated by semicolon (;) +CsvColumnCorrectionAuthorshipStatementState: States of the statements of authorship ("#{toPathPiece ASMissing}", "#{toPathPiece ASOldStatement}", or "#{toPathPiece ASExists}"), separated by semicolon (;) +CsvColumnCorrectionCorrectorName: Full name of the corrector of the submission +CsvColumnCorrectionCorrectorEmail: Email address of the corrector of the submission +CsvColumnCorrectionRatingDone: Rating done ("t"/"f") +CsvColumnCorrectionRatedAt: Timestamp of rating (ISO 8601) +CsvColumnCorrectionAssigned: Timestamp of when corrector was assigned (ISO 8601) +CsvColumnCorrectionLastEdit: Timestamp of the last edit of the submission (ISO 8601) +CsvColumnCorrectionRatingPoints: Achieved points (for “_{MsgSheetGradingPassBinary}” 0 means “_{MsgRatingNotPassed}”, everything else means “_{MsgRatingPassed}”) +CsvColumnCorrectionRatingComment: Rating comment +CorrectionCsvSingleSubmittors: One row per submittor +CorrectionCsvSingleSubmittorsTip: Should submissions with multiple submittors be split into multiple rows, such that there is one row per submittor instead of having multiple submittors within one row? + +CorrectionTableCsvNameSheetCorrections tid ssh csh shn: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn}-submissions +CorrectionTableCsvSheetNameSheetCorrections tid ssh csh shn: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn} Submissions +CorrectionTableCsvNameCourseCorrections tid ssh csh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-submissions +CorrectionTableCsvSheetNameCourseCorrections tid ssh csh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh} Submissions +CorrectionTableCsvNameCorrections: submissions +CorrectionTableCsvSheetNameCorrections: Submissions +CorrectionTableCsvNameCourseUserCorrections tid ssh csh displayName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase displayName}-submissions +CorrectionTableCsvSheetNameCourseUserCorrections tid ssh csh displayName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase displayName} Submissions diff --git a/package.yaml b/package.yaml index 9b8fdec52..a2afdc4f7 100644 --- a/package.yaml +++ b/package.yaml @@ -121,6 +121,7 @@ dependencies: - http-types - jose-jwt - mono-traversable + - mono-traversable-keys - lens-aeson - systemd - streaming-commons diff --git a/src/Data/Scientific/Instances.hs b/src/Data/Scientific/Instances.hs index cee91482d..87b079e7e 100644 --- a/src/Data/Scientific/Instances.hs +++ b/src/Data/Scientific/Instances.hs @@ -9,7 +9,17 @@ import Data.Scientific import Web.PathPieces +import Text.ParserCombinators.ReadP (readP_to_S) + +import Control.Monad.Fail + instance PathPiece Scientific where toPathPiece = pack . formatScientific Fixed Nothing - fromPathPiece = readFromPathPiece + + fromPathPiece = disambiguate . readP_to_S scientificP . unpack + where + disambiguate strs = case filter (\(_, rStr) -> null rStr) strs of + [(x, _)] -> pure x + _other -> fail "fromPathPiece Scientific: Ambiguous parse" + diff --git a/src/Data/Word/Word24/Instances.hs b/src/Data/Word/Word24/Instances.hs index e1d6add1a..b80cdc620 100644 --- a/src/Data/Word/Word24/Instances.hs +++ b/src/Data/Word/Word24/Instances.hs @@ -12,6 +12,8 @@ import System.Random (Random(..)) import Data.Aeson (FromJSON(..), ToJSON(..)) import qualified Data.Aeson.Types as Aeson +import Web.PathPieces + import Data.Word.Word24 import Control.Lens @@ -19,6 +21,7 @@ import Control.Lens import Control.Monad.Fail import qualified Data.Scientific as Scientific +import Data.Scientific.Instances () import Data.Binary import Data.Bits @@ -51,6 +54,10 @@ instance FromJSON Word24 where instance ToJSON Word24 where toJSON = Aeson.Number . fromIntegral +instance PathPiece Word24 where + toPathPiece p = toPathPiece (fromIntegral p :: Word32) + fromPathPiece = Scientific.toBoundedInteger <=< fromPathPiece + -- | Big Endian instance Binary Word24 where diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 9dc051554..f85cc309a 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -308,6 +308,8 @@ embedRenderMessageVariant ''UniWorX ''ADInvalidCredentials ("InvalidCredentials" embedRenderMessage ''UniWorX ''SchoolAuthorshipStatementMode id embedRenderMessage ''UniWorX ''SheetAuthorshipStatementMode id +embedRenderMessage ''UniWorX ''AuthorshipStatementSubmissionState $ concat . ("SubmissionAuthorshipStatementState" :) . drop 1 . splitCamel + newtype ShortSex = ShortSex Sex embedRenderMessageVariant ''UniWorX ''ShortSex ("Short" <>) diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 30ef678c2..7ef122422 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -240,10 +240,11 @@ courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do courseUserSubmissionsSection :: Entity Course -> Entity User -> MaybeT Handler Widget -courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid _) = do +courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid User{..}) = do guardM . lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR - let whereClause = (E.&&.) <$> courseIs cid <*> userIs uid + let whereClause :: CorrectionTableWhere + whereClause = (E.&&.) <$> courseIs cid <*> userIs uid colonnade = mconcat -- should match getSSubsR for consistent UX [ colSelect , colSheet @@ -256,18 +257,24 @@ courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid _) = do , colCorrector , colAssigned ] -- Continue here - filterUI = Just $ \mPrev -> mconcat - [ prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgCourseCourseMembers) - , prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgTableMatrikelNr) - -- "pseudonym" TODO DB only stores Word24 - , Map.singleton "sheet-search" . maybeToList <$> aopt textField (fslI MsgTableSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev))) - , prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgTableCorrector) - , prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableHasCorrector) - , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableRatingTime) - , prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission) + filterUI = Just $ mconcat + [ filterUIUserNameEmail + , filterUIUserMatrikelnummer + , filterUIPseudonym + , filterUISheetSearch + , filterUICorrectorNameEmail + , filterUIIsAssigned + , filterUIIsRated + , filterUISubmission ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway - (cWdgt, statistics) <- lift . correctionsR' whereClause colonnade filterUI psValidator $ Map.fromList + csvSettings = Just CorrectionTableCsvSettings + { cTableCsvQualification = CorrectionTableCsvQualifySheet + , cTableCsvName = MsgCorrectionTableCsvNameCourseUserCorrections courseTerm courseSchool courseShorthand userDisplayName + , cTableCsvSheetName = MsgCorrectionTableCsvSheetNameCourseUserCorrections courseTerm courseSchool courseShorthand userDisplayName + , cTableShowCorrector = True + } + (cWdgt, statistics) <- lift . correctionsR' whereClause colonnade filterUI csvSettings psValidator $ Map.fromList [ downloadAction , assignAction (Left cid) , deleteAction diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 2a12a905c..0d25a488b 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -197,17 +197,13 @@ instance Csv.ToNamedRecord UserTableCsv where , "email" Csv..= csvUserEmail , "study-features" Csv..= csvUserStudyFeatures , "submission-group" Csv..= csvUserSubmissionGroup - ] ++ - [ let tutsStr = Text.intercalate "; " . map CI.original $ csvUserTutorials ^. _1 - in "tutorial" Csv..= tutsStr + , "tutorial" Csv..= CsvSemicolonList (csvUserTutorials ^. _1) ] ++ [ encodeUtf8 (CI.foldedCase regGroup) Csv..= (CI.original <$> mTut) | (regGroup, mTut) <- Map.toList $ csvUserTutorials ^. _2 ] ++ - [ let examsStr = Text.intercalate "; " $ map CI.original csvUserExams - in "exams" Csv..= examsStr - ] ++ - [ "registration" Csv..= csvUserRegistration + [ "exams" Csv..= CsvSemicolonList csvUserExams + , "registration" Csv..= csvUserRegistration ] ++ [ encodeUtf8 (CI.foldedCase shn) Csv..= res | (shn, res) <- Map.toList csvUserSheets diff --git a/src/Handler/Submission/Grade.hs b/src/Handler/Submission/Grade.hs index 88b181f50..d805b574e 100644 --- a/src/Handler/Submission/Grade.hs +++ b/src/Handler/Submission/Grade.hs @@ -19,7 +19,8 @@ getCorrectionsGradeR, postCorrectionsGradeR :: Handler Html getCorrectionsGradeR = postCorrectionsGradeR postCorrectionsGradeR = do uid <- requireAuthId - let whereClause = ratedBy uid + let whereClause :: CorrectionTableWhere + whereClause = ratedBy uid displayColumns = mconcat -- should match getSSubsR for consistent UX [ -- dbRow, colSchool @@ -37,15 +38,16 @@ postCorrectionsGradeR = do , colMaxPointsField , colCommentField ] -- Continue here - filterUI = Just $ \mPrev -> mconcat - [ prismAForm (singletonFilter "course" ) mPrev $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgTableCourse) - , prismAForm (singletonFilter "term" ) mPrev $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTableTerm) - , prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgTableCourseSchool) - , Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgTableSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev))) - , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableRatingTime) - , prismAForm (singletonFilter "rating-visible" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingDone) - , prismAForm (singletonFilter "rating" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` pointsField) (fslI MsgColumnRatingPoints) - , Map.singleton "comment" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgRatingComment) (Just <$> listToMaybe =<< (Map.lookup "comment" =<< mPrev)) + filterUI = Just $ mconcat + [ filterUICourse courseOptions + , filterUITerm termOptions + , filterUISchool schoolOptions + , filterUISheetSearch + , filterUIPseudonym + , filterUIIsRated + -- , flip (prismAForm $ singletonFilter "rating-visible" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingDone) + , filterUIRating + , filterUIComment ] courseOptions = runDB $ do courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) @@ -60,9 +62,9 @@ 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 + (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI Nothing 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 345cadd99..d9976e95c 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -1,3 +1,6 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} + module Handler.Submission.List ( getCorrectionsR, postCorrectionsR , getCCorrectionsR, postCCorrectionsR @@ -5,10 +8,13 @@ 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 + , 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 + , CorrectionTableData, CorrectionTableWhere , ActionCorrections(..), downloadAction, deleteAction, assignAction, autoAssignAction + , CorrectionTableCsvQualification(..), CorrectionTableCsvSettings(..) ) where import Import hiding (link) @@ -18,7 +24,6 @@ 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 @@ -28,7 +33,8 @@ 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 Database.Esqueleto.Internal.Internal as IE (From) + +import qualified Data.Conduit.Combinators as C import Text.Hamlet (ihamletFile) @@ -36,399 +42,741 @@ import Database.Persist.Sql (updateWhereCount) import Data.List (genericLength) +import qualified Data.Csv as Csv -newtype CorrectionTableFilterProj = CorrectionTableFilterProj + +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 = CorrectionTableExpr -> E.SqlExpr (E.Value Bool) -type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Maybe UTCTime, Map UserId (User, Maybe Pseudonym, Maybe SubmissionGroupName), CryptoFileNameSubmission, Bool {- Access to non-anonymous submission data -}) -correctionsTableQuery :: CorrectionTableWhere -> (CorrectionTableExpr -> v) -> CorrectionTableExpr -> E.SqlQuery v -correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = 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 - E.where_ $ whereClause t - return $ returnStatement t +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 + ) -lastEditQuery :: IE.From (E.SqlExpr (Entity SubmissionEdit)) - => E.SqlExpr (Entity Submission) -> E.SqlExpr (E.Value (Maybe UTCTime)) -lastEditQuery submission = E.subSelectMaybe $ E.from $ \edit -> do - E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId - return $ E.max_ $ edit E.^. SubmissionEditTime -queryCourse :: CorrectionTableExpr -> E.SqlExpr (Entity Course) -queryCourse = $(sqlIJproj 3 1) . $(sqlLOJproj 2 1) +queryCourse :: Getter CorrectionTableExpr (E.SqlExpr (Entity Course)) +queryCourse = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 2 1) -querySubmission :: CorrectionTableExpr -> E.SqlExpr (Entity Submission) -querySubmission = $(sqlIJproj 3 3) . $(sqlLOJproj 2 1) +querySheet :: Getter CorrectionTableExpr (E.SqlExpr (Entity Sheet)) +querySheet = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 2 1) -queryCorrector :: CorrectionTableExpr -> E.SqlExpr (Maybe (Entity User)) -queryCorrector = $(sqlLOJproj 2 2) +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 ((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) +ratedBy uid = views querySubmission $ (E.==. E.justVal uid) . (E.^. SubmissionRatingBy) courseIs :: CourseId -> CorrectionTableWhere -courseIs cid (( course `E.InnerJoin` _sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = course E.^. CourseId E.==. E.val cid +courseIs cid = views queryCourse $ (E.==. E.val cid) . (E.^. CourseId) sheetIs :: Key Sheet -> CorrectionTableWhere -sheetIs shid ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetId E.==. E.val shid +sheetIs shid = views querySheet $ (E.==. E.val shid) . (E.^. SheetId) userIs :: Key User -> CorrectionTableWhere -userIs uid ((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = E.exists . E.from $ \submissionUser -> +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) - $ \DBRow{ dbrOutput } -> - textCell $ termToText $ unTermKey $ dbrOutput ^. _3 . _3 -- kurze Semsterkürzel +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) - $ \DBRow{ dbrOutput } -> let course = dbrOutput ^. _3 in - anchorCell (TermSchoolCourseListR (course ^. _3) (course ^. _4)) [whamlet|#{unSchoolKey (course ^. _4)}|] +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) - $ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid),_ , _, _, _, _) } -> courseCellCL (tid,sid,csh) +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) $ \row -> - let sheet = row ^. _dbrOutput . _2 - course= row ^. _dbrOutput . _3 - tid = course ^. _3 - ssh = course ^. _4 - csh = course ^. _2 - shn = sheetName $ entityVal sheet - in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|_{shn}|] +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) $ \case - DBRow{ dbrOutput = (_, _, _, Nothing , _, _, _, _) } -> cell mempty - DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _, _, _, _) } -> userCell userDisplayName userSurname +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) - $ \DBRow{ dbrOutput=(_, sheet, course, _, _,_, cid, _) } -> - let csh = course ^. _2 - tid = course ^. _3 - ssh = course ^. _4 - shn = sheetName $ entityVal sheet - in anchorCellC $cacheIdentHere (CSubmissionR tid ssh csh shn cid SubShowR) (toPathPiece cid) +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 $ \DBRow{ dbrOutput=(_, _, _, _, _, _, cid, _) } -> return cid +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) $ \DBRow{ dbrOutput=(_, _, course, _, _, users, _, hasAccess) } -> - let - csh = course ^. _2 - tid = course ^. _3 - ssh = course ^. _4 - link cid = CourseR tid ssh csh $ CUserR cid - protoCell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo, _)) -> - anchorCellCM $cacheIdentHere (link <$> encrypt userId) $ case mPseudo of - Nothing -> nameWidget userDisplayName userSurname - Just p -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review _PseudonymText p})|] - in if | hasAccess -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] - | otherwise -> mempty +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) $ \DBRow{ dbrOutput=(_, _, (_, csh, tid, ssh), _, _, users, _, hasAccess) } -> - let protoCell = listCell (Map.toList $ Map.mapMaybe (\x@(User{userMatrikelnummer}, _, _) -> (x,) <$> assertM (not . null) userMatrikelnummer) users) $ \(userId, (_, matr)) -> anchorCellCM $cacheIdentHere (CourseR tid ssh csh . CUserR <$> encrypt userId) matr - in if | hasAccess -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] - | otherwise -> mempty +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) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, _, _, _, users, _, hasAccess) } -> - let protoCell = listCell (nubOrdOn (view _2) . Map.toList $ Map.mapMaybe (view _3) users) $ \(_, sGroup) -> cell $ toWidget sGroup - in if | hasAccess - , is _RegisteredGroups sheetGrouping - -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] - | otherwise - -> mempty +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. IsDBTable m (a, SheetTypeSummary SqlBackendKey) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary SqlBackendKey)) -colRating = sortable (Just "rating") (i18nCell MsgTableRating) $ \DBRow{ dbrOutput=(Entity subId sub@Submission{..}, Entity _ Sheet{..}, course, _, _, _, _, _) } -> - let csh = course ^. _2 - tid = course ^. _3 - ssh = course ^. _4 - -- shn = sheetName +colRating :: forall m a a'. (IsDBTable m a, a ~ (a', SheetTypeSummary SqlBackendKey)) => Colonnade Sortable CorrectionTableData (DBCell m a) +colRating = colRating' _2 - mkRoute = do - cid <- encrypt subId - return $ CSubmissionR tid ssh csh sheetName 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 (_2 :: Lens' (a, SheetTypeSummary SqlBackendKey) (SheetTypeSummary SqlBackendKey)) summary - ] +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) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _, _, _) } -> - maybe mempty dateTimeCell submissionRatingAssigned +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) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _, _, _) } -> - maybe mempty dateTimeCell submissionRatingTime +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) $ \DBRow{ dbrOutput=(_, _, _, _, _, users, _, _) } -> let - lCell = listCell (catMaybes $ view (_2 . _2) <$> Map.toList users) $ \pseudo -> - cell [whamlet|#{review _PseudonymText pseudo}|] - in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] +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 :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (Bool, a, b) CorrectionTableData))) -colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell id - (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId) - (\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _, _, _, _) } mkUnique -> over (_1.mapped) (_1 .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done)) +colRatedField :: a' ~ (Bool, a, b) => Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a' CorrectionTableData))) +colRatedField = colRatedField' _1 -colPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData))) -colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id - (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId) - (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _, _, _, _) } mkUnique -> case sheetType of - NotGraded -> pure $ over (_1.mapped) (_2 .~) (FormSuccess Nothing, mempty) - _other -> over (_1.mapped) (_2 .~) . over _2 fvWidget <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints) +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 :: _ => Colonnade Sortable CorrectionTableData (DBCell m (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData))) -colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgTableSheetType) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{sheetCourse, sheetType}, _, _, _, _, _, _) } -> cell $ do +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 - tr <- getTranslate - toWidget $ sheetTypeDesc tr + toWidget . sheetTypeDesc =<< getTranslate -colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) -colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id - (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId) - (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment)) +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) $ - \DBRow{ dbrOutput=(_, _, _, _, mbLastEdit, _, _, _) } -> maybe mempty dateTimeCell mbLastEdit +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) -> _ -> PSValidator m x -> DBParams m x -> DB (DBResult m x) -makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams = do - let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _ - dbtSQLQuery = correctionsTableQuery whereClause - (\((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> - let crse = ( course E.^. CourseName :: E.SqlExpr (E.Value CourseName) - , course E.^. CourseShorthand - , course E.^. CourseTerm - , course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId) - ) - in (submission, sheet, crse, corrector, lastEditQuery submission) - ) - 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 + => 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 - 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 + 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 - 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 - nonAnonymousAccess <- lift . lift $ or2M - (return $ not sheetAnonymousCorrection) - (hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR) + lastEdit <- view queryLastEdit - return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess) - dbTable psValidator DBTable - { dbtSQLQuery - , dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) -> submission E.^. SubmissionId - , dbtColonnade - , dbtProj - , dbtSorting = Map.fromList - [ ( "term" - , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm - ) - , ( "school" - , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseSchool - ) - , ( "course" - , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand - ) - , ( "sheet" - , SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName - ) - , ( "corrector" - , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserSurname - ) - , ( "rating" - , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints - ) - , ( "sheet-type" - , SortColumns $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> - [ 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)) + 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 ] - ) - , ( "israted" - , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> E.not_ . E.isNothing $ submission E.^. SubmissionRatingTime - ) - , ( "ratingtime" - , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingTime - ) - , ( "assignedtime" - , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingAssigned - ) - , ( "submittors" - , SortProjected . comparing $ \DBRow{ dbrOutput = (_, _, _, _, _, submittors, _, hasAccess) } -> guardOn @Maybe hasAccess . fmap ((userSurname &&& userDisplayName) . view _1) $ Map.elems submittors - ) - , ( "submittors-matriculation" - , SortProjected . comparing $ \DBRow{ dbrOutput = (_, _, _, _, _, submittors, _, hasAccess) } -> guardOn @Maybe hasAccess . fmap (view $ _1 . _userMatrikelnummer) $ Map.elems submittors - ) - , ( "submittors-group" - , SortProjected . comparing $ \DBRow{ dbrOutput = (_, _, _, _, _, submittors, _, hasAccess) } -> guardOn @Maybe hasAccess . fmap (view _3) $ Map.elems submittors - ) - , ( "comment" -- sorting by comment specifically requested by correctors to easily see submissions to be done - , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingComment - ) - , ( "last-edit" - , SortColumn $ \((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) -> lastEditQuery submission - ) - , ( "submission" - , SortProjected . comparing $ toPathPiece . view (_dbrOutput . _7) - ) - ] - , dbtFilter = Map.fromList - [ ( "term" - , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if - | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids) - ) - , ( "school" - , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) sids -> if - | Set.null sids -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> course E.^. CourseSchool `E.in_` E.valList (Set.toList sids) - ) - , ( "course" - , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) cshs -> if - | Set.null cshs -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList cshs) - ) - , ( "sheet" - , FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> if - | Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns) - ) - , ( "sheet-search" - , FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> case getLast (shns :: Last (CI Text)) of - Nothing -> E.val True :: E.SqlExpr (E.Value Bool) - Just needle -> sheet E.^. SheetName `E.ilike` (E.%) E.++. E.val needle E.++. (E.%) - ) - , ( "corrector" - , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if - | Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> corrector E.?. UserEmail `E.in_` E.justList (E.valList . catMaybes $ Set.toList emails) - E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False) - ) - , ( "isassigned" - , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of - Nothing -> E.val True :: E.SqlExpr (E.Value Bool) - Just True -> E.isJust $ submission E.^. SubmissionRatingBy - Just False-> E.isNothing $ submission E.^. SubmissionRatingBy - ) - , ( "israted" - , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of - Nothing -> E.val True :: E.SqlExpr (E.Value Bool) - Just True -> E.isJust $ submission E.^. SubmissionRatingTime - Just False-> E.isNothing $ submission E.^. SubmissionRatingTime - ) - , ( "corrector-name-email" -- corrector filter does not work for text-filtering - , FilterColumn $ E.anyFilter - [ E.mkContainsFilterWith Just $ queryCorrector >>> (E.?. UserSurname) - , E.mkContainsFilterWith Just $ queryCorrector >>> (E.?. UserDisplayName) - , E.mkContainsFilterWith (Just . CI.mk) $ queryCorrector >>> (E.?. UserEmail) + 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) ] - ) - , ( "user-name-email" - , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do + , 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_ $ querySubmission table E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission - E.where_ $ (\f -> f user $ Set.singleton needle) $ E.anyFilter + 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) - ] - ) - , ( "user-matriclenumber" - , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do + , 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_ $ querySubmission table E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission - E.where_ $ (\f -> f user $ Set.singleton needle) $ - E.mkContainsFilter (E.^. UserMatrikelnummer) - ) - , ( "submission-group" - , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do + 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_ $ queryCourse table E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse - E.where_ $ (\f -> f submissionGroup $ Set.singleton needle) $ - E.mkContainsFilter (E.^. SubmissionGroupName) - ) - , ( "rating-visible" - , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of - Nothing -> E.val True :: E.SqlExpr (E.Value Bool) - Just True -> E.isJust $ submission E.^. SubmissionRatingTime - Just False-> E.isNothing $ submission E.^. SubmissionRatingTime - ) - , ( "rating" - , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) pts -> if - | Set.null pts -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> E.maybe (E.val False :: E.SqlExpr (E.Value Bool)) (\p -> p `E.in_` E.valList (Set.toList pts)) (submission E.^. SubmissionRatingPoints) - ) - , ( "comment" - , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) comm -> case getLast (comm :: Last Text) of - Nothing -> E.val True :: E.SqlExpr (E.Value Bool) - Just needle -> E.maybe (E.val False :: E.SqlExpr (E.Value Bool)) (E.isInfixOf $ E.val needle) (submission E.^. SubmissionRatingComment) - ) - , ( "submission" - , FilterProjected (_corrProjFilterSubmission ?~) - -- , FilterProjected $ \(DBRow{..} :: CorrectionTableData) (criteria :: Set Text) -> - -- let cid = map CI.mk . unpack . toPathPiece $ dbrOutput ^. _7 - -- criteria' = map CI.mk . unpack <$> Set.toList criteria - -- in any (`isInfixOf` cid) criteria' - ) - ] - , dbtFilterUI = fromMaybe mempty dbtFilterUI - , dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI } - , dbtParams - , dbtIdent = "corrections" :: Text - , dbtCsvEncode = noCsvEncode - , dbtCsvDecode = Nothing - , dbtExtraReps = [] - } + 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 @@ -447,16 +795,16 @@ data ActionCorrectionsData = CorrDownloadData SubmissionDownloadAnonymous Submis | CorrAutoSetCorrectorData SheetId | CorrDeleteData -correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent -correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do - (table, statistics) <- correctionsR' whereClause displayColumns dbtFilterUI psValidator actions +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' :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary SqlBackendKey) -correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do +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) @@ -465,7 +813,7 @@ correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do } ((actionRes', statistics), table) <- runDB $ - makeCorrectionsTable whereClause displayColumns dbtFilterUI psValidator DBParamsForm + makeCorrectionsTable whereClause displayColumns dbtFilterUI csvSettings psValidator DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Just $ SomeRoute currentRoute , dbParamsFormAttrs = [] @@ -605,7 +953,12 @@ 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") @@ -654,7 +1007,8 @@ getCorrectionsR, postCorrectionsR :: Handler TypedContent getCorrectionsR = postCorrectionsR postCorrectionsR = do uid <- requireAuthId - let whereClause = ratedBy uid + let whereClause :: CorrectionTableWhere + whereClause = ratedBy uid colonnade = mconcat [ colSelect , colSchool @@ -670,13 +1024,14 @@ postCorrectionsR = do , colRating , colRated ] -- Continue here - filterUI = Just $ \mPrev -> mconcat - [ prismAForm (singletonFilter "course" ) mPrev $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgTableCourse) - , prismAForm (singletonFilter "term" ) mPrev $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTableTerm) - , prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgTableCourseSchool) - , Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgTableSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev))) - , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableRatingTime) - , prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission) + 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) @@ -693,41 +1048,65 @@ postCorrectionsR = do & restrictAnonymous & defaultSorting [SortDescBy "ratingtime", SortAscBy "assignedtime" ] & defaultFilter (singletonMap "israted" [toPathPiece False]) - correctionsR whereClause colonnade filterUI psValidator $ Map.fromList + + 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 _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh - let whereClause = courseIs cid - colonnade = mconcat -- should match getSSubsR for consistent UX - [ colSelect - , colSheet - , colSMatrikel - , colSubmittors - , colSGroups - , colSubmissionLink - , colLastEdit - , colRating - , colRated - , colCorrector - , colAssigned + (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 $ \mPrev -> mconcat - [ prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgTableCourseMembers) - , prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgTableMatrikelNr) - -- "pseudonym" TODO DB only stores Word24 - , Map.singleton "sheet-search" . maybeToList <$> aopt textField (fslI MsgTableSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev))) - , prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgTableCorrector) - , prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableHasCorrector) - , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableRatingTime) - , prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgTableSubmissionGroup) - , prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission) + 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 - correctionsR whereClause colonnade filterUI psValidator $ Map.fromList + 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) , deleteAction @@ -736,31 +1115,45 @@ 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 - let whereClause = sheetIs shid - colonnade = mconcat -- should match getCCorrectionsR for consistent UX - [ colSelect - , colSMatrikel - , colSubmittors - , colSubmissionLink - , colLastEdit - , colRating - , colRated - , colCorrector - , colAssigned + (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 $ \mPrev -> mconcat - [ prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgTableCourseMembers) - , prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgTableMatrikelNr) - , prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgTableCorrector) - , prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableHasCorrector) - , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableRatingTime) - , prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgTableSubmissionGroup) - , prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission) - -- "pseudonym" TODO DB only stores Word24 + 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 - correctionsR whereClause colonnade filterUI psValidator $ Map.fromList + 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 diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index e89b05c47..ef0d0a2e6 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -22,8 +22,6 @@ import Handler.Utils.StudyFeatures.Parse import qualified Data.Csv as Csv -import qualified Data.ByteString as ByteString - import qualified Data.Set as Set import Data.RFC5051 (compareUnicode) @@ -65,7 +63,7 @@ instance Csv.ToField UserTableStudyFeature where [] $ ShortStudyFieldType userTableFieldType instance Csv.ToField UserTableStudyFeatures where - toField = ByteString.intercalate "; " . map Csv.toField . view _UserTableStudyFeatures + toField = Csv.toField . CsvSemicolonList . view _UserTableStudyFeatures userTableStudyFeatureSort :: UserTableStudyFeature -> UserTableStudyFeature diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 1d5e5ab7a..b59d1d723 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,44 @@ correctionInvisibleWidget tid ssh csh shn cID (Entity subId sub) = runMaybeT $ d tellPoint CorrectionInvisibleExamUnfinished return $ notification NotificationBroad =<< messageIconWidget Warning IconInvisible $(widgetFile "submission-correction-invisible") + + +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 diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index a3471822d..50e666ed0 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -45,7 +45,8 @@ module Handler.Utils.Table.Pagination , maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM' , anchorCellC, anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM' , cellTooltip - , listCell, listCell' + , listCell, listCell', listCellOf, listCellOf' + , ilistCell, ilistCell', ilistCellOf, ilistCellOf' , formCell, DBFormResult(..), getDBFormResult , dbSelect , (&) @@ -1170,7 +1171,6 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db && all (is _Just) filterSql psLimit' = bool PagesizeAll psLimit selectPagesize - rows' <- E.select . E.from $ \t -> do res <- dbtSQLQuery t @@ -1183,10 +1183,10 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db Nothing | PagesizeLimit l <- psLimit' , selectPagesize + , hasn't (_FormSuccess . _DBCsvExport) csvMode -> do - unless (has (_FormSuccess . _DBCsvExport) csvMode) $ - E.limit l - E.offset (psPage * l) + E.limit l + E.offset $ psPage * l Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps _other -> return () Map.foldr (\fc expr -> maybe (return ()) (E.where_ . ($ t)) fc >> expr) (return ()) filterSql @@ -1793,12 +1793,30 @@ listCell :: (IsDBTable m a, MonoFoldable mono) => mono -> (Element mono -> DBCel listCell = listCell' . return listCell' :: (IsDBTable m a, MonoFoldable mono) => WriterT a m mono -> (Element mono -> DBCell m a) -> DBCell m a -listCell' mkXS mkCell = review dbCell . ([], ) $ do +listCell' mkXS mkCell = ilistCell' (otoList <$> mkXS) $ const mkCell + +ilistCell :: (IsDBTable m a, MonoFoldableWithKey mono) => mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a +ilistCell = ilistCell' . return + +ilistCell' :: (IsDBTable m a, MonoFoldableWithKey mono) => WriterT a m mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a +ilistCell' mkXS mkCell = review dbCell . ([], ) $ do xs <- mkXS - cells <- forM (toList xs) $ - \(view dbCell . mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget + cells <- forM (otoKeyedList xs) $ + \(view dbCell . uncurry mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget return $(widgetFile "table/cell/list") +listCellOf :: IsDBTable m a' => Getting (Endo [a]) s a -> s -> (a -> DBCell m a') -> DBCell m a' +listCellOf l x = listCell (x ^.. l) + +listCellOf' :: IsDBTable m a' => Getting (Endo [a]) s a -> WriterT a' m s -> (a -> DBCell m a') -> DBCell m a' +listCellOf' l mkX = listCell' (toListOf l <$> mkX) + +ilistCellOf :: IsDBTable m a' => IndexedGetting i (Endo [(i, a)]) s a -> s -> (i -> a -> DBCell m a') -> DBCell m a' +ilistCellOf l x = listCell (itoListOf l x) . uncurry + +ilistCellOf' :: IsDBTable m a' => IndexedGetting i (Endo [(i, a)]) s a -> WriterT a' m s -> (i -> a -> DBCell m a') -> DBCell m a' +ilistCellOf' l mkX = listCell' (itoListOf l <$> mkX) . uncurry + newtype DBFormResult i a r = DBFormResult (Map i (r, a -> a)) instance Functor (DBFormResult i a) where diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 79a6a45ca..ad0ac8f97 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -24,6 +24,7 @@ import ClassyPrelude.Yesod as Import , authorizationCheck , mkMessage, mkMessageFor, mkMessageVariant , YesodBreadcrumbs(..) + , MonoZip(..), ozipWith ) import UnliftIO.Async.Utils as Import @@ -235,6 +236,8 @@ import Data.Scientific as Import (Scientific, formatScientific) import Data.MultiSet as Import (MultiSet) +import Data.MonoTraversable.Keys as Import + import Control.Monad.Trans.RWS (RWST) diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 76d427ed9..8f9a3bd28 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -133,6 +133,8 @@ instance ToJSON TermIdentifier where instance FromJSON TermIdentifier where parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText +pathPieceCsv ''TermIdentifier + {- Must be defined in a later module: termField :: Field (HandlerT UniWorX IO) TermIdentifier termField = checkMMap (return . termFromText) termToText textField diff --git a/src/Model/Types/Submission.hs b/src/Model/Types/Submission.hs index 49dfd12ce..676b64776 100644 --- a/src/Model/Types/Submission.hs +++ b/src/Model/Types/Submission.hs @@ -130,3 +130,27 @@ pseudonymWords = folding pseudonymFragments :: Fold Text [PseudonymWord] pseudonymFragments = folding $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters) + + +instance PathPiece Pseudonym where + toPathPiece = review _PseudonymText + fromPathPiece t + | Just p <- t ^? _PseudonymText = Just p + | Just n <- fromPathPiece t = Just $ Pseudonym n + | otherwise = Nothing + +pathPieceCsv ''Pseudonym + + +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 +pathPieceCsv ''AuthorshipStatementSubmissionState +pathPieceJSON ''AuthorshipStatementSubmissionState diff --git a/src/Utils/Csv.hs b/src/Utils/Csv.hs index 7070720b1..850ef9af1 100644 --- a/src/Utils/Csv.hs +++ b/src/Utils/Csv.hs @@ -10,6 +10,7 @@ module Utils.Csv , toCsvRendered , toDefaultOrderedCsvRendered , csvRenderedToXlsx, Xlsx, Xlsx.fromXlsx + , CsvSemicolonList(..) ) where import ClassyPrelude hiding (lookup) @@ -39,6 +40,19 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.CaseInsensitive as CI +import qualified Data.Binary.Builder as Builder +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Attoparsec.ByteString as Attoparsec + +import qualified Data.Csv.Parser as Csv +import qualified Data.Csv.Builder as Csv + +import qualified Data.Vector as Vector + +import Data.Char (ord) + +import Control.Monad.Fail + deriving instance Typeable CsvParseError instance Exception CsvParseError @@ -114,3 +128,27 @@ csvRenderedToXlsx sheetName CsvRendered{..} = def & Xlsx.atSheet sheetName ?~ (d addValues = flip foldMap (zip [2..] csvRenderedData) $ \(r, nr) -> flip foldMap (zip [1..] $ toList csvRenderedHeader) $ \(c, hBS) -> case HashMap.lookup hBS nr of Nothing -> mempty Just vBS -> Endo $ Xlsx.cellValueAtRC (r, c) ?~ Xlsx.CellText (decodeUtf8 vBS) + + +newtype CsvSemicolonList a = CsvSemicolonList { unCsvSemicolonList :: [a] } + deriving stock (Read, Show, Generic, Typeable) + deriving newtype (Eq, Ord) + +instance ToField a => ToField (CsvSemicolonList a) where + toField (CsvSemicolonList xs) = dropEnd 2 . LBS.toStrict . Builder.toLazyByteString $ Csv.encodeRecordWith encOpts fs + where + fs = map toField xs + encOpts = defaultEncodeOptions + { encDelimiter = fromIntegral $ ord ';' + , encQuoting = case fs of + [fStr] | null fStr -> QuoteAll + _other -> QuoteMinimal + , encUseCrLf = True + } + +instance FromField a => FromField (CsvSemicolonList a) where + parseField f + | null f = pure $ CsvSemicolonList [] + | otherwise = fmap CsvSemicolonList . mapM parseField . Vector.toList <=< either fail return $ Attoparsec.parseOnly (Csv.record sep) f + where + sep = fromIntegral $ ord ';' diff --git a/templates/i18n/changelog/corrections-csv-export.de-de-formal.hamlet b/templates/i18n/changelog/corrections-csv-export.de-de-formal.hamlet new file mode 100644 index 000000000..8a44b1939 --- /dev/null +++ b/templates/i18n/changelog/corrections-csv-export.de-de-formal.hamlet @@ -0,0 +1,2 @@ +$newline never +Tabellen von Übungsblattabgaben können nun als CSV exportiert werden diff --git a/templates/i18n/changelog/corrections-csv-export.en-eu.hamlet b/templates/i18n/changelog/corrections-csv-export.en-eu.hamlet new file mode 100644 index 000000000..70a14aa63 --- /dev/null +++ b/templates/i18n/changelog/corrections-csv-export.en-eu.hamlet @@ -0,0 +1,2 @@ +$newline never +Tables of exercise sheet submissions can now be exported as CSV diff --git a/test/Data/Scientific/InstancesSpec.hs b/test/Data/Scientific/InstancesSpec.hs new file mode 100644 index 000000000..0fb95c4f3 --- /dev/null +++ b/test/Data/Scientific/InstancesSpec.hs @@ -0,0 +1,10 @@ +module Data.Scientific.InstancesSpec where + +import TestImport +import Data.Scientific + + +spec :: Spec +spec = modifyMaxSuccess (* 10) $ + lawsCheckHspec (Proxy @Scientific) + [ pathPieceLaws ] diff --git a/test/Utils/CsvSpec.hs b/test/Utils/CsvSpec.hs new file mode 100644 index 000000000..b4f1c16c0 --- /dev/null +++ b/test/Utils/CsvSpec.hs @@ -0,0 +1,38 @@ +module Utils.CsvSpec where + +import TestImport + +import Utils.Csv + +import Data.Csv (toField, runParser, parseField) + +import Data.Char (ord) +import qualified Data.ByteString as BS + + +deriving newtype instance Arbitrary a => Arbitrary (CsvSemicolonList a) + + +spec :: Spec +spec = modifyMaxSuccess (* 10) . parallel $ do + lawsCheckHspec (Proxy @(CsvSemicolonList ByteString)) + [ csvFieldLaws ] + describe "CsvSemicolonList" $ do + let + test :: [ByteString] -> ByteString -> Expectation + test (CsvSemicolonList -> x) t = do + toField x `shouldBe` t + runParser (parseField t) `shouldBe` Right x + it "is transparent" . property $ \(bs :: ByteString) + -> let expectTransparent = BS.all (`notElem` [34, 10, 13, fromIntegral $ ord ';']) bs + && not (BS.null bs) + in expectTransparent ==> test [bs] bs + it "behaves as expected on some examples" $ do + test ["foo"] "foo" + test ["foo", "bar"] "foo;bar" + test [] "" + test [""] "\"\"" + test ["", ""] ";" + test ["foo", ""] "foo;" + test ["", "foo"] ";foo" + test ["", "", "foo", ""] ";;foo;"