fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(course-participants): csv export exercise sheets

Browse Source
This commit is contained in:
Gregor Kleen 2020-06-14 18:15:58 +02:00
parent 33d9d7dbc3
commit 06f47c59b4
8 changed files with 66 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
messages/uniworx/de-de-formal.msg
View File

@ -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

3
messages/uniworx/en-eu.msg
View File

@ -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

47
src/Handler/Course/Users.hs
View File

@ -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

10
src/Handler/Submission/Assign.hs
View File

@ -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

17
src/Model/Types/Sheet.hs
View File

@ -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"

3
src/Utils.hs
View File

@ -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

2
src/Utils/Lens.hs
View File

@ -145,8 +145,6 @@ makeLenses_ ''SubmissionGroup
makeLenses_ ''SheetGrading
makeLenses_ ''SheetType
makePrisms ''SheetGroup
makePrisms ''AuthResult

6
test/Database/Fill.hs
View File

@ -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