jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

src: update for changed map type in aeson-2

Browse Source 
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
This commit is contained in:
Robert Vollmert
2022-06-13 13:25:54 +02:00
parent 48a3d1d516
commit 2b8ffc8e61
4 changed files with 23 additions and 16 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/PostgREST/Auth.hs
+6 -5
View File
@@ -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
+4 -3
View File
@@ -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
src/PostgREST/Middleware.hs
+4 -2
View File
@@ -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
+9 -6
View File
@@ -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