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

Add role-claim-key config value

Browse Source
This commit is contained in:
steve-chavez
2018-04-30 11:31:06 -05:00
committed by Steve Chávez
parent 5c87fe2704
commit f033c2c4b5
10 changed files with 147 additions and 29 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/PostgREST/App.hs
+1 -1
View File
@@ -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
+30 -18
View File
@@ -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 _ _ "" _ = return $ JWTClaims M.empty
jwtClaims secret audience payload time =
jwtClaims :: Maybe JWK -> Maybe StringOrURI -> LByteString -> UTCTime -> Maybe JSPath -> IO JWTAttempt
jwtClaims _ _ "" _ _ = return $ JWTClaims M.empty
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
+12 -1
View File
@@ -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
+2 -2
View File
@@ -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
+23
View File
@@ -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
+5
View File
@@ -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)