feat(course-users-table): json export

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)