From f602b79e7a72c2dced293d5218a4f7bea98c610c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 6 Aug 2019 09:51:05 +0200 Subject: [PATCH] feat(audit): introduce id-based format --- models/audit | 9 +--- src/Audit.hs | 29 ++---------- src/Audit/Types.hs | 24 +++++----- src/Handler/Exam/AddUser.hs | 2 +- src/Handler/Exam/Register.hs | 4 +- src/Handler/Exam/RegistrationInvite.hs | 6 +-- src/Handler/Exam/Users.hs | 15 ++++--- src/Handler/Term.hs | 2 +- src/Model/Migration.hs | 62 +++++++++++++++++++++++++- src/Model/Migration/Types.hs | 37 ++++++++++++--- src/Utils/DB.hs | 14 ++++-- 11 files changed, 137 insertions(+), 67 deletions(-) diff --git a/models/audit b/models/audit index 5c9c10ef7..ecff023f5 100644 --- a/models/audit +++ b/models/audit @@ -2,11 +2,6 @@ TransactionLog time UTCTime instance InstanceId - initiator UserIdent Maybe -- Case-insensitive user-identifier associated with performing this action + initiator UserId Maybe -- User 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 UserIdent -- Case-insensitive user-identifier - UniqueTransactionLogAffected transaction user \ No newline at end of file + info Value -- JSON-encoded `Transaction` \ No newline at end of file diff --git a/src/Audit.hs b/src/Audit.hs index a148da1c5..ac8270edf 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -1,7 +1,7 @@ module Audit ( module Audit.Types , AuditException(..) - , audit, audit' + , audit , AuditRemoteException(..) , getRemote ) where @@ -61,7 +61,6 @@ getRemote = do data AuditException = AuditRemoteException AuditRemoteException - | AuditUserNotFound UserId deriving (Show, Generic, Typeable) instance Exception AuditException @@ -77,37 +76,17 @@ audit :: ( AuthId (HandlerSite m) ~ Key User , HasAppSettings (HandlerSite m) ) => Transaction -- ^ Transaction to record - -> [UserId] -- ^ Affected users -> ReaderT (YesodPersistBackend (HandlerSite m)) m () -- ^ Log a transaction using information available from `HandlerT`: -- -- - `transactionLogTime` is now -- - `transactionLogInitiator` is currently logged in user (or none) -- - `transactionLogRemote` is determined from current HTTP-Request -audit (toJSON -> transactionLogInfo) affected = do - uid <- liftHandlerT maybeAuthId +audit (toJSON -> transactionLogInfo) = do transactionLogTime <- liftIO getCurrentTime transactionLogInstance <- getsYesod $ view instanceID - transactionLogInitiator <- for uid $ \uid' -> maybe (throwM $ AuditUserNotFound uid') (return . userIdent) =<< get uid' + transactionLogInitiator <- liftHandlerT maybeAuthId transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote - tlId <- insert TransactionLog{..} - - affectedUsers <- forM affected $ \uid' -> maybe (throwM $ AuditUserNotFound uid') (return . userIdent) =<< get uid' - insertMany_ $ map (TransactionLogAffected tlId) affectedUsers - -audit' :: ( AuthId (HandlerSite m) ~ Key User - , AuthEntity (HandlerSite m) ~ User - , IsSqlBackend (YesodPersistBackend (HandlerSite m)) - , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m)) - , HasInstanceID (HandlerSite m) InstanceId - , YesodAuthPersist (HandlerSite m) - , MonadHandler m - , MonadCatch m - , HasAppSettings (HandlerSite m) - ) - => Transaction -- ^ Transaction to record - -> ReaderT (YesodPersistBackend (HandlerSite m)) m () --- ^ Special case of `audit` for when there are no affected users -audit' = flip audit [] + insert_ TransactionLog{..} diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 5ffabcd09..493b8b1b7 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -12,21 +12,23 @@ import Utils.PathPiece data Transaction = TransactionTermEdit - { transactionTerm :: TermIdentifier + { transactionTerm :: TermId } | TransactionExamRegister - { transactionTerm :: TermIdentifier - , transactionSchool :: SchoolShorthand - , transactionCourse :: CourseShorthand - , transactionExam :: ExamName - , transactionUser :: UserIdent + { transactionExam :: ExamId + , transactionUser :: UserId } | TransactionExamDeregister - { transactionTerm :: TermIdentifier - , transactionSchool :: SchoolShorthand - , transactionCourse :: CourseShorthand - , transactionExam :: ExamName - , transactionUser :: UserIdent + { transactionExam :: ExamId + , transactionUser :: UserId + } + | TransactionExamResultEdit + { transactionExam :: ExamId + , transactionUser :: UserId + } + | TransactionExamResultDeleted + { transactionExam :: ExamId + , transactionUser :: UserId } deriving (Eq, Ord, Read, Show, Generic, Typeable) diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs index 744c96b7c..fdc7fc3b0 100644 --- a/src/Handler/Exam/AddUser.hs +++ b/src/Handler/Exam/AddUser.hs @@ -122,7 +122,7 @@ postEAddUserR tid ssh csh examn = do examRegister :: YesodJobDB UniWorX () examRegister = do insert_ $ ExamRegistration eid uid occId now - audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent + audit $ TransactionExamRegister eid uid whenM (lift . lift . existsBy $ UniqueExamRegistration eid uid) $ throwError $ mempty { aurAlreadyRegistered = pure userEmail } diff --git a/src/Handler/Exam/Register.hs b/src/Handler/Exam/Register.hs index 8051de2a7..cc8e387a7 100644 --- a/src/Handler/Exam/Register.hs +++ b/src/Handler/Exam/Register.hs @@ -38,13 +38,13 @@ postERegisterR tid ssh csh examn = do runDB $ do now <- liftIO getCurrentTime insert_ $ ExamRegistration eId uid Nothing now - audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent + audit $ TransactionExamRegister eId uid addMessageIconI Success IconExamRegisterTrue $ MsgExamRegisteredSuccess examn redirect $ CExamR tid ssh csh examn EShowR BtnExamDeregister -> do runDB $ do deleteBy $ UniqueExamRegistration eId uid - audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent + audit $ TransactionExamDeregister eId uid addMessageIconI Info IconExamRegisterFalse $ MsgExamDeregisteredSuccess examn -- yes, it's a success message, but it should be visually different from a positive success, since most will just note the positive green color! See discussion on commit 5f4925a4 redirect $ CExamR tid ssh csh examn EShowR diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs index c7ac4c7b4..e9d19f338 100644 --- a/src/Handler/Exam/RegistrationInvite.hs +++ b/src/Handler/Exam/RegistrationInvite.hs @@ -93,13 +93,11 @@ examRegistrationInvitationConfig = InvitationConfig{..} fieldRes <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid) (fslI MsgCourseStudyFeature) Nothing return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes (True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing) - invitationInsertHook (Entity _ Exam{..}) _ ExamRegistration{..} mField act = do + invitationInsertHook (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do whenIsJust mField $ \cpField -> insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField False - Course{..} <- get404 examCourse - User{..} <- get404 examRegistrationUser - let doAudit = audit' $ TransactionExamRegister (unTermKey courseTerm) (unSchoolKey courseSchool) courseShorthand examName userIdent + let doAudit = audit $ TransactionExamRegister eid examRegistrationUser act <* doAudit invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInvitationAccepted examName invitationUltDest (Entity _ Exam{..}) _ = do diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 3e7cc80c9..ac590c7ba 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -443,14 +443,13 @@ postEUsersR tid ssh csh examn = do , courseParticipantField = examUserCsvActCourseField , courseParticipantAllocated = False } - User{userIdent} <- getJust examUserCsvActUser - audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent insert_ ExamRegistration { examRegistrationExam = eid , examRegistrationUser = examUserCsvActUser , examRegistrationOccurrence = examUserCsvActOccurrence , examRegistrationTime = now } + audit $ TransactionExamRegister eid examUserCsvActUser ExamUserCsvRegisterData{..} -> do examRegistrationTime <- liftIO getCurrentTime insert_ ExamRegistration @@ -459,24 +458,28 @@ postEUsersR tid ssh csh examn = do , examRegistrationOccurrence = examUserCsvActOccurrence , .. } + audit $ TransactionExamRegister eid examUserCsvActUser ExamUserCsvAssignOccurrenceData{..} -> update examUserCsvActRegistration [ ExamRegistrationOccurrence =. examUserCsvActOccurrence ] ExamUserCsvSetCourseFieldData{..} -> update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ] ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of - Nothing -> deleteBy $ UniqueExamResult eid examUserCsvActUser + Nothing -> do + deleteBy $ UniqueExamResult eid examUserCsvActUser + audit $ TransactionExamResultDeleted eid examUserCsvActUser Just res -> do let res' = either (over _examResult $ review passingGrade) id res now <- liftIO getCurrentTime - void $ upsert + void $ upsertBy + (UniqueExamResult eid examUserCsvActUser) (ExamResult eid examUserCsvActUser res' now) [ ExamResultResult =. res' , ExamResultLastChanged =. now ] + audit $ TransactionExamResultEdit eid examUserCsvActUser ExamUserCsvDeregisterData{..} -> do ExamRegistration{examRegistrationUser} <- getJust examUserCsvActRegistration - User{userIdent} <- getJust examRegistrationUser - audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent + audit $ TransactionExamDeregister eid examRegistrationUser delete examUserCsvActRegistration ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Nothing, .. } -> do noteId <- getKeyBy $ UniqueCourseUserNote examUserCsvActUser examCourse diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 64a85bfef..8d67d8e5c 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -187,7 +187,7 @@ termEditHandler term = do -- term <- runDB $ get $ TermKey termName runDB $ do repsert tid res - audit' . TransactionTermEdit $ unTermKey tid + audit $ TransactionTermEdit tid -- VOR INTERNATIONALISIERUNG: -- let tid = termToText $ termName res -- let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert." diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 743e774e3..41d4a52ce 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -8,6 +8,7 @@ import ClassyPrelude.Yesod import Utils (lastMaybe) import Model +import Audit.Types import Model.Migration.Version import qualified Model.Migration.Types as Legacy import Data.Map (Map) @@ -23,6 +24,8 @@ import qualified Data.Conduit.List as C import Database.Persist.Sql import Database.Persist.Postgresql +import Control.Monad.Trans.Maybe (MaybeT(..)) + import Text.Read (readMaybe) import Data.CaseInsensitive (CI) @@ -30,10 +33,17 @@ import Text.Shakespeare.Text (st) import Control.Monad.Trans.Reader (mapReaderT) import Control.Monad.Except (MonadError(..)) -import Utils (exceptT) +import Utils (exceptT, allM, whenIsJust, guardM) +import Utils.DB (getKeyBy) import Numeric.Natural +import qualified Net.IP as IP +import qualified Net.IPv4 as IPv4 +import qualified Net.IPv6 as IPv6 + +import Data.Aeson (toJSON) + -- Database versions must follow https://pvp.haskell.org: -- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format) -- - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table) @@ -341,6 +351,53 @@ customMigrations = Map.fromListWith (>>) splitFirstName _ = Nothing runConduit $ getUsers .| C.mapMaybe splitFirstName .| C.mapM_ updateUser ) + , ( AppliedMigrationKey [migrationVersion|15.0.0|] [version|16.0.0|] + , whenM (tableExists "transaction_log") $ do + [executeQQ| + UPDATE transaction_log SET remote = null WHERE remote = #{IP.fromIPv4 IPv4.loopback} OR remote = #{IP.fromIPv6 IPv6.loopback} + |] + + [executeQQ| + ALTER TABLE transaction_log ADD COLUMN "initiator_id" bigint DEFAULT null; + |] + + whenM (tableExists "user") $ + [executeQQ| + UPDATE transaction_log SET initiator_id = "user".id FROM "user" WHERE transaction_log.initiator = "user".ident; + |] + + [executeQQ| + ALTER TABLE transaction_log DROP COLUMN initiator; + ALTER TABLE transaction_log RENAME COLUMN initiator_id TO initiator; + ALTER TABLE transaction_log ALTER COLUMN initiator DROP DEFAULT; + |] + + let getLogEntries = rawQuery [st|SELECT id, info FROM transaction_log|] [] + updateTransactionInfo [fromPersistValue -> Right lid, fromPersistValue -> Right (oldT :: Legacy.Transaction)] = do + newT <- case oldT of + Legacy.TransactionTermEdit tid + -> return . Just . TransactionTermEdit $ TermKey tid + Legacy.TransactionExamRegister (TermKey -> tid) (SchoolKey -> ssh) csh examn uident + -> runMaybeT $ do + guardM . lift $ tablesExist ["user", "exam", "course"] + + cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + eid <- MaybeT . getKeyBy $ UniqueExam cid examn + uid <- MaybeT . getKeyBy $ UniqueAuthentication uident + return $ TransactionExamRegister eid uid + Legacy.TransactionExamDeregister (TermKey -> tid) (SchoolKey -> ssh) csh examn uident + -> runMaybeT $ do + guardM . lift $ tablesExist ["user", "exam", "course"] + + cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + eid <- MaybeT . getKeyBy $ UniqueExam cid examn + uid <- MaybeT . getKeyBy $ UniqueAuthentication uident + return $ TransactionExamRegister eid uid + whenIsJust newT $ \newT' -> + update lid [ TransactionLogInfo =. toJSON newT' ] + updateTransactionInfo _ = return () + runConduit $ getLogEntries .| C.mapM_ updateTransactionInfo + ) ] @@ -352,6 +409,9 @@ tableExists table = do [Just _] -> return True _other -> return False +tablesExist :: MonadIO m => [Text] -> ReaderT SqlBackend m Bool +tablesExist = flip allM tableExists + tableIsEmpty :: MonadIO m => Text -> ReaderT SqlBackend m Bool tableIsEmpty table = do [rows] <- rawSql [st|SELECT COUNT(*) FROM "#{table}"|] [] diff --git a/src/Model/Migration/Types.hs b/src/Model/Migration/Types.hs index 2126ce178..58e6b7b25 100644 --- a/src/Model/Migration/Types.hs +++ b/src/Model/Migration/Types.hs @@ -58,11 +58,36 @@ instance Finite SheetSubmissionMode nullaryPathPiece ''SheetSubmissionMode camelToPathPiece - -{- TODO: - * RenderMessage instance for newtype(SheetType) if needed --} - - deriveJSON defaultOptions ''SheetType Current.derivePersistFieldJSON ''SheetType + + + +data Transaction + = TransactionTermEdit + { transactionTerm :: Current.TermIdentifier + } + | TransactionExamRegister + { transactionTerm :: Current.TermIdentifier + , transactionSchool :: Current.SchoolShorthand + , transactionCourse :: Current.CourseShorthand + , transactionExam :: Current.ExamName + , transactionUser :: Current.UserIdent + } + | TransactionExamDeregister + { transactionTerm :: Current.TermIdentifier + , transactionSchool :: Current.SchoolShorthand + , transactionCourse :: Current.CourseShorthand + , transactionExam :: Current.ExamName + , transactionUser :: Current.UserIdent + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + , fieldLabelModifier = camelToPathPiece' 1 + , tagSingleConstructors = True + , sumEncoding = TaggedObject "transaction" "data" + } ''Transaction + +Current.derivePersistFieldJSON ''Transaction diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index de6a3c0fa..3907253cb 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -11,6 +11,8 @@ import qualified Database.Esqueleto as E -- import Database.Persist -- currently not needed here import Utils +import Control.Lens +import Control.Lens.Extras (is) @@ -27,14 +29,20 @@ entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal ent getKeyBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m) => Unique record -> ReaderT backend m (Maybe (Key record)) getKeyBy u = fmap entityKey <$> getBy u -- TODO optimize this, so that DB does not deliver entire record! + +getKeyJustBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record)) + => Unique record -> ReaderT backend m (Key record) +getKeyJustBy u = getKeyBy u >>= maybe + (throwM . PersistForeignConstraintUnmet $ tshow u) + return -getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m) +getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadHandler m) => Unique record -> ReaderT backend m (Key record) -getKeyBy404 = fmap entityKey . getBy404 -- TODO optimize this, so that DB does not deliver entire record! +getKeyBy404 u = getKeyBy u >>= maybe notFound return existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m) => Unique record -> ReaderT backend m Bool -existsBy = fmap isJust . getBy -- TODO optimize, so that DB does not deliver entire record +existsBy = fmap (is _Just) . getKeyBy existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistStoreRead backend, MonadIO m) => Key record -> ReaderT backend m Bool