Much cleaner storage of remote address within audit

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

package.yaml

@@ -118,6 +118,7 @@ dependencies:
   - hsass
   - semigroupoids
   - http-types
+  - ip
 
 other-extensions:
   - GeneralizedNewtypeDeriving

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

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

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

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