diff --git a/models/audit b/models/audit index 6186c42e3..8569afd8a 100644 --- a/models/audit +++ b/models/audit @@ -3,8 +3,8 @@ TransactionLog time UTCTime instance InstanceId initiator (CI Text) 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` - request RequestInfo Maybe -- HTTP-Request info -- Best guess of users affected by a change in database-state at time of transaction TransactionLogAffected transaction TransactionLogId diff --git a/package.yaml b/package.yaml index 5e793cc67..221322476 100644 --- a/package.yaml +++ b/package.yaml @@ -118,6 +118,7 @@ dependencies: - hsass - semigroupoids - http-types + - ip other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Audit.hs b/src/Audit.hs index f339a0b22..a96efe55e 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -1,7 +1,8 @@ module Audit ( module Audit.Types - , audit - , getRequestInfo + , audit, audit' + , AuditRemoteException(..) + , getRemote ) where @@ -13,25 +14,27 @@ import Model import Utils.Lens import qualified Network.Wai as Wai +import qualified Network.Socket as Wai + +import qualified Net.IP as IP {-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} -data RequestInfoException - = RICouldNotParseMethod Method +data AuditRemoteException + = ARUnsupportedSocketKind deriving (Show, Generic, Typeable) -instance Exception RequestInfoException +instance Exception AuditRemoteException -getRequestInfo :: (MonadHandler m, MonadThrow m) => m RequestInfo -getRequestInfo = do +getRemote :: (MonadHandler m, MonadThrow m) => m IP +getRemote = 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{..} + case Wai.remoteHost wai of + Wai.SockAddrInet _ hAddr -> let (b1, b2, b3, b4) = Wai.hostAddressToTuple hAddr in return $ IP.ipv4 b1 b2 b3 b4 + Wai.SockAddrInet6 _ _ hAddr _ -> let (w1, w2, w3, w4, w5, w6, w7, w8) = Wai.hostAddress6ToTuple hAddr in return $ IP.ipv6 w1 w2 w3 w4 w5 w6 w7 w8 + _other -> throwM ARUnsupportedSocketKind audit :: ( AuthId site ~ Key User @@ -41,23 +44,35 @@ audit :: ( AuthId site ~ Key User , HasInstanceID site InstanceId , YesodAuthPersist site ) - => [UserId] -- ^ Affected users - -> Transaction -- ^ Transaction to record + => Transaction -- ^ Transaction to record + -> [UserId] -- ^ Affected users -> 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 +audit (toJSON -> transactionLogInfo) affected = do uid <- liftHandlerT maybeAuthId transactionLogTime <- liftIO getCurrentTime transactionLogInstance <- getsYesod $ view instanceID transactionLogInitiator <- for uid $ fmap userIdent . getJust - transactionLogRequest <- Just <$> getRequestInfo + transactionLogRemote <- Just <$> getRemote tlId <- insert TransactionLog{..} affectedUsers <- forM affected getJust insertMany_ [ TransactionLogAffected tlId aident | aident <- userIdent <$> affectedUsers ] + +audit' :: ( AuthId site ~ Key User + , AuthEntity site ~ User + , IsSqlBackend (YesodPersistBackend site) + , SqlBackendCanWrite (YesodPersistBackend site) + , HasInstanceID site InstanceId + , YesodAuthPersist site + ) + => Transaction -- ^ Transaction to record + -> YesodDB site () +-- ^ Special case of `audit` for when there are no affected users +audit' = flip audit [] diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 352f5d02b..4e5b059ac 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -183,7 +183,7 @@ termEditHandler term = do -- term <- runDB $ get $ TermKey termName runDB $ do repsert tid res - audit [] $ TransactionTermEdit tid + audit' $ TransactionTermEdit tid -- VOR INTERNATIONALISIERUNG: -- let tid = termToText $ termName res -- let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert." diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 037815ff4..67e41c83d 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -9,7 +9,7 @@ module Model.Types , module Mail , module Utils.DateTime , module Data.UUID.Types - , StdMethod, QueryText, SockAddr, PortNumber + , module Net.IP ) where import ClassyPrelude @@ -27,7 +27,6 @@ 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 @@ -44,6 +43,7 @@ import Web.PathPieces import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Lens as Text +import qualified Data.Text.Encoding as Text import qualified Data.HashMap.Strict as HashMap @@ -71,7 +71,6 @@ 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) @@ -83,9 +82,8 @@ import Data.Text.Metrics (damerauLevenshtein) import Data.Binary (Binary) -import Network.HTTP.Types.URI (QueryText) -import Network.HTTP.Types.Method (StdMethod(..)) -import Network.Socket +import Net.IP (IP) +import qualified Net.IP as IP instance PathPiece UUID where @@ -793,35 +791,14 @@ 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 +instance PersistField IP where + toPersistValue = PersistDbSpecific . encodeUtf8 . IP.encode + fromPersistValue (PersistDbSpecific bs) = first tshow (Text.decodeUtf8' bs) >>= maybe (Left "Could not parse IP-address") Right . IP.decode + fromPersistValue (PersistByteString bs) = first tshow (Text.decodeUtf8' bs) >>= maybe (Left "Could not parse IP-address") Right . IP.decode + fromPersistValue (PersistText t) = maybe (Left "Could not parse IP-address") Right $ IP.decode t + fromPersistValue _ = Left "IP-address values must be converted from PersistDbSpecific, PersistText, or PersistByteString" +instance PersistFieldSql IP where + sqlType _ = SqlOther "inet" -- Type synonyms diff --git a/src/Settings.hs b/src/Settings.hs index f96babd60..f717ee378 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,6 +272,11 @@ 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