From 2b8ffc8e612f4f6a362a121910fdcd16939695a7 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Mon, 13 Jun 2022 10:31:13 +0200 Subject: [PATCH] src: update for changed map type in aeson-2 This means that we're now using Data.Map.Strict instead of Data.HashMap.Strict for JSON objects in general, and specifically for claims maps and CSV rows. This addresses certain hash flooding vulnerabilities, but may have performance downsides. Compare e.g. https://frasertweedale.github.io/blog-fp/posts/2021-10-12-aeson-hash-flooding-protection.html --- src/PostgREST/Auth.hs | 11 ++++++----- src/PostgREST/GucHeader.hs | 7 ++++--- src/PostgREST/Middleware.hs | 6 ++++-- src/PostgREST/Request/ApiRequest.hs | 15 +++++++++------ 4 files changed, 23 insertions(+), 16 deletions(-) diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs index 5c1f029da..d14c50ff4 100644 --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -20,9 +20,10 @@ module PostgREST.Auth import qualified Crypto.JWT as JWT import qualified Data.Aeson as JSON +import qualified Data.Aeson.Key as K +import qualified Data.Aeson.KeyMap as KM import qualified Data.Aeson.Types as JSON import qualified Data.ByteString.Lazy.Char8 as LBS -import qualified Data.HashMap.Strict as HM import qualified Data.Text.Encoding as T import qualified Data.Vault.Lazy as Vault import qualified Data.Vector as V @@ -45,7 +46,7 @@ import Protolude data AuthResult = AuthResult - { authClaims :: HM.HashMap Text JSON.Value + { authClaims :: KM.KeyMap JSON.Value , authRole :: Text } @@ -78,13 +79,13 @@ parseClaims AppConfig{..} jclaims@(JSON.Object mclaims) = do role <- liftEither . maybeToRight JwtTokenRequired $ unquoted <$> walkJSPath (Just jclaims) configJwtRoleClaimKey <|> configDbAnonRole return AuthResult - { authClaims = mclaims & HM.insert "role" (JSON.toJSON role) + { authClaims = mclaims & KM.insert "role" (JSON.toJSON role) , authRole = role } where walkJSPath :: Maybe JSON.Value -> JSPath -> Maybe JSON.Value walkJSPath x [] = x - walkJSPath (Just (JSON.Object o)) (JSPKey key:rest) = walkJSPath (HM.lookup key o) rest + walkJSPath (Just (JSON.Object o)) (JSPKey key:rest) = walkJSPath (KM.lookup (K.fromText key) o) rest walkJSPath (Just (JSON.Array ar)) (JSPIdx idx:rest) = walkJSPath (ar V.!? idx) rest walkJSPath _ _ = Nothing @@ -92,7 +93,7 @@ parseClaims AppConfig{..} jclaims@(JSON.Object mclaims) = do unquoted (JSON.String t) = t unquoted v = T.decodeUtf8 . LBS.toStrict $ JSON.encode v -- impossible case - just added to please -Wincomplete-patterns -parseClaims _ _ = return AuthResult { authClaims = HM.empty, authRole = mempty } +parseClaims _ _ = return AuthResult { authClaims = KM.empty, authRole = mempty } -- | Validate authorization header. -- Parse and store JWT claims for future use in the request. diff --git a/src/PostgREST/GucHeader.hs b/src/PostgREST/GucHeader.hs index 5b8b5ebd5..2deba6999 100644 --- a/src/PostgREST/GucHeader.hs +++ b/src/PostgREST/GucHeader.hs @@ -5,8 +5,9 @@ module PostgREST.GucHeader ) where import qualified Data.Aeson as JSON +import qualified Data.Aeson.Key as K +import qualified Data.Aeson.KeyMap as KM import qualified Data.CaseInsensitive as CI -import qualified Data.HashMap.Strict as HM import Network.HTTP.Types.Header (Header) @@ -21,8 +22,8 @@ newtype GucHeader = GucHeader (CI.CI ByteString, ByteString) instance JSON.FromJSON GucHeader where parseJSON (JSON.Object o) = - case HM.toList o of - [(k, JSON.String s)] -> pure $ GucHeader (CI.mk $ toUtf8 k, toUtf8 s) + case KM.toList o of + [(k, JSON.String s)] -> pure $ GucHeader (CI.mk $ toUtf8 $ K.toText k, toUtf8 s) _ -> mzero parseJSON _ = mzero diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index 359bd1180..507202d22 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -10,6 +10,8 @@ module PostgREST.Middleware ) where import qualified Data.Aeson as JSON +import qualified Data.Aeson.Key as K +import qualified Data.Aeson.KeyMap as KM import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.HashMap.Strict as HM import qualified Data.Text as T @@ -38,7 +40,7 @@ import PostgREST.Request.Preferences import Protolude -- | Runs local(transaction scoped) GUCs for every request, plus the pre-request function -runPgLocals :: AppConfig -> HM.HashMap Text JSON.Value -> Text -> +runPgLocals :: AppConfig -> KM.KeyMap JSON.Value -> Text -> (ApiRequest -> ExceptT Error SQL.Transaction Wai.Response) -> ApiRequest -> ByteString -> PgVersion -> ExceptT Error SQL.Transaction Wai.Response runPgLocals conf claims role app req jsonDbS actualPgVersion = do @@ -57,7 +59,7 @@ runPgLocals conf claims role app req jsonDbS actualPgVersion = do then setConfigLocal "request.cookie." <$> iCookies req else setConfigLocalJson "request.cookies" (iCookies req) claimsSql = if usesLegacyGucs - then setConfigLocal "request.jwt.claim." <$> [(toUtf8 c, toUtf8 $ unquoted v) | (c,v) <- HM.toList claims] + then setConfigLocal "request.jwt.claim." <$> [(toUtf8 $ K.toText c, toUtf8 $ unquoted v) | (c,v) <- KM.toList claims] else [setConfigLocal mempty ("request.jwt.claims", LBS.toStrict $ JSON.encode claims)] roleSql = [setConfigLocal mempty ("role", toUtf8 role)] appSettingsSql = setConfigLocal mempty <$> (join bimap toUtf8 <$> configAppSettings conf) diff --git a/src/PostgREST/Request/ApiRequest.hs b/src/PostgREST/Request/ApiRequest.hs index 2cd2f309a..8dc4c5d89 100644 --- a/src/PostgREST/Request/ApiRequest.hs +++ b/src/PostgREST/Request/ApiRequest.hs @@ -18,6 +18,8 @@ module PostgREST.Request.ApiRequest ) where import qualified Data.Aeson as JSON +import qualified Data.Aeson.Key as K +import qualified Data.Aeson.KeyMap as KM import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.CaseInsensitive as CI @@ -25,6 +27,7 @@ import qualified Data.Csv as CSV import qualified Data.HashMap.Strict as HM import qualified Data.List as L import qualified Data.List.NonEmpty as NonEmptyList +import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified Data.Text.Encoding as T import qualified Data.Vector as V @@ -357,7 +360,7 @@ mutuallyAgreeable sProduces cAccepts = then listToMaybe sProduces else exact -type CsvData = V.Vector (HM.HashMap Text LBS.ByteString) +type CsvData = V.Vector (M.Map Text LBS.ByteString) {-| Converts CSV like @@ -375,8 +378,8 @@ csvToJson :: (CSV.Header, CsvData) -> JSON.Value csvToJson (_, vals) = JSON.Array $ V.map rowToJsonObj vals where - rowToJsonObj = JSON.Object . - HM.map (\str -> + rowToJsonObj = JSON.Object . KM.fromMapText . + M.map (\str -> if str == "NULL" then JSON.Null else JSON.String . T.decodeUtf8 $ LBS.toStrict str @@ -389,9 +392,9 @@ payloadAttributes raw json = JSON.Array arr -> case arr V.!? 0 of Just (JSON.Object o) -> - let canonicalKeys = S.fromList $ HM.keys o + let canonicalKeys = S.fromList $ K.toText <$> KM.keys o areKeysUniform = all (\case - JSON.Object x -> S.fromList (HM.keys x) == canonicalKeys + JSON.Object x -> S.fromList (K.toText <$> KM.keys x) == canonicalKeys _ -> False) arr in if areKeysUniform then Just $ ProcessedJSON raw canonicalKeys @@ -399,7 +402,7 @@ payloadAttributes raw json = Just _ -> Nothing Nothing -> Just emptyPJArray - JSON.Object o -> Just $ ProcessedJSON raw (S.fromList $ HM.keys o) + JSON.Object o -> Just $ ProcessedJSON raw (S.fromList $ K.toText <$> KM.keys o) -- truncate everything else to an empty array. _ -> Just emptyPJArray