From 6f291b2e6893554193732b059758794fe2b7fa51 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 30 Mar 2021 15:49:53 +0200 Subject: [PATCH] feat(course-users-table): json export --- src/Handler/Course/Users.hs | 93 ++++++++++++++++++++++++++++++++++--- 1 file changed, 87 insertions(+), 6 deletions(-) diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index d81ad892a..cd3b6f2df 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -35,6 +35,10 @@ import Database.Persist.Sql (updateWhereCount) import Handler.Sheet.PersonalisedFiles +import qualified Data.Text.Lazy as Lazy (Text) + +import qualified Data.Aeson as JSON + type UserTableExpr = ( E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant) @@ -249,6 +253,58 @@ userTableCsvHeader showSex tuts sheets UserCsvExportData{..} = Csv.header $ hasEmptyRegGroup = has (folded . _entityVal . _tutorialRegGroup . _Nothing) tuts regGroups = Set.toList $ setOf (folded . _entityVal . _tutorialRegGroup . _Just) tuts +data UserTableJson = UserTableJson + { jsonUserSurname :: UserSurname + , jsonUserFirstName :: UserFirstName + , jsonUserName :: UserDisplayName + , jsonUserSex :: Maybe (Maybe Sex) + , jsonUserMatriculation :: Maybe UserMatriculation + , jsonUserEmail :: UserEmail + , jsonUserStudyFeatures :: UserTableStudyFeatures + , jsonUserSubmissionGroup :: Maybe SubmissionGroupName + , jsonUserRegistration :: UTCTime + , jsonUserNote :: Maybe Lazy.Text + , jsonUserTutorials :: Set TutorialName + , jsonUserTutorialGroups :: Map (CI Text) (Maybe TutorialName) + , jsonUserExams :: Set ExamName + , jsonUserSheets :: Map SheetName UserTableJsonSheetResult + } deriving (Generic, Typeable) + +data UserTableJsonSheetResult = UserTableJsonSheetResult + { jsonSheetType :: SheetType UserTableJsonSheetTypeExamPartRef + , jsonPoints :: Maybe Points + } deriving (Generic, Typeable) + +data UserTableJsonSheetTypeExamPartRef = UserTableJsonSheetTypeExamPartRef + { jsonExam :: ExamName + , jsonExamPart :: ExamPartNumber + } deriving (Generic, Typeable) + +deriveToJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''UserTableJsonSheetTypeExamPartRef + +deriveToJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''UserTableJsonSheetResult + +instance ToJSON UserTableJson where + toJSON UserTableJson{..} = JSON.object $ catMaybes + [ pure $ "surname" JSON..= jsonUserSurname + , pure $ "first-name" JSON..= jsonUserFirstName + , pure $ "name" JSON..= jsonUserName + , ("sex" JSON..=) <$> jsonUserSex + , ("matriculation" JSON..=) <$> jsonUserMatriculation + , pure $ "email" JSON..= jsonUserEmail + , ("study-features" JSON..=) <$> assertM' (views _Wrapped $ not . onull) jsonUserStudyFeatures + , ("submission-group" JSON..=) <$> jsonUserSubmissionGroup + , pure $ "registration" JSON..= jsonUserRegistration + , ("note" JSON..=) <$> jsonUserNote + , ("tutorials" JSON..=) <$> assertM' (not . onull) jsonUserTutorials + , ("tutorial-groups" JSON..=) <$> assertM' (any $ is _Just) jsonUserTutorialGroups + , ("exams" JSON..=) <$> assertM' (not . onull) jsonUserExams + , ("sheets" JSON..=) <$> assertM' (any $ has (to jsonPoints . _Just)) jsonUserSheets + ] data CourseUserAction = CourseUserSendMail | CourseUserRegisterTutorial @@ -485,13 +541,38 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do , dbtCsvHeader = return . Vector.filter csvColumns' . userTableCsvHeader showSex tutorials sheets . fromMaybe def , dbtCsvExampleData = Nothing } - where - userNote = runMaybeT $ do - noteId <- MaybeT . preview $ _userTableNote . _Just - CourseUserNote{..} <- lift . lift $ getJust noteId - return courseUserNoteNote + userNote = runMaybeT $ do + noteId <- MaybeT . preview $ _userTableNote . _Just + CourseUserNote{..} <- lift . lift $ getJust noteId + return courseUserNoteNote dbtCsvDecode = Nothing - dbtExtraReps = withCsvExtraRep dbtCsvSheetName (UserCsvExportData True) dbtCsvEncode [] + dbtExtraReps = withCsvExtraRep dbtCsvSheetName (UserCsvExportData True) dbtCsvEncode + [ DBTExtraRep $ toPrettyJSON <$> repUserJson, DBTExtraRep $ toYAML <$> repUserJson + ] + + repUserJson :: ConduitT (E.Value UserId, UserTableData) Void DB (Map CryptoUUIDUser UserTableJson) + repUserJson = C.foldMapM $ \(E.Value uid, res) -> Map.singleton <$> encrypt uid <*> mkUserTableJson res + where + mkUserTableJson res' = flip runReaderT res' $ UserTableJson + <$> view (hasUser . _userSurname) + <*> view (hasUser . _userFirstName) + <*> view (hasUser . _userDisplayName) + <*> views (hasUser . _userSex) (guardOn showSex) + <*> view (hasUser . _userMatrikelnummer) + <*> view (hasUser . _userEmail) + <*> view _userStudyFeatures + <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName) + <*> view _userTableRegistration + <*> (fmap markupInput <$> userNote) + <*> view (_userTutorials . _1 . folded . to (Set.singleton . tutorialName . entityVal)) + <*> views (_userTutorials . _2) (over (traverse . _Just) $ tutorialName . entityVal) + <*> view (_userExams . folded . to (Set.singleton . examName . entityVal)) + <*> (fmap (fmap $ uncurry UserTableJsonSheetResult) . traverseOf (traverse . _1) (lift . resolveSheetType') =<< view _userSheets) + resolveSheetType' sType = do + sType' <- resolveSheetType cid sType + for sType' $ \(Entity _ ExamPart{..}) -> do + Exam{..} <- getJust examPartExam + return $ UserTableJsonSheetTypeExamPartRef examName examPartNumber over _1 postprocess <$> dbTable psValidator DBTable{..} where postprocess :: FormResult (First act', DBFormResult UserId Bool UserTableData) -> FormResult (act', Set UserId)