feat(audit): introduce id-based format

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`
+  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

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
+audit (toJSON -> transactionLogInfo) = do
-  uid <- liftHandlerT maybeAuthId
 
   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{..}
+  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 []

src/Audit/Types.hs

@@ -12,21 +12,23 @@ import Utils.PathPiece
 
 data Transaction
   = TransactionTermEdit
-    { transactionTerm   :: TermIdentifier
+    { transactionTerm   :: TermId
     }
   | TransactionExamRegister
-    { transactionTerm   :: TermIdentifier
+    { transactionExam   :: ExamId
-    , transactionSchool :: SchoolShorthand
+    , transactionUser   :: UserId
-    , transactionCourse :: CourseShorthand
-    , transactionExam   :: ExamName
-    , transactionUser   :: UserIdent
     }
   | TransactionExamDeregister
-    { transactionTerm   :: TermIdentifier
+    { transactionExam   :: ExamId
-    , transactionSchool :: SchoolShorthand
+    , transactionUser   :: UserId
-    , transactionCourse :: CourseShorthand
+    }
-    , transactionExam   :: ExamName
+  | TransactionExamResultEdit
-    , transactionUser   :: UserIdent
+    { transactionExam   :: ExamId
+    , transactionUser   :: UserId
+    }
+  | TransactionExamResultDeleted
+    { transactionExam   :: ExamId
+    , transactionUser   :: UserId
     }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 

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 }

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

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
+      let doAudit = audit $ TransactionExamRegister eid examRegistrationUser
-      User{..} <- get404 examRegistrationUser
-      let doAudit = audit' $ TransactionExamRegister (unTermKey courseTerm) (unSchoolKey courseSchool) courseShorthand examName userIdent
       act <* doAudit
     invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInvitationAccepted examName
     invitationUltDest (Entity _ Exam{..}) _ = do

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 eid examRegistrationUser
-                    audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
                     delete examUserCsvActRegistration
                   ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Nothing, .. } -> do
                     noteId <- getKeyBy $ UniqueCourseUserNote examUserCsvActUser examCourse

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

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

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

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