diff --git a/models/audit b/models/audit index 8569afd8a..5c9c10ef7 100644 --- a/models/audit +++ b/models/audit @@ -2,11 +2,11 @@ TransactionLog time UTCTime instance InstanceId - initiator (CI Text) Maybe -- Case-insensitive user-identifier associated with performing this action + initiator UserIdent Maybe -- Case-insensitive user-identifier associated with performing this action remote IP Maybe -- Remote party that triggered this action via HTTP info Value -- JSON-encoded `Transaction` -- Best guess of users affected by a change in database-state at time of transaction TransactionLogAffected transaction TransactionLogId - user (CI Text) -- Case-insensitive user-identifier + user UserIdent -- Case-insensitive user-identifier UniqueTransactionLogAffected transaction user \ No newline at end of file diff --git a/src/Audit.hs b/src/Audit.hs index 866efdd10..a3c7d623a 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -1,5 +1,6 @@ module Audit ( module Audit.Types + , AuditException(..) , audit, audit' , AuditRemoteException(..) , getRemote @@ -23,7 +24,6 @@ import qualified Net.IP as IP data AuditRemoteException = ARUnsupportedSocketKind deriving (Show, Generic, Typeable) - instance Exception AuditRemoteException @@ -36,6 +36,13 @@ getRemote = do _other -> throwM ARUnsupportedSocketKind +data AuditException + = AuditRemoteException AuditRemoteException + | AuditUserNotFound UserId + deriving (Show, Generic, Typeable) +instance Exception AuditException + + audit :: ( AuthId site ~ Key User , AuthEntity site ~ User , IsSqlBackend (YesodPersistBackend site) @@ -50,19 +57,19 @@ audit :: ( AuthId site ~ Key User -- -- - `transactionLogTime` is now -- - `transactionLogInitiator` is currently logged in user (or none) --- - `transactionLogRequest` is current HTTP-Request +-- - `transactionLogRemote` is determined from current HTTP-Request audit (toJSON -> transactionLogInfo) affected = do uid <- liftHandlerT maybeAuthId transactionLogTime <- liftIO getCurrentTime transactionLogInstance <- getsYesod $ view instanceID - transactionLogInitiator <- for uid $ fmap userIdent . getJust - transactionLogRemote <- Just <$> getRemote + transactionLogInitiator <- for uid $ \uid' -> maybe (throwM $ AuditUserNotFound uid') (return . userIdent) =<< get uid' + transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote tlId <- insert TransactionLog{..} - affectedUsers <- forM affected getJust - insertMany_ [ TransactionLogAffected tlId aident | aident <- userIdent <$> affectedUsers ] + affectedUsers <- forM affected $ \uid' -> maybe (throwM $ AuditUserNotFound uid') (return . userIdent) =<< get uid' + insertMany_ $ map (TransactionLogAffected tlId) affectedUsers audit' :: ( AuthId site ~ Key User , AuthEntity site ~ User diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 64d1ff0d3..5ffabcd09 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -9,11 +9,25 @@ import Model import Data.Aeson.TH import Utils.PathPiece -{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} - data Transaction - = TransactionTermEdit { transactionTerm :: Key Term } + = TransactionTermEdit + { transactionTerm :: TermIdentifier + } + | TransactionExamRegister + { transactionTerm :: TermIdentifier + , transactionSchool :: SchoolShorthand + , transactionCourse :: CourseShorthand + , transactionExam :: ExamName + , transactionUser :: UserIdent + } + | TransactionExamDeregister + { transactionTerm :: TermIdentifier + , transactionSchool :: SchoolShorthand + , transactionCourse :: CourseShorthand + , transactionExam :: ExamName + , transactionUser :: UserIdent + } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index 0cd76224a..001ba2dba 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -806,7 +806,7 @@ postEInviteR = error "postEInviteR" postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html postERegisterR tid ssh csh examn = do - uid <- requireAuthId + Entity uid User{..} <- requireAuth Entity eId Exam{..} <- runDB $ fetchExam tid ssh csh examn @@ -814,11 +814,15 @@ postERegisterR tid ssh csh examn = do formResult btnResult $ \case BtnRegister -> do - runDB . void . insert $ ExamRegistration eId uid Nothing + runDB $ do + insert_ $ ExamRegistration eId uid Nothing + audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent addMessageI Success $ MsgExamRegisteredSuccess examn redirect $ CExamR tid ssh csh examn EShowR BtnDeregister -> do - runDB . deleteBy $ UniqueExamRegistration eId uid + runDB $ do + deleteBy $ UniqueExamRegistration eId uid + audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent addMessageI Success $ MsgExamDeregisteredSuccess examn redirect $ CExamR tid ssh csh examn EShowR diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index cf645101c..f2e27c298 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -185,7 +185,7 @@ termEditHandler term = do -- term <- runDB $ get $ TermKey termName runDB $ do repsert tid res - audit' $ TransactionTermEdit tid + audit' . TransactionTermEdit $ unTermKey tid -- VOR INTERNATIONALISIERUNG: -- let tid = termToText $ termName res -- let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert." diff --git a/src/Model.hs b/src/Model.hs index c97b1a68e..b63b39a19 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -64,4 +64,4 @@ instance ToMarkup (Key Term) where toMarkup = toMarkup . termToText . unTermKey instance ToMessage (Key Term) where - toMessage = termToText . unTermKey \ No newline at end of file + toMessage = termToText . unTermKey diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index c7d18cd54..c0cd4a30b 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -25,6 +25,7 @@ type CourseShorthand = CI Text type SheetName = CI Text type MaterialName = CI Text type UserEmail = CI Email +type UserIdent = CI Text type TutorialName = CI Text type ExamName = CI Text type ExamPartName = CI Text @@ -33,4 +34,4 @@ type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString type InstanceId = UUID type ClusterId = UUID type TokenId = UUID -type TermCandidateIncidence = UUID \ No newline at end of file +type TermCandidateIncidence = UUID