diff --git a/models/audit b/models/audit new file mode 100644 index 000000000..6186c42e3 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/package.yaml b/package.yaml index 339ecff3e..5e793cc67 100644 --- a/package.yaml +++ b/package.yaml @@ -117,6 +117,7 @@ dependencies: - lattices - hsass - semigroupoids + - http-types other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Audit.hs b/src/Audit.hs new file mode 100644 index 000000000..f339a0b22 --- /dev/null +++ b/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 ] diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs new file mode 100644 index 000000000..4f9279bb6 --- /dev/null +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index b65dda85b..b099c86b5 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 31ab90653..352f5d02b 100644 --- a/src/Handler/Term.hs +++ b/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." diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index dd0861ab9..65d31cba6 100644 --- a/src/Import/NoFoundation.hs +++ b/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) diff --git a/src/Model/Migration/Types.hs b/src/Model/Migration/Types.hs index 0aed744b0..5ec81cd81 100644 --- a/src/Model/Migration/Types.hs +++ b/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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 775900850..037815ff4 100644 --- a/src/Model/Types.hs +++ b/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 diff --git a/src/Model/Types/JSON.hs b/src/Model/Types/JSON.hs index e69f8f1b2..6bb938926 100644 --- a/src/Model/Types/JSON.hs +++ b/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"|]) [] ] ] diff --git a/src/Settings.hs b/src/Settings.hs index f717ee378..f96babd60 100644 --- a/src/Settings.hs +++ b/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 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 0abc9a8ee..c518e6348 100644 --- a/src/Utils/Lens.hs +++ b/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 diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index d30237550..539d733a5 100644 --- a/test/Model/TypesSpec.hs +++ b/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 () @@ -144,7 +145,21 @@ instance Arbitrary AuthenticationMode where 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 $