Add role-claim-key config value

main/Main.hs

@@ -148,18 +148,23 @@ main = do
       port = configPort conf
       proxy = configProxyUri conf
       pgSettings = toS (configDatabase conf) -- is the db-uri
+      roleClaimKey = configRoleClaimKey conf
       appSettings =
         setHost ((fromString . toS) host) -- Warp settings
         . setPort port
         . setServerName (toS $ "postgrest/" <> prettyVersion)
         . setTimeout 3600 $
         defaultSettings
-  --
+
-  -- Checks that the provided proxy uri is formated correctly,
+  -- Checks that the provided proxy uri is formated correctly
-  -- does not test if it works here.
   when (isMalformedProxyUri $ toS <$> proxy) $
     panic
       "Malformed proxy uri, a correct example: https://example.com:8443/basePath"
+
+  -- Checks that the provided jspath is valid
+  when (isLeft roleClaimKey) $
+    panic $ show roleClaimKey
+
   putStrLn $ ("Listening on port " :: Text) <> show (configPort conf)
   --
   -- create connection pool with the provided settings, returns either

src/PostgREST/App.hs

@@ -78,7 +78,7 @@ postgrest conf refDbStructure pool getTime worker =
         response <- case userApiRequest (configSchema conf) req body of
           Left err -> return $ apiRequestError err
           Right apiRequest -> do
-            eClaims <- jwtClaims jwtSecret (configJwtAudience conf) (toS $ iJWT apiRequest) time
+            eClaims <- jwtClaims jwtSecret (configJwtAudience conf) (toS $ iJWT apiRequest) time (rightToMaybe $ configRoleClaimKey conf)
 
             let authed = containsRole eClaims
                 proc = case (iTarget apiRequest, iPayload apiRequest, iPreferSingleObjectParameter apiRequest) of

src/PostgREST/Auth.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 {-|
 Module      : PostgREST.Auth
 Description : PostgREST authorization functions.
@@ -19,9 +20,11 @@ module PostgREST.Auth (
   ) where
 
 import           Control.Lens.Operators
-import           Data.Aeson             (Value (..), decode, toJSON)
+import qualified Data.Aeson             as JSON
 import qualified Data.HashMap.Strict    as M
-import           Data.Time.Clock           (UTCTime)
+import           Data.Time.Clock        (UTCTime)
+import           Data.Vector            as V
+import           PostgREST.Types
 import           Protolude
 
 import qualified Crypto.JOSE.Types      as JOSE.Types
@@ -32,16 +35,16 @@ import           Crypto.JWT
 -}
 data JWTAttempt = JWTInvalid JWTError
                 | JWTMissingSecret
-                | JWTClaims (M.HashMap Text Value)
+                | JWTClaims (M.HashMap Text JSON.Value)
                 deriving (Eq, Show)
 
 {-|
   Receives the JWT secret and audience (from config) and a JWT and returns a map
   of JWT claims.
 -}
-jwtClaims :: Maybe JWK -> Maybe StringOrURI -> LByteString -> UTCTime -> IO JWTAttempt
+jwtClaims :: Maybe JWK -> Maybe StringOrURI -> LByteString -> UTCTime -> Maybe JSPath -> IO JWTAttempt
-jwtClaims _ _ "" _ = return $ JWTClaims M.empty
+jwtClaims _ _ "" _ _ = return $ JWTClaims M.empty
-jwtClaims secret audience payload time =
+jwtClaims secret audience payload time jspath =
   case secret of
     Nothing -> return JWTMissingSecret
     Just s -> do
@@ -51,7 +54,26 @@ jwtClaims secret audience payload time =
         verifyClaimsAt validation s time jwt
       return $ case eJwt of
         Left e    -> JWTInvalid e
-        Right jwt -> JWTClaims . claims2map $ jwt
+        Right jwt -> JWTClaims $ claims2map jwt jspath
+
+{-|
+  Turn JWT ClaimSet into something easier to work with,
+  also here the jspath is applied to put the "role" in the map
+-}
+claims2map :: ClaimsSet -> Maybe JSPath -> M.HashMap Text JSON.Value
+claims2map claims jspath = (\case
+    val@(JSON.Object o) ->
+      let role = maybe M.empty (M.singleton "role") $
+                 walkJSPath (Just val) =<< jspath in
+      M.delete "role" o `M.union` role -- mutating the map
+    _ -> M.empty
+  ) $ JSON.toJSON claims
+
+walkJSPath :: Maybe JSON.Value -> JSPath -> Maybe JSON.Value
+walkJSPath x                      []                = x
+walkJSPath (Just (JSON.Object o)) (JSPKey key:rest) = walkJSPath (M.lookup key o) rest
+walkJSPath (Just (JSON.Array ar)) (JSPIdx idx:rest) = walkJSPath (ar V.!? idx) rest
+walkJSPath _                      _                 = Nothing
 
 {-|
   Whether a response from jwtClaims contains a role claim
@@ -60,19 +82,9 @@ containsRole :: JWTAttempt -> Bool
 containsRole (JWTClaims claims) = M.member "role" claims
 containsRole _                  = False
 
-{-|
-  Internal helper used to turn JWT ClaimSet into something
-  easier to work with
--}
-claims2map :: ClaimsSet -> M.HashMap Text Value
-claims2map = val2map . toJSON
- where
-  val2map (Object o) = o
-  val2map _          = M.empty
-
 parseJWK :: ByteString -> JWK
 parseJWK str =
-  fromMaybe (hs256jwk str) (decode (toS str) :: Maybe JWK)
+  fromMaybe (hs256jwk str) (JSON.decode (toS str) :: Maybe JWK)
 
 {-|
   Internal helper to generate HMAC-SHA256. When the jwt key in the

src/PostgREST/Config.hs

@@ -25,7 +25,6 @@ module PostgREST.Config ( prettyVersion
                         )
        where
 
-import           PostgREST.Types             (PgVersion(..))
 import           Control.Applicative
 import           Control.Monad                (fail)
 import           Control.Lens                 (preview)
@@ -52,6 +51,9 @@ import           Network.Wai
 import           Network.Wai.Middleware.Cors  (CorsResourcePolicy (..))
 import           Options.Applicative          hiding (str)
 import           Paths_postgrest              (version)
+import           PostgREST.Parsers            (pRoleClaimKey)
+import           PostgREST.Types              (PgVersion(..), ApiRequestError(..),
+                                               JSPath, JSPathExp(..))
 import           Protolude                    hiding (hPutStrLn, take,
                                                intercalate, (<>))
 import           System.IO                    (hPrint)
@@ -78,6 +80,7 @@ data AppConfig = AppConfig {
   , configReqCheck          :: Maybe Text
   , configQuiet             :: Bool
   , configSettings          :: [(Text, Text)]
+  , configRoleClaimKey      :: Either ApiRequestError JSPath
   }
 
 defaultCorsPolicy :: CorsResourcePolicy
@@ -139,6 +142,7 @@ readOptions = do
           <*> (mfilter (/= "") <$> C.key "pre-request")
           <*> pure False
           <*> (fmap parsedPairToTextPair <$> C.subassocs "app.settings")
+          <*> (maybe (Right [JSPKey "role"]) parseRoleClaimKey <$> C.key "role-claim-key")
 
   case mAppConf of
     Nothing -> do
@@ -174,6 +178,10 @@ readOptions = do
     coerceBool (String b) = readMaybe $ toS b
     coerceBool _          = Nothing
 
+    parseRoleClaimKey :: Value -> Either ApiRequestError JSPath
+    parseRoleClaimKey (String s) = pRoleClaimKey s
+    parseRoleClaimKey v = pRoleClaimKey $ show v
+
     opts = info (helper <*> pathParser) $
              fullDesc
              <> progDesc (
@@ -218,6 +226,9 @@ readOptions = do
           |
           |## stored proc to exec immediately after auth
           |# pre-request = "stored_proc_name"
+          |
+          |## jspath to the role claim key
+          |# role-claim-key = ".role"
           |]
 
 pathParser :: Parser FilePath

src/PostgREST/Middleware.hs

@@ -5,7 +5,7 @@
 module PostgREST.Middleware where
 
 import           Crypto.JWT
-import           Data.Aeson                    (Value (..))
+import qualified Data.Aeson                    as JSON
 import qualified Data.HashMap.Strict           as M
 import qualified Hasql.Transaction             as H
 
@@ -44,7 +44,7 @@ runWithClaims conf eClaims app req =
         setSchemaSql = ["set schema " <> pgFmtLit (configSchema conf) <> ";"] :: [Text]
         -- role claim defaults to anon if not specified in jwt
         claimsWithRole = M.union claims (M.singleton "role" anon)
-        anon = String . toS $ configAnonRole conf
+        anon = JSON.String . toS $ configAnonRole conf
         customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf
   where
     unauthed message = simpleError

src/PostgREST/Parsers.hs

@@ -12,6 +12,7 @@ import           PostgREST.RangeQuery          (NonnegRange)
 import           PostgREST.Types
 import           Text.ParserCombinators.Parsec hiding (many, (<|>))
 import           Text.Parsec.Error
+import           Text.Read                     (read)
 
 pRequestSelect :: Text -> Either ApiRequestError [Tree SelectItem]
 pRequestSelect selStr =
@@ -212,3 +213,25 @@ mapError = mapLeft translateError
         message = show $ errorPos e
         details = strip $ replace "\n" " " $ toS
            $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
+
+-- Used for the config value "role-claim-key"
+pRoleClaimKey :: Text -> Either ApiRequestError JSPath
+pRoleClaimKey selStr =
+  mapError $ parse pJSPath ("failed to parse role-claim-key value (" <> toS selStr <> ")") (toS selStr)
+
+pJSPath :: Parser JSPath
+pJSPath = toJSPath <$> (period *> pPath `sepBy` period <* eof)
+  where
+    toJSPath :: [(Text, Maybe Int)] -> JSPath
+    toJSPath = concatMap (\(key, idx) -> JSPKey key : maybeToList (JSPIdx <$> idx))
+    period = char '.' <?> "period (.)"
+    pPath :: Parser (Text, Maybe Int)
+    pPath = (,) <$> pJSPKey <*> optionMaybe pJSPIdx
+
+pJSPKey :: Parser Text
+pJSPKey = toS <$> (many1 (alphaNum <|> oneOf "_$@") <|> pQuoted) <?> "attribute name [a..z0..9_$@])"
+  where
+    pQuoted = char '"' *> many (noneOf "\"") <* char '"'
+
+pJSPIdx :: Parser Int
+pJSPIdx = char '[' *> (read <$> many1 digit) <* char ']' <?> "array index [0..n]"

src/PostgREST/Types.hs

@@ -317,3 +317,8 @@ data PgVersion = PgVersion {
 
 sourceCTEName :: SqlFragment
 sourceCTEName = "pg_source"
+
+-- | full jspath, e.g. .property[0].attr.detail
+type JSPath = [JSPathExp]
+-- | jspath expression, e.g. .property, .property[0] or ."property-dash"
+data JSPathExp = JSPKey Text | JSPIdx Int deriving (Eq, Show)

test/SpecHelper.hs

@@ -17,6 +17,7 @@ import           System.Process (readProcess)
 import           Text.Heredoc
 
 import PostgREST.Config (AppConfig(..))
+import PostgREST.Types  (JSPathExp(..))
 
 import Test.Hspec hiding (pendingWith)
 import Test.Hspec.Wai
@@ -76,6 +77,8 @@ _baseCfg =  -- Connection Settings
             [ ("app.settings.app_host", "localhost")
             , ("app.settings.external_api_secret", "0123456789abcdef")
             ]
+            -- Default role claim key
+            (Right [JSPKey "role"])
 
 testCfg :: Text -> AppConfig
 testCfg testDbConn = _baseCfg { configDatabase = testDbConn }

test/io-tests.sh

@@ -40,9 +40,10 @@ pgrStopAll(){ pkill -f "$(stack path --local-install-root)/bin/postgrest"; }
 rootStatus(){
   curl -s -o /dev/null -w '%{http_code}' "http://localhost:$pgrPort/"
 }
+
 authorsStatus(){
   curl -s -o /dev/null -w '%{http_code}' \
-    -H "Authorization: Bearer $( cat "$1" )" \
+    -H "Authorization: Bearer $1" \
     "http://localhost:$pgrPort/authors_only"
 }
 
@@ -68,7 +69,7 @@ readSecretFromFile(){
   if pgrStarted
   then
     authorsJwt="./secrets/${1%.*}.jwt"
-    httpStatus="$( authorsStatus "$authorsJwt" )"
+    httpStatus="$( authorsStatus $(cat "$authorsJwt") )"
     if test "$httpStatus" -eq 200
     then
       ok "authentication with $2 secret read from a file"
@@ -81,6 +82,44 @@ readSecretFromFile(){
   pgrStop
 }
 
+reqWithRoleClaimKey(){
+  export ROLE_CLAIM_KEY=$1
+  pgrStart "./configs/role-claim-key.config"
+  while pgrStarted && test "$( rootStatus )" -ne 200
+  do
+    # wait for the server to start
+    sleep 0.1 \
+    || sleep 1 # fallback: subsecond sleep is not standard and may fail
+  done
+  authorsJwt=$(psql -qtAX postgrest_test -c "select jwt.sign('$2', 'reallyreallyreallyreallyverysafe');")
+  httpStatus="$( authorsStatus "$authorsJwt" )"
+  if test "$httpStatus" -eq $3
+  then
+    ok "request with \"$1\" role-claim-key for $2 jwt gave $3"
+  else
+    ko "request with \"$1\" role-claim-key for $2 jwt gave $httpStatus"
+  fi
+  pgrStop
+}
+
+invalidRoleClaimKey(){
+  export ROLE_CLAIM_KEY=$1
+  pgrStart "./configs/role-claim-key.config"
+  while pgrStarted && test "$( rootStatus )" -ne 200
+  do
+    # wait for the server to start
+    sleep 0.1 \
+    || sleep 1 # fallback: subsecond sleep is not standard and may fail
+  done
+  if pgrStarted
+  then
+    ko "invalid jspath \"$1\" accepted"
+  else
+    ok "invalid jspath \"$1\" rejected"
+  fi
+  pgrStop
+}
+
 # PRE: curl must be available
 test -n "$(command -v curl)" || bailOut 'curl is not available'
 
@@ -89,8 +128,7 @@ psql -l 1>/dev/null 2>/dev/null || bailOut 'postgres is not running'
 
 setUp
 
-totalTests=12
+echo "Running IO tests.."
-echo "1..$totalTests"
 
 readSecretFromFile word.noeol 'simple (no EOL)'
 readSecretFromFile word.txt 'simple'
@@ -106,6 +144,19 @@ readSecretFromFile ascii.b64 'Base64 (ASCII)'
 readSecretFromFile utf8.b64 'Base64 (UTF-8)'
 readSecretFromFile binary.b64 'Base64 (binary)'
 
+reqWithRoleClaimKey '.postgrest.a_role' '{"postgrest":{"a_role":"postgrest_test_author"}}' 200
+reqWithRoleClaimKey '.customObject.manyRoles[1]' '{"customObject":{"manyRoles": ["other", "postgrest_test_author"]}}' 200
+reqWithRoleClaimKey '."https://www.example.com/roles"[0].value' '{"https://www.example.com/roles":[{"value":"postgrest_test_author"}]}' 200
+reqWithRoleClaimKey '.myDomain[3]' '{"myDomain":["other","postgrest_test_author"]}' 401
+reqWithRoleClaimKey '.myRole' '{"role":"postgrest_test_author"}' 401
+
+invalidRoleClaimKey 'role.other'
+invalidRoleClaimKey '.role##'
+invalidRoleClaimKey '.my_role;;domain'
+invalidRoleClaimKey '.#$%&$%/'
+invalidRoleClaimKey ''
+invalidRoleClaimKey 1234
+
 cleanUp
 
 exit $failedTests

test/io-tests/configs/role-claim-key.config

@@ -0,0 +1,8 @@
+db-uri = "postgres:///postgrest_test"
+db-schema = "test"
+db-anon-role = "postgrest_test_anonymous"
+db-pool = 1
+server-host = "*4"
+server-port = 49421
+role-claim-key = "$(ROLE_CLAIM_KEY)"
+jwt-secret = "reallyreallyreallyreallyverysafe"