feat(exam): audit exam registrations

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

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
+  transactionLogInitiator <- for uid $ \uid' -> maybe (throwM $ AuditUserNotFound uid') (return . userIdent) =<< get uid'
-  transactionLogRemote <- Just <$> getRemote
+  transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote
 
   tlId <- insert TransactionLog{..}
 
-  affectedUsers <- forM affected getJust
+  affectedUsers <- forM affected $ \uid' -> maybe (throwM $ AuditUserNotFound uid') (return . userIdent) =<< get uid'
-  insertMany_ [ TransactionLogAffected tlId aident | aident <- userIdent <$> affectedUsers ]
+  insertMany_ $ map (TransactionLogAffected tlId) affectedUsers
 
 audit' :: ( AuthId site ~ Key User
           , AuthEntity site ~ User

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

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
 

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

src/Model.hs

@@ -64,4 +64,4 @@ instance ToMarkup (Key Term) where
   toMarkup = toMarkup . termToText . unTermKey
 
 instance ToMessage (Key Term) where
-  toMessage = termToText . unTermKey
+  toMessage = termToText . unTermKey

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
+type TermCandidateIncidence = UUID