fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(audit): introduce id-based format

Browse Source
This commit is contained in:
Gregor Kleen 2019-08-06 09:51:05 +02:00
parent fb027dee58
commit f602b79e7a
11 changed files with 137 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
models/audit
View File

@ -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
info Value -- JSON-encoded `Transaction`

29
src/Audit.hs
View File

@ -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{..}

24
src/Audit/Types.hs
View File

@ -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)

2
src/Handler/Exam/AddUser.hs
View File

@ -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 }

4
src/Handler/Exam/Register.hs
View File

@ -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

6
src/Handler/Exam/RegistrationInvite.hs
View File

@ -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

15
src/Handler/Exam/Users.hs
View File

@ -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

2
src/Handler/Term.hs
View File

@ -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."

62
src/Model/Migration.hs
View File

@ -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}"|] []

37
src/Model/Migration/Types.hs
View File

@ -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

14
src/Utils/DB.hs
View File

@ -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