From 2b153c1863752ddaf7a8f476fc9696448fed17e6 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 2 Dec 2019 15:51:46 +0100 Subject: [PATCH] feat(external-exams): auditing --- src/Audit/Types.hs | 30 +++++++++++++++++++++++++ src/Handler/Course/LecturerInvite.hs | 2 +- src/Handler/Course/ParticipantInvite.hs | 2 +- src/Handler/Exam/CorrectorInvite.hs | 2 +- src/Handler/Exam/RegistrationInvite.hs | 2 +- src/Handler/ExamOffice/Users.hs | 2 +- src/Handler/ExternalExam/Edit.hs | 22 ++++++++++++------ src/Handler/ExternalExam/New.hs | 30 ++++++++++++++++--------- src/Handler/ExternalExam/StaffInvite.hs | 7 +++++- src/Handler/Sheet.hs | 2 +- src/Handler/Submission.hs | 2 +- src/Handler/Tutorial/TutorInvite.hs | 2 +- src/Handler/Users.hs | 2 +- src/Handler/Utils/Invitations.hs | 4 ++-- 14 files changed, 82 insertions(+), 29 deletions(-) diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 8f1520ce3..c065c1f36 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -139,6 +139,36 @@ data Transaction { transactionTutorial :: TutorialId } + | TransactionExternalExamEdit + { transactionExternalExam :: ExternalExamId + } + + | TransactionExternalExamOfficeSchoolEdit + { transactionExternalExam :: ExternalExamId + , transactionSchool :: SchoolId + } + | TransactionExternalExamOfficeSchoolDelete + { transactionExternalExam :: ExternalExamId + , transactionSchool :: SchoolId + } + + | TransactionExternalExamStaffEdit + { transactionExternalExam :: ExternalExamId + , transactionUser :: UserId + } + | TransactionExternalExamStaffDelete + { transactionExternalExam :: ExternalExamId + , transactionUser :: UserId + } + | TransactionExternalExamStaffInviteEdit + { transactionExternalExam :: ExternalExamId + , transactionEmail :: UserEmail + } + | TransactionExternalExamStaffInviteDelete + { transactionExternalExam :: ExternalExamId + , transactionEmail :: UserEmail + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions diff --git a/src/Handler/Course/LecturerInvite.hs b/src/Handler/Course/LecturerInvite.hs index 44b27ce64..9d52eeede 100644 --- a/src/Handler/Course/LecturerInvite.hs +++ b/src/Handler/Course/LecturerInvite.hs @@ -75,7 +75,7 @@ lecturerInvitationConfig = InvitationConfig{..} where toJunction jLecturerType = (JunctionLecturer{..}, ()) lFs = fslI MsgLecturerType & setTooltip MsgCourseLecturerRightsIdentical - invitationInsertHook _ _ _ _ = id + invitationInsertHook _ _ _ _ _ = id invitationSuccessMsg (Entity _ Course{..}) (Entity _ Lecturer{..}) = do MsgRenderer mr <- getMsgRenderer return . SomeMessage $ MsgLecturerInvitationAccepted (mr lecturerType) courseShorthand diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 280a69d6f..99558d12f 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -91,7 +91,7 @@ participantInvitationConfig = InvitationConfig{..} studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure Nothing - invitationInsertHook _ _ CourseParticipant{..} _ act = do + invitationInsertHook _ _ _ CourseParticipant{..} _ act = do res <- act audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser return res diff --git a/src/Handler/Exam/CorrectorInvite.hs b/src/Handler/Exam/CorrectorInvite.hs index d207ff9ef..2cb691360 100644 --- a/src/Handler/Exam/CorrectorInvite.hs +++ b/src/Handler/Exam/CorrectorInvite.hs @@ -71,7 +71,7 @@ examCorrectorInvitationConfig = InvitationConfig{..} return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized invitationForm _ _ _ = pure (JunctionExamCorrector, ()) - invitationInsertHook _ _ _ _ = id + invitationInsertHook _ _ _ _ _ = id invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName invitationUltDest (Entity _ Exam{..}) _ = do Course{..} <- get404 examCourse diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs index cfd109f94..be7decbf4 100644 --- a/src/Handler/Exam/RegistrationInvite.hs +++ b/src/Handler/Exam/RegistrationInvite.hs @@ -97,7 +97,7 @@ examRegistrationInvitationConfig = InvitationConfig{..} fieldRes <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature) Nothing return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes (True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing) - invitationInsertHook (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do + invitationInsertHook _ (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do whenIsJust mField $ \cpField -> do insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField Nothing queueDBJob . JobQueueNotification $ NotificationCourseRegistered examRegistrationUser examCourse diff --git a/src/Handler/ExamOffice/Users.hs b/src/Handler/ExamOffice/Users.hs index 3e688c936..fd03b912b 100644 --- a/src/Handler/ExamOffice/Users.hs +++ b/src/Handler/ExamOffice/Users.hs @@ -74,7 +74,7 @@ examOfficeUserInvitationConfig = InvitationConfig{..} return InvitationTokenConfig{..} invitationRestriction _ _ = return Authorized invitationForm _ _ _ = pure (JunctionExamOfficeUser, ()) - invitationInsertHook _ _ ExamOfficeUser{..} _ act = do + invitationInsertHook _ _ _ ExamOfficeUser{..} _ act = do res <- act audit $ TransactionExamOfficeUserAdd examOfficeUserOffice examOfficeUserUser return res diff --git a/src/Handler/ExternalExam/Edit.hs b/src/Handler/ExternalExam/Edit.hs index 276a94815..76a58dc90 100644 --- a/src/Handler/ExternalExam/Edit.hs +++ b/src/Handler/ExternalExam/Edit.hs @@ -53,23 +53,31 @@ postEEEditR tid ssh coursen examn = do , externalExamShowGrades = eefShowGrades } when (is _Nothing replaceRes) $ do + audit $ TransactionExternalExamEdit eeId + forM_ (eefStaff `setSymmDiff` staff) $ \change -> if | change `Set.member` eefStaff -> case change of - Left invEmail -> + Left invEmail -> do + audit $ TransactionExternalExamStaffInviteEdit eeId invEmail sinkInvitationsF externalExamStaffInvitationConfig [(invEmail, eeId, (InvDBDataExternalExamStaff, InvTokenDataExternalExamStaff))] - Right staffUid -> - insert_ $ ExternalExamStaff staffUid eeId + Right staffUid -> do + audit $ TransactionExternalExamStaffEdit eeId staffUid + insert_ $ ExternalExamStaff staffUid eeId | otherwise -> case change of - Left invEmail -> + Left invEmail -> do + audit $ TransactionExternalExamStaffInviteDelete eeId invEmail deleteInvitation @ExternalExamStaff eeId invEmail - Right staffUid -> + Right staffUid -> do + audit $ TransactionExternalExamStaffDelete eeId staffUid deleteBy $ UniqueExternalExamStaff eeId staffUid forM_ (eefOfficeSchools `setSymmDiff` schools) $ \change -> if - | change `Set.member` eefOfficeSchools -> + | change `Set.member` eefOfficeSchools -> do + audit $ TransactionExternalExamOfficeSchoolEdit eeId change insert_ $ ExternalExamOfficeSchool change eeId - | otherwise -> + | otherwise -> do + audit $ TransactionExternalExamOfficeSchoolDelete eeId change deleteBy $ UniqueExternalExamOfficeSchool eeId change return replaceRes diff --git a/src/Handler/ExternalExam/New.hs b/src/Handler/ExternalExam/New.hs index b8403b674..36a8cf6ed 100644 --- a/src/Handler/ExternalExam/New.hs +++ b/src/Handler/ExternalExam/New.hs @@ -31,19 +31,29 @@ postEExamNewR = do , externalExamShowGrades = eefShowGrades } whenIsJust insertRes $ \eeId -> do - insertMany_ - [ ExternalExamOfficeSchool{..} - | externalExamOfficeSchoolSchool <- Set.toList eefOfficeSchools - , externalExamOfficeSchoolSchool /= eefSchool - , let externalExamOfficeSchoolExam = eeId - ] + audit $ TransactionExternalExamEdit eeId + + let eefOfficeSchools' = do + externalExamOfficeSchoolSchool <- Set.toList eefOfficeSchools + guard $ externalExamOfficeSchoolSchool /= eefSchool + let externalExamOfficeSchoolExam = eeId + return ExternalExamOfficeSchool{..} + insertMany_ eefOfficeSchools' + forM_ eefOfficeSchools' $ \ExternalExamOfficeSchool{..} -> + audit $ TransactionExternalExamOfficeSchoolEdit eeId externalExamOfficeSchoolSchool let (invites, adds) = partitionEithers $ Set.toList eefStaff - insertMany_ [ ExternalExamStaff{..} - | externalExamStaffUser <- adds - , let externalExamStaffExam = eeId - ] + eefStaff' = do + externalExamStaffUser <- adds + let externalExamStaffExam = eeId + return ExternalExamStaff{..} + insertMany_ eefStaff' + forM_ eefStaff' $ \ExternalExamStaff{..} -> + audit $ TransactionExternalExamStaffEdit eeId externalExamStaffUser + sinkInvitationsF externalExamStaffInvitationConfig $ map (, eeId, (InvDBDataExternalExamStaff, InvTokenDataExternalExamStaff)) invites + forM_ invites $ \invEmail -> + audit $ TransactionExternalExamStaffInviteEdit eeId invEmail return insertRes case insertRes of diff --git a/src/Handler/ExternalExam/StaffInvite.hs b/src/Handler/ExternalExam/StaffInvite.hs index e4ebfb056..0e9414913 100644 --- a/src/Handler/ExternalExam/StaffInvite.hs +++ b/src/Handler/ExternalExam/StaffInvite.hs @@ -63,7 +63,12 @@ externalExamStaffInvitationConfig = InvitationConfig{..} return $ InvitationTokenConfig itAuthority Nothing (Just Nothing) Nothing invitationRestriction _ _ = return Authorized invitationForm _ (InvDBDataExternalExamStaff, _) _ = pure (JunctionExternalExamStaff, ()) - invitationInsertHook _ _ _ _ = id + invitationInsertHook invEmail _ _ ExternalExamStaff{..} _ act = do + res <- act + + audit $ TransactionExternalExamStaffInviteDelete externalExamStaffExam invEmail + audit $ TransactionExternalExamStaffEdit externalExamStaffExam externalExamStaffUser + return res invitationSuccessMsg (Entity _ ExternalExam{..}) (Entity _ ExternalExamStaff{}) = return . SomeMessage $ MsgExternalExamStaffInvitationAccepted externalExamCourseName externalExamExamName invitationUltDest (Entity _ ExternalExam{..}) _ = return . SomeRoute $ EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEShowR diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index ff7cc41ea..93b6f64ba 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -892,7 +892,7 @@ correctorInvitationConfig = InvitationConfig{..} return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure $ (JunctionSheetCorrector cLoad cState, ()) - invitationInsertHook _ _ _ _ = id + invitationInsertHook _ _ _ _ _ = id invitationSuccessMsg (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName invitationUltDest (Entity _ Sheet{..}) _ = do Course{..} <- get404 sheetCourse diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 9167d417a..2551f6164 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -114,7 +114,7 @@ submissionUserInvitationConfig = InvitationConfig{..} return InvitationTokenConfig{..} invitationRestriction _ _ = return Authorized invitationForm _ _ _ = pure (JunctionSubmissionUser, ()) - invitationInsertHook _ _ _ _ = id + invitationInsertHook _ _ _ _ _ = id invitationSuccessMsg (Entity _ Submission{..}) _ = do Sheet{..} <- getJust submissionSheet return . SomeMessage $ MsgSubmissionUserInvitationAccepted sheetName diff --git a/src/Handler/Tutorial/TutorInvite.hs b/src/Handler/Tutorial/TutorInvite.hs index e78953b67..bcb002f4d 100644 --- a/src/Handler/Tutorial/TutorInvite.hs +++ b/src/Handler/Tutorial/TutorInvite.hs @@ -68,7 +68,7 @@ tutorInvitationConfig = InvitationConfig{..} return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized invitationForm _ _ _ = pure (JunctionTutor, ()) - invitationInsertHook _ _ _ _ = id + invitationInsertHook _ _ _ _ _ = id invitationSuccessMsg (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName invitationUltDest (Entity _ Tutorial{..}) _ = do Course{..} <- get404 tutorialCourse diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 2a580d03f..27c59d743 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -579,7 +579,7 @@ functionInvitationConfig = InvitationConfig{..} return InvitationTokenConfig{..} invitationRestriction _ _ = return Authorized invitationForm _ (_, InvTokenDataUserFunction{..}) _ = pure $ (JunctionUserFunction invTokenUserFunctionFunction, ()) - invitationInsertHook _ _ _ _ = id + invitationInsertHook _ _ _ _ _ = id invitationSuccessMsg (Entity _ School{..}) (Entity _ UserFunction{..}) = do MsgRenderer mr <- getMsgRenderer return . SomeMessage . MsgSchoolFunctionInvitationAccepted schoolName $ mr userFunctionFunction diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index 99bd99691..5e3489ac0 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -134,7 +134,7 @@ data InvitationConfig junction = forall formCtx. InvitationConfig -- ^ Additional restrictions to check before allowing an user to redeem an invitation token , invitationForm :: Entity (InvitationFor junction) -> InvitationData junction -> Key User -> AForm (YesodDB UniWorX) (InvitableJunction junction, formCtx) -- ^ Assimilate the additional data entered by the redeeming user - , invitationInsertHook :: forall a. Entity (InvitationFor junction) -> InvitationData junction -> junction -> formCtx -> (YesodJobDB UniWorX a -> YesodJobDB UniWorX a) + , invitationInsertHook :: forall a. UserEmail -> Entity (InvitationFor junction) -> InvitationData junction -> junction -> formCtx -> (YesodJobDB UniWorX a -> YesodJobDB UniWorX a) -- ^ Perform additional actions before or after insertion of the junction into the database , invitationSuccessMsg :: Entity (InvitationFor junction) -> Entity junction -> DB (SomeMessage UniWorX) -- ^ What to tell the redeeming user after accepting the invitation @@ -402,7 +402,7 @@ invitationR' InvitationConfig{..} = liftHandler $ do return . Just $ SomeRoute HomeR Just (jData, formCtx) -> do let junction = review _InvitableJunction (invitee, fid, jData) - mResult <- invitationInsertHook fEnt iData junction formCtx $ insertUniqueEntity junction + mResult <- invitationInsertHook itEmail fEnt iData junction formCtx $ insertUniqueEntity junction case mResult of Nothing -> invalidArgsI [MsgInvitationCollision] Just res -> do