diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index ac81efc23..7cb07f419 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1907,6 +1907,9 @@ ExternalExamUserCsvName tid@TermId ssh@SchoolId coursen@CourseName examn@ExamNam CourseApplicationsTableCsvName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungen ParticipantsCsvName tid@TermId ssh@SchoolId: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-kursteilnehmer +CourseUserCsvIncludeSheets: Übungsblätter +CourseUserCsvIncludeSheetsTip: Soll die exportierte CSV-Datei zusätzlich eine Spalte pro Übungsblatt enthalten? + CsvColumnsExplanationsLabel: Spalten- & Zellenformat CsvColumnsExplanationsTip: Bedeutung und Format der in der CSV-Datei enthaltenen Spalten CsvColumnExamUserSurname: Nachname(n) des Teilnehmers diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 6fe436270..2a866b9de 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -1906,6 +1906,9 @@ ExternalExamUserCsvName tid@TermId ssh@SchoolId coursen@CourseName examn@ExamNam CourseApplicationsTableCsvName tid ssh csh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-applications ParticipantsCsvName tid ssh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-participants +CourseUserCsvIncludeSheets: Exercise sheets +CourseUserCsvIncludeSheetsTip: Should the exportet CSV-file additionally contain one column per exercise sheet? + CsvColumnsExplanationsLabel: Column & cell format CsvColumnsExplanationsTip: Meaning and format of the columns contained in imported and exported CSV files CsvColumnExamUserSurname: Participant's surname diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 4297bb253..f7454ab38 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -220,6 +220,7 @@ data UserTableCsv = UserTableCsv , csvUserNote :: Maybe Html , csvUserTutorials :: ([TutorialName], Map (CI Text) (Maybe TutorialName)) , csvUserExams :: [ExamName] + , csvUserSheets :: Map SheetName (SheetType, Maybe Points) } deriving (Eq, Ord, Read, Show, Generic, Typeable) makeLenses_ ''UserTableCsv @@ -254,7 +255,11 @@ instance Csv.ToNamedRecord UserTableCsv where in "exams" Csv..= examsStr ] ++ [ "registration" Csv..= csvUserRegistration - , "note" Csv..= csvUserNote + ] ++ + [ encodeUtf8 (CI.foldedCase shn) Csv..= res + | (shn, res) <- Map.toList csvUserSheets + ] ++ + [ "note" Csv..= csvUserNote ] instance CsvColumnsExplained UserTableCsv where csvColumnsExplanations _ = mconcat @@ -276,22 +281,24 @@ instance CsvColumnsExplained UserTableCsv where single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget single k v = singletonMap k [whamlet|_{v}|] -newtype UserCsvExportData = UserCsvExportData +data UserCsvExportData = UserCsvExportData { csvUserSimplifiedFeaturesOfStudy :: Bool + , csvUserIncludeSheets :: Bool } deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Default UserCsvExportData where - def = UserCsvExportData True + def = UserCsvExportData True False -userTableCsvHeader :: Bool -> UserCsvExportData -> [Entity Tutorial] -> Csv.Header -userTableCsvHeader showSex UserCsvExportData{..} tuts = Csv.header $ +userTableCsvHeader :: Bool -> [Entity Tutorial] -> [Entity Sheet] -> UserCsvExportData -> Csv.Header +userTableCsvHeader showSex tuts sheets UserCsvExportData{..} = Csv.header $ [ "name" ] ++ [ "sex" | showSex ] ++ [ "matriculation", "email" ] ++ bool (pure "study-features") ["field", "degree", "semester"] csvUserSimplifiedFeaturesOfStudy ++ [ "tutorial" | hasEmptyRegGroup ] ++ map (encodeUtf8 . CI.foldedCase) regGroups ++ - [ "exams", "registration", "note" - ] + [ "exams", "registration" ] ++ + guardOnM csvUserIncludeSheets [ encodeUtf8 $ CI.foldedCase sheetName | Entity _ Sheet{..} <- sheets ] ++ + [ "note" ] where hasEmptyRegGroup = has (folded . _entityVal . _tutorialRegGroup . _Nothing) tuts regGroups = Set.toList $ setOf (folded . _entityVal . _tutorialRegGroup . _Just) tuts @@ -345,6 +352,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do csvName <- getMessageRender <*> pure (MsgCourseUserCsvName courseTerm courseSchool courseShorthand) tutorials <- selectList [ TutorialCourse ==. cid ] [] exams <- selectList [ ExamCourse ==. cid ] [] + sheets <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom] -- -- psValidator has default sorting and filtering showSex <- getShowSex let dbtIdent = "courseUsers" :: Text @@ -354,10 +362,10 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do dbtProj = traverse $ \(user, participant, E.Value userNoteId, (feature,degree,terms), subGroup) -> do tuts'' <- selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] [] exams' <- selectList [ ExamRegistrationUser ==. entityKey user ] [] - subs' <- E.select . E.from $ \(sheet `E.InnerJoin` (submission `E.InnerJoin` submissionUser)) -> do - E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId - E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet - E.&&. submissionUser E.^. SubmissionUserUser E.==. E.val (entityKey user) + subs' <- E.select . E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do + E.on $ submissionUser E.?. SubmissionUserSubmission E.==. submission E.?. SubmissionId + E.on $ E.just (sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet + E.&&. submissionUser E.?. SubmissionUserUser E.==. E.just (E.val $ entityKey user) E.where_ $ sheet E.^. SheetCourse E.==. E.val cid return ( sheet E.^. SheetName , ( sheet E.^. SheetType @@ -369,7 +377,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') tutorials tuts = foldr (\tut@(Entity _ Tutorial{..}) -> maybe (over _1 $ cons tut) (over _2 . flip (Map.insertWith (<|>)) (Just tut)) tutorialRegGroup) ([], Map.fromSet (const Nothing) regGroups) tuts' exs = filter (\(Entity eId _) -> any ((== eId) . examRegistrationExam . entityVal) exams') exams - subs = Map.fromList $ mapMaybe (over (mapped . _2 . _2) (submissionRatingPoints . entityVal) . assertM' (views (_2 . _2 . _entityVal) submissionRatingDone) . over _1 E.unValue . over (_2 . _1) E.unValue) subs' + subs = Map.fromList $ map (over (_2 . _2) (views _entityVal submissionRatingPoints <=< assertM (views _entityVal submissionRatingDone)) . over _1 E.unValue . over (_2 . _1) E.unValue) subs' return (user, participant, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms), tuts, exs, subGroup, subs) dbtColonnade = colChoices dbtSorting = mconcat @@ -406,6 +414,17 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do ) , single $ ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName)) , single $ ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState)) + , mconcat + [ single ( SortingKey $ "sheet-" <> sheetName + , SortColumn $ \(queryUser -> user) -> E.subSelectMaybe . E.from $ \(submission `E.InnerJoin` submissionUser) -> do + E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission + E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId + E.where_ $ submission E.^. SubmissionSheet E.==. E.val shId + return $ submission E.^. SubmissionRatingPoints + + ) + | Entity shId Sheet{..} <- sheets + ] ] where single = uncurry Map.singleton dbtFilter = mconcat @@ -478,6 +497,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do return $ DBTCsvEncode { dbtCsvExportForm = UserCsvExportData <$> apopt checkBoxField (fslI MsgUserSimplifiedFeaturesOfStudyCsv & setTooltip MsgUserSimplifiedFeaturesOfStudyCsvTip) (Just $ csvUserSimplifiedFeaturesOfStudy def) + <*> apopt checkBoxField (fslI MsgCourseUserCsvIncludeSheets & setTooltip MsgCourseUserCsvIncludeSheetsTip) (Just $ csvUserIncludeSheets def) , dbtCsvDoEncode = \UserCsvExportData{..} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $ UserTableCsv <$> view (hasUser . _userDisplayName) @@ -520,9 +540,10 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do <*> (over (_2.traverse._Just) (tutorialName . entityVal) . over (_1.traverse) (tutorialName . entityVal) <$> view _userTutorials) -- <*> (over (_2.traverse._Just) (examName . entityVal) . over (_1.traverse) (examName . entityVal) <$> view _userExams) <*> (over traverse (examName . entityVal) <$> view _userExams) + <*> view _userSheets , dbtCsvName = unpack csvName , dbtCsvNoExportData = Nothing - , dbtCsvHeader = return . Vector.filter csvColumns' . flip (userTableCsvHeader showSex) tutorials . fromMaybe def + , dbtCsvHeader = return . Vector.filter csvColumns' . userTableCsvHeader showSex tutorials sheets . fromMaybe def , dbtCsvExampleData = Nothing } where diff --git a/src/Handler/Submission/Assign.hs b/src/Handler/Submission/Assign.hs index 1a9f93c00..53aec90d0 100644 --- a/src/Handler/Submission/Assign.hs +++ b/src/Handler/Submission/Assign.hs @@ -93,8 +93,8 @@ assignHandler tid ssh csh cid assignSids = do groupsPossible = let foldFun (Entity _ Sheet{sheetGrouping=sgr}) acc = acc || sgr /= NoGroups in List.foldr foldFun False sheetList - assignSheetNames = fmap sheetName $ mapMaybe (\sid -> Map.lookup sid sheets) assignSids - assignSheetNames' = fmap sheetName $ mapMaybe (\sid -> Map.lookup sid sheets) assignSids' + assignSheetNames = sheetName <$> mapMaybe (`Map.lookup` sheets) assignSids + assignSheetNames' = sheetName <$> mapMaybe (`Map.lookup` sheets) assignSids' assignButtons = Map.fromSet (maybe BtnSubmissionsAssignAll BtnSubmissionsAssign) $ Set.fromList . bool (Nothing :) id (null sheetList) $ map Just assignSheetNames' @@ -102,7 +102,7 @@ assignHandler tid ssh csh cid assignSids = do fmap (over _1 (asum . fmap (hoistMaybe =<<)) . over _2 (, csrf) . unzip) . for assignButtons $ \btn -> mopt (buttonField btn) "" Nothing -- plan or assign unassigned submissions for given sheets - let buildA :: (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational)) -> SheetId -> DB (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational)) + let buildA :: Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational) -> SheetId -> DB (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational)) buildA acc sid = maybeT (return acc) $ do let shn = sheetName $ sheets ! sid -- is sheet closed? @@ -151,7 +151,7 @@ assignHandler tid ssh csh cid assignSids = do ) -- Lecturers may correct without being enlisted SheetCorrectors, so fetch all names act_correctors <- E.select . E.distinct . E.from $ \(submission `E.InnerJoin` user) -> do - E.on $ submission E.^. SubmissionRatingBy E.==. (E.just $ user E.^. UserId) + E.on $ submission E.^. SubmissionRatingBy E.==. E.just (user E.^. UserId) E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds return (submission E.^. SubmissionSheet, user) let correctorMap :: Map UserId (User, Map SheetName SheetCorrector) @@ -262,7 +262,7 @@ assignHandler tid ssh csh cid assignSids = do let headingShort = MsgMenuCorrectionsAssign headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign - unassignableSheets = filter (\shn -> Map.notMember shn assignment) assignSheetNames + unassignableSheets = filter (`Map.notMember` assignment) assignSheetNames unless (null unassignableSheets) $ addMessageI Warning $ MsgSheetsUnassignable $ Text.intercalate ", " $ fmap CI.original unassignableSheets siteLayoutMsg headingShort $ do diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index 08067c9ab..99b5e521d 100644 --- a/src/Model/Types/Sheet.hs +++ b/src/Model/Types/Sheet.hs @@ -19,6 +19,8 @@ import qualified Data.Map as Map import Text.Blaze (Markup) import Data.Maybe (fromJust) + +import qualified Data.Csv as Csv data SheetGrading @@ -26,7 +28,7 @@ data SheetGrading | PassPoints { maxPoints, passingPoints :: Points } | PassBinary -- non-zero means passed | PassAlways - deriving (Eq, Read, Show, Generic) + deriving (Eq, Ord, Read, Show, Generic) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece @@ -112,7 +114,7 @@ data SheetType | Normal { grading :: SheetGrading } | Bonus { grading :: SheetGrading } | Informational { grading :: SheetGrading } - deriving (Eq, Read, Show, Generic) + deriving (Eq, Ord, Read, Show, Generic) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece @@ -121,6 +123,7 @@ deriveJSON defaultOptions } ''SheetType derivePersistFieldJSON ''SheetType +makeLenses_ ''SheetType makePrisms ''SheetType data SheetTypeSummary = SheetTypeSummary @@ -321,3 +324,13 @@ showCompactCorrectorLoad Load{..} CorrectorNormal | byProportion == 0 = tutoria tutorialText = case byTutorial of Nothing -> mempty Just True -> "(T)" Just False -> "T" + +instance Csv.ToField (SheetType, Maybe Points) where + toField (_, Nothing) = mempty + toField (sType, Just res) + | Just passed <- flip gradingPassed res =<< preview _grading sType + = bool "not-passed" "passed" passed + | has _grading sType, hasn't (_grading . _passingBound) sType + = Csv.toField res + toField (_, Just _) + = "submitted" diff --git a/src/Utils.hs b/src/Utils.hs index 60e87f633..bdf3376c1 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -709,6 +709,9 @@ assertM_ f x = guard . f =<< x assertM' :: Alternative m => (a -> Bool) -> a -> m a assertM' f x = x <$ guard (f x) +assertMM' :: MonadPlus m => (a -> m Bool) -> a -> m a +assertMM' f x = x <$ guardM (f x) + guardOn :: forall m a. Alternative m => Bool -> a -> m a guardOn b x = x <$ guard b diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 8b0bde094..6fe3c61a5 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -145,8 +145,6 @@ makeLenses_ ''SubmissionGroup makeLenses_ ''SheetGrading -makeLenses_ ''SheetType - makePrisms ''SheetGroup makePrisms ''AuthResult diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 6e5f2ac55..8205128d6 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -1048,9 +1048,9 @@ fillDb = do , sheetType = Normal $ PassPoints 12 6 , sheetGrouping = Arbitrary 3 , sheetMarkingText = Nothing - , sheetVisibleFrom = Just $ termTime False Winter shNr False Monday toMidnight - , sheetActiveFrom = Just $ termTime False Winter (succ shNr) False Monday toMidnight - , sheetActiveTo = Just $ termTime False Winter (succ shNr) False Sunday beforeMidnight + , sheetVisibleFrom = Just $ termTime False Winter (fromInteger shNr) False Monday toMidnight + , sheetActiveFrom = Just $ termTime False Winter (fromInteger $ succ shNr) False Monday toMidnight + , sheetActiveTo = Just $ termTime False Winter (fromInteger $ succ shNr) False Sunday beforeMidnight , sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing , sheetHintFrom = Nothing , sheetSolutionFrom = Nothing