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

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

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
+    case KM.toList o of
-      [(k, JSON.String s)] -> pure $ GucHeader (CI.mk $ toUtf8 k, toUtf8 s)
+      [(k, JSON.String s)] -> pure $ GucHeader (CI.mk $ toUtf8 $ K.toText k, toUtf8 s)
       _ -> mzero
   parseJSON _ = mzero
 

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)

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 .
+  rowToJsonObj = JSON.Object . KM.fromMapText .
-    HM.map (\str ->
+    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