First prototype of audit-log

Has auditing for term-edits as an example

models/audit

@@ -0,0 +1,12 @@
+-- Table recording all significant changes of database-state for auditing purposes
+TransactionLog
+  time UTCTime
+  instance InstanceId
+  initiator (CI Text) Maybe -- Case-insensitive user-identifier associated with performing this action
+  info Value -- JSON-encoded `Transaction`
+  request RequestInfo Maybe -- HTTP-Request info
+-- 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
+  UniqueTransactionLogAffected transaction user

package.yaml

@@ -117,6 +117,7 @@ dependencies:
   - lattices
   - hsass
   - semigroupoids
+  - http-types
 
 other-extensions:
   - GeneralizedNewtypeDeriving

src/Audit.hs

@@ -0,0 +1,63 @@
+module Audit
+  ( module Audit.Types
+  , audit
+  , getRequestInfo
+  ) where
+
+
+import ClassyPrelude.Yesod
+import Database.Persist.Sql
+import Yesod.Auth
+import Audit.Types
+import Model
+
+import Utils.Lens
+import qualified Network.Wai as Wai
+
+{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
+
+
+data RequestInfoException
+  = RICouldNotParseMethod Method
+  deriving (Show, Generic, Typeable)
+
+instance Exception RequestInfoException
+
+
+getRequestInfo :: (MonadHandler m, MonadThrow m) => m RequestInfo
+getRequestInfo = do
+  wai <- waiRequest
+  riMethod <- either (throwM . RICouldNotParseMethod) return . parseMethod $ Wai.requestMethod wai
+  let riRemote = Wai.remoteHost wai
+      riPath = Wai.pathInfo wai
+      riQueryString = queryToQueryText $ Wai.queryString wai
+  return RequestInfo{..}
+
+
+audit :: ( AuthId site ~ Key User
+         , AuthEntity site ~ User
+         , IsSqlBackend (YesodPersistBackend site)
+         , SqlBackendCanWrite (YesodPersistBackend site)
+         , HasInstanceID site InstanceId
+         , YesodAuthPersist site
+         )
+      => [UserId] -- ^ Affected users
+      -> Transaction -- ^ Transaction to record
+      -> YesodDB site ()
+-- ^ Log a transaction using information available from `HandlerT`:
+--
+--   - `transactionLogTime` is now
+--   - `transactionLogInitiator` is currently logged in user (or none)
+--   - `transactionLogRequest` is current HTTP-Request
+audit affected (toJSON -> transactionLogInfo) = do
+  uid <- liftHandlerT maybeAuthId
+
+  transactionLogTime <- liftIO getCurrentTime
+  transactionLogInstance <- getsYesod $ view instanceID
+  transactionLogInitiator <- for uid $ fmap userIdent . getJust
+  transactionLogRequest <- Just <$> getRequestInfo
+
+  tlId <- insert TransactionLog{..}
+
+  affectedUsers <- forM affected getJust
+  insertMany_ [ TransactionLogAffected tlId aident | aident <- userIdent <$> affectedUsers ]

src/Audit/Types.hs

@@ -0,0 +1,26 @@
+module Audit.Types
+  ( Transaction(..)
+  ) where
+
+import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
+import Model.Types.JSON
+import Model
+
+import Data.Aeson.TH
+import Utils.PathPiece
+
+{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
+
+
+data Transaction
+  = TransactionTermEdit { transactionTerm :: TermId }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  , fieldLabelModifier = camelToPathPiece' 1
+  , tagSingleConstructors = True
+  , sumEncoding = TaggedObject "transaction" "data"
+  } ''Transaction
+
+derivePersistFieldJSON ''Transaction

src/Foundation.hs

@@ -4,6 +4,7 @@
 
 module Foundation where
 
+import ClassyPrelude.Yesod (getHttpManager)
 import Import.NoFoundation
 import Database.Persist.Sql (ConnectionPool, runSqlPool)
 import Text.Hamlet          (hamletFile)
@@ -123,6 +124,12 @@ data UniWorX = UniWorX
 
 type SMTPPool = Pool SMTPConnection
 
+makeLenses_ ''UniWorX
+instance HasInstanceID UniWorX InstanceId where
+  instanceID = _appInstanceID
+instance HasHttpManager UniWorX Manager where
+  httpManager = _appHttpManager
+
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:
 -- http://www.yesodweb.com/book/routing-and-handlers
@@ -2190,12 +2197,6 @@ instance YesodAuth UniWorX where
 
 instance YesodAuthPersist UniWorX
 
--- Useful when writing code that is re-usable outside of the Handler context.
--- An example is background jobs that send email.
--- This can also be useful for writing code that works across multiple Yesod applications.
-instance HasHttpManager UniWorX where
-    getHttpManager = appHttpManager
-
 unsafeHandler :: UniWorX -> Handler a -> IO a
 unsafeHandler f h = do
   logger <- makeLogger f

src/Handler/Term.hs

@@ -181,7 +181,9 @@ termEditHandler term = do
       (FormSuccess res) -> do
           let tid = TermKey $ termName res
           -- term <- runDB $ get $ TermKey termName
-          runDB $ repsert tid res
+          runDB $ do
+            repsert tid res
+            audit [] $ TransactionTermEdit tid
 -- VOR INTERNATIONALISIERUNG:
 --           let tid = termToText $ termName res
 --           let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert."

src/Import/NoFoundation.hs

@@ -3,7 +3,7 @@ module Import.NoFoundation
     , MForm
     ) where
 
-import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm)
+import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, HasHttpManager(..))
 import Model                  as Import
 import Model.Types.JSON       as Import
 import Model.Migration        as Import
@@ -34,6 +34,7 @@ import Data.Pool              as Import (Pool)
 import Network.HaskellNet.SMTP as Import (SMTPConnection)
 
 import Mail                   as Import
+import Audit                  as Import
 
 import Data.Data              as Import (Data)
 import Data.Typeable          as Import (Typeable)

src/Model/Migration/Types.hs

@@ -2,7 +2,6 @@ module Model.Migration.Types where
 
 import ClassyPrelude.Yesod
 import Data.Aeson.TH (deriveJSON, defaultOptions)
-import Database.Persist.Sql
 
 import qualified Model as Current
 import qualified Model.Types.JSON as Current

src/Model/Types.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving
            , UndecidableInstances
   #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Model.Types
   ( module Model.Types
@@ -9,6 +9,7 @@ module Model.Types
   , module Mail
   , module Utils.DateTime
   , module Data.UUID.Types
+  , StdMethod, QueryText, SockAddr, PortNumber
   ) where
 
 import ClassyPrelude
@@ -26,6 +27,7 @@ import Data.Universe
 import Data.Universe.Helpers
 import Data.UUID.Types (UUID)
 import qualified Data.UUID.Types as UUID
+import Data.Scientific (Scientific, toBoundedInteger)
 
 import Data.Default
 
@@ -69,6 +71,7 @@ import Utils.DateTime (DateTimeFormat(..), SelDateTimeFormat(..))
 
 import Numeric.Natural
 import Data.Word.Word24 (Word24)
+import Data.Word (Word16)
 import Data.Bits
 import Data.Ix
 import Data.List (genericIndex, elemIndex)
@@ -80,6 +83,10 @@ import Data.Text.Metrics (damerauLevenshtein)
 
 import Data.Binary (Binary)
 
+import Network.HTTP.Types.URI (QueryText)
+import Network.HTTP.Types.Method (StdMethod(..))
+import Network.Socket
+
 
 instance PathPiece UUID where
   fromPathPiece = UUID.fromString . unpack
@@ -786,6 +793,37 @@ deriveJSON  defaultOptions
 derivePersistFieldJSON ''LecturerType
 
 
+deriving instance Generic StdMethod
+deriving instance Generic SockAddr
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece
+  } ''StdMethod
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 2
+  } ''SockAddr
+
+instance FromJSON PortNumber where
+  parseJSON = Aeson.withScientific "PortNumber" $ \sciNum -> case toBoundedInteger sciNum of
+    Just int -> return $ fromIntegral (int :: Word16)
+    Nothing -> fail "Expected whole number of plausible size to denote port"
+instance ToJSON PortNumber where
+  toJSON = toJSON . (fromIntegral :: PortNumber -> Scientific)
+
+
+data RequestInfo = RequestInfo
+  { riMethod :: StdMethod
+  , riRemote :: SockAddr
+  , riPath :: [Text]
+  , riQueryString :: QueryText
+  } deriving (Eq, Ord, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  } ''RequestInfo
+derivePersistFieldJSON ''RequestInfo
+  
+
 -- Type synonyms
 
 type Email           = Text

src/Model/Types/JSON.hs

@@ -28,10 +28,10 @@ derivePersistFieldJSON tName = do
         | otherwise = cxt [[t|PersistField|] `appT` t]
   sequence
     [ instanceD iCxt ([t|PersistField|] `appT` t)
-      [ funD (mkName "toPersistValue")
+      [ funD 'toPersistValue
         [ clause [] (normalB [e|PersistDbSpecific . LBS.toStrict . JSON.encode|]) []
         ]
-      , funD (mkName "fromPersistValue")
+      , funD 'fromPersistValue
         [ do
             bs <- newName "bs"
             clause [[p|PersistDbSpecific $(varP bs)|]] (normalB [e|first pack $ JSON.eitherDecodeStrict' $(varE bs)|]) []
@@ -45,7 +45,7 @@ derivePersistFieldJSON tName = do
         ]
       ]
     , instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
-      [ funD (mkName "sqlType")
+      [ funD 'sqlType
         [ clause [wildP] (normalB [e|SqlOther "jsonb"|]) []
         ]
       ]

src/Settings.hs

@@ -14,7 +14,7 @@ import           ClassyPrelude.Yesod
 import Data.UUID (UUID)
 import qualified Control.Exception           as Exception
 import           Data.Aeson                  (Result (..), fromJSON, withObject
-                                             ,(.!=), (.:?), withScientific
+                                             ,(.!=), (.:?)
                                              )
 import qualified Data.Aeson.Types as Aeson
 import           Data.Aeson.TH
@@ -272,11 +272,6 @@ deriveJSON
     }
   ''LogLevel
 
-instance FromJSON HaskellNet.PortNumber where
-  parseJSON = withScientific "PortNumber" $ \sciNum -> case toBoundedInteger sciNum of
-    Just int -> return $ fromIntegral (int :: Word16)
-    Nothing -> fail "Expected whole number of plausible size to denote port"
-
 deriveFromJSON
   defaultOptions
     { constructorTagModifier = unpack . intercalate "-" . Text.splitOn "_" . toLower . pack

src/Utils/Lens.hs

@@ -1,6 +1,12 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Utils.Lens ( module Utils.Lens ) where
 
-import Import.NoFoundation
+import ClassyPrelude.Yesod hiding (HasHttpManager(..))
+import qualified ClassyPrelude.Yesod as Yesod (HasHttpManager(..))
+import Model
+
 import Control.Lens as Utils.Lens hiding ((<.>))
 import Control.Lens.Extras as Utils.Lens (is)
 import Utils.Lens.TH as Utils.Lens (makeLenses_, makeClassyFor_)
@@ -94,3 +100,15 @@ makeLenses_ ''StudyTermCandidate
 -- makeClassy_ ''Load
 
 
+--------------------------
+-- Fields for `UniWorX` --
+--------------------------
+  
+class HasInstanceID s a | s -> a where
+  instanceID :: Lens' s a
+
+class HasHttpManager s a | s -> a where
+  httpManager :: Lens' s a
+
+instance HasHttpManager s Manager => Yesod.HasHttpManager s where
+  getHttpManager = view httpManager

test/Model/TypesSpec.hs

@@ -6,6 +6,7 @@ import Settings
 import Control.Lens (review, preview)
 import Data.Aeson (Value)
 import qualified Data.Aeson as Aeson
+import Data.Word (Word16)
 
 import MailSpec ()
 
@@ -145,6 +146,20 @@ instance Arbitrary LecturerType where
   arbitrary = genericArbitrary
   shrink = genericShrink
 
+instance Arbitrary StdMethod where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+instance Arbitrary SockAddr where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+instance Arbitrary PortNumber where
+  arbitrary = (fromIntegral :: Word16 -> PortNumber) <$> arbitrary
+  
+instance Arbitrary RequestInfo where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
 
 spec :: Spec
 spec = do
@@ -205,6 +220,14 @@ spec = do
       [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
     lawsCheckHspec (Proxy @LecturerType)
       [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @StdMethod)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws ]
+    lawsCheckHspec (Proxy @SockAddr)
+      [ eqLaws, ordLaws, jsonLaws ]
+    lawsCheckHspec (Proxy @PortNumber)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws ]
+    lawsCheckHspec (Proxy @RequestInfo)
+      [ eqLaws, ordLaws, jsonLaws, persistFieldLaws ]
 
   describe "TermIdentifier" $ do
     it "has compatible encoding/decoding to/from Text" . property $