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

refactor: Use jose-jwt instead of hs-jose

Browse Source 
This removes one more dependency on Template Haskell.
This commit is contained in:
Wolfgang Walther
2024-06-17 08:55:32 +02:00
committed by Wolfgang Walther
parent 0948d38863
commit 465170c7d6
4 changed files with 65 additions and 43 deletions
Download Patch File Download Diff File Expand all files Collapse all files
nix/overlays/haskell-packages.nix
+2
View File
@@ -59,6 +59,8 @@ let
hasql-pool = lib.dontCheck prev.hasql-pool_1_0_1;
jose-jwt = prev.jose-jwt_0_10_0;
postgresql-libpq = lib.dontCheck
(prev.postgresql-libpq.override {
postgresql = super.libpq;
postgrest.cabal
+1 -1
View File
@@ -115,7 +115,7 @@ library
, heredoc >= 0.2 && < 0.3
, http-types >= 0.12.2 && < 0.13
, insert-ordered-containers >= 0.2.2 && < 0.3
, jose >= 0.8.5.1 && < 0.12
, jose-jwt >= 0.9.6 && < 0.11
, lens >= 4.14 && < 5.3
, lens-aeson >= 1.0.1 && < 1.3
, mtl >= 2.2.2 && < 2.4
src/PostgREST/Auth.hs
+48 -16
View File
@@ -19,7 +19,6 @@ module PostgREST.Auth
, middleware
) where
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
@@ -30,11 +29,12 @@ import qualified Data.Cache as C
import qualified Data.Scientific as Sci
import qualified Data.Vault.Lazy as Vault
import qualified Data.Vector as V
import qualified Jose.Jwk as JWT
import qualified Jose.Jwt as JWT
import qualified Network.HTTP.Types.Header as HTTP
import qualified Network.Wai as Wai
import qualified Network.Wai.Middleware.HttpAuth as Wai
import Control.Lens (set)
import Control.Monad.Except (liftEither)
import Data.Either.Combinators (mapLeft)
import Data.List (lookup)
@@ -54,25 +54,57 @@ import Protolude
-- | Receives the JWT secret and audience (from config) and a JWT and returns a
-- JSON object of JWT claims.
parseToken :: Monad m =>
AppConfig -> LByteString -> UTCTime -> ExceptT Error m JSON.Value
parseToken :: AppConfig -> ByteString -> UTCTime -> ExceptT Error IO JSON.Value
parseToken _ "" _ = return JSON.emptyObject
parseToken AppConfig{..} token time = do
secret <- liftEither . maybeToRight JwtTokenMissing $ configJWKS
eitherClaims <-
lift . runExceptT $
JWT.verifyClaimsAt validation secret time =<< JWT.decodeCompact token
liftEither . mapLeft jwtClaimsError $ JSON.toJSON <$> eitherClaims
eitherContent <- liftIO $ JWT.decode (JWT.keys secret) Nothing token
content <- liftEither . mapLeft jwtDecodeError $ eitherContent
liftEither $ verifyClaims content
where
validation =
JWT.defaultJWTValidationSettings audienceCheck & set JWT.allowedSkew 30
-- TODO: Improve errors, those were just taken as-is from hs-jose to avoid
-- breaking changes.
jwtDecodeError :: JWT.JwtError -> Error
jwtDecodeError (JWT.KeyError _) = JwtTokenInvalid "JWSError JWSInvalidSignature"
jwtDecodeError JWT.BadCrypto = JwtTokenInvalid "JWSError (CompactDecodeError Invalid number of parts: Expected 3 parts; got 2)"
jwtDecodeError (JWT.BadAlgorithm _) = JwtTokenInvalid "JWSError JWSNoSignatures"
jwtDecodeError e = JwtTokenInvalid $ show e
audienceCheck :: JWT.StringOrURI -> Bool
audienceCheck = maybe (const True) (==) configJwtAudience
verifyClaims :: JWT.JwtContent -> Either Error JSON.Value
verifyClaims (JWT.Jws (_, claims)) = case JSON.decodeStrict claims of
Nothing -> Left $ JwtTokenInvalid "Parsing claims failed"
Just (JSON.Object mclaims)
| failedExpClaim mclaims -> Left $ JwtTokenInvalid "JWT expired"
| failedNbfClaim mclaims -> Left $ JwtTokenInvalid "JWTNotYetValid"
| failedIatClaim mclaims -> Left $ JwtTokenInvalid "JWTIssuedAtFuture"
| failedAudClaim mclaims -> Left $ JwtTokenInvalid "JWTNotInAudience"
Just jclaims -> Right jclaims
-- TODO: We could enable JWE support here (encrypted tokens)
verifyClaims _ = Left $ JwtTokenInvalid "Unsupported token type"
jwtClaimsError :: JWT.JWTError -> Error
jwtClaimsError JWT.JWTExpired = JwtTokenInvalid "JWT expired"
jwtClaimsError e = JwtTokenInvalid $ show e
allowedSkewSeconds = 30 :: Int64
now = floor . nominalDiffTimeToSeconds $ utcTimeToPOSIXSeconds time
sciToInt = fromMaybe 0 . Sci.toBoundedInteger
failedExpClaim :: KM.KeyMap JSON.Value -> Bool
failedExpClaim mclaims = case KM.lookup "exp" mclaims of
Just (JSON.Number secs) -> now > (sciToInt secs + allowedSkewSeconds)
_ -> False
failedNbfClaim :: KM.KeyMap JSON.Value -> Bool
failedNbfClaim mclaims = case KM.lookup "nbf" mclaims of
Just (JSON.Number secs) -> now < (sciToInt secs - allowedSkewSeconds)
_ -> False
failedIatClaim :: KM.KeyMap JSON.Value -> Bool
failedIatClaim mclaims = case KM.lookup "iat" mclaims of
Just (JSON.Number secs) -> now < (sciToInt secs - allowedSkewSeconds)
_ -> False
failedAudClaim :: KM.KeyMap JSON.Value -> Bool
failedAudClaim mclaims = case KM.lookup "aud" mclaims of
Just (JSON.String str) -> maybe (const False) (/=) configJwtAudience str
_ -> False
parseClaims :: Monad m =>
AppConfig -> JSON.Value -> ExceptT Error m AuthResult
@@ -105,7 +137,7 @@ middleware appState app req respond = do
time <- getTime appState
let token = fromMaybe "" $ Wai.extractBearerAuth =<< lookup HTTP.hAuthorization (Wai.requestHeaders req)
parseJwt = runExceptT $ parseToken conf (LBS.fromStrict token) time >>= parseClaims conf
parseJwt = runExceptT $ parseToken conf token time >>= parseClaims conf
-- If DbPlanEnabled -> calculate JWT validation time
-- If JwtCacheMaxLifetime -> cache JWT validation result
src/PostgREST/Config.hs
+14 -26
View File
@@ -28,27 +28,24 @@ module PostgREST.Config
, addTargetSessionAttrs
) where
import qualified Crypto.JOSE.Types as JOSE
import qualified Crypto.JWT as JWT
import qualified Data.Aeson as JSON
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy as LBS
import qualified Data.CaseInsensitive as CI
import qualified Data.Configurator as C
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Jose.Jwa as JWT
import qualified Jose.Jwk as JWT
import Control.Lens (preview)
import Control.Monad (fail)
import Crypto.JWT (JWK, JWKSet, StringOrURI, stringOrUri)
import Data.Aeson (toJSON)
import Data.Either.Combinators (mapLeft)
import Data.List (lookup)
import Data.List.NonEmpty (fromList, toList)
import Data.Maybe (fromJust)
import Data.Scientific (floatingOrInteger)
import Jose.Jwk (Jwk, JwkSet)
import Network.URI (escapeURIString,
isUnescapedInURIComponent)
import Numeric (readOct, showOct)
@@ -92,8 +89,8 @@ data AppConfig = AppConfig
, configDbTxRollbackAll :: Bool
, configDbUri :: Text
, configFilePath :: Maybe FilePath
, configJWKS :: Maybe JWKSet
, configJwtAudience :: Maybe StringOrURI
, configJWKS :: Maybe JwkSet
, configJwtAudience :: Maybe Text
, configJwtRoleClaimKey :: JSPath
, configJwtSecret :: Maybe BS.ByteString
, configJwtSecretIsBase64 :: Bool
@@ -163,7 +160,7 @@ toText conf =
,("db-pre-config", q . maybe mempty dumpQi . configDbPreConfig)
,("db-tx-end", q . showTxEnd)
,("db-uri", q . configDbUri)
,("jwt-aud", T.decodeUtf8 . LBS.toStrict . JSON.encode . maybe "" toJSON . configJwtAudience)
,("jwt-aud", q . fromMaybe mempty . configJwtAudience)
,("jwt-role-claim-key", q . T.intercalate mempty . fmap dumpJSPath . configJwtRoleClaimKey)
,("jwt-secret", q . T.decodeUtf8 . showJwtSecret)
,("jwt-secret-is-base64", T.toLower . show . configJwtSecretIsBase64)
@@ -267,7 +264,7 @@ parser optPath env dbSettings roleSettings roleIsolationLvl =
<*> (fromMaybe "postgresql://" <$> optString "db-uri")
<*> pure optPath
<*> pure Nothing
<*> parseJwtAudience "jwt-aud"
<*> optString "jwt-aud"
<*> parseRoleClaimKey "jwt-role-claim-key" "role-claim-key"
<*> (fmap encodeUtf8 <$> optString "jwt-secret")
<*> (fromMaybe False <$> optWithAlias
@@ -326,14 +323,6 @@ parser optPath env dbSettings roleSettings roleIsolationLvl =
Just val | isMalformedProxyUri val -> fail "Malformed proxy uri, a correct example: https://example.com:8443/basePath"
| otherwise -> pure $ Just val
parseJwtAudience :: C.Key -> C.Parser C.Config (Maybe StringOrURI)
parseJwtAudience k =
optString k >>= \case
Nothing -> pure Nothing -- no audience in config file
Just aud -> case preview stringOrUri (T.unpack aud) of
Nothing -> fail "Invalid Jwt audience. Check your configuration."
aud' -> pure aud'
parseLogLevel :: C.Key -> C.Parser C.Config LogLevel
parseLogLevel k =
optString k >>= \case
@@ -447,24 +436,23 @@ decodeSecret conf@AppConfig{..} =
decodeB64 = B64.decode . encodeUtf8 . T.strip . replaceUrlChars . decodeUtf8
replaceUrlChars = T.replace "_" "/" . T.replace "-" "+" . T.replace "." "="
-- | Parse `jwt-secret` configuration option and turn into a JWKSet.
-- | Parse `jwt-secret` configuration option and turn into a JWKS.
--
-- There are three ways to specify `jwt-secret`: text secret, JSON Web Key
-- (JWK), or JSON Web Key Set (JWKS). The first two are converted into a JWKSet
-- (JWK), or JSON Web Key Set (JWKS). The first two are converted into a JwkSet
-- with one key and the last is converted as is.
decodeJWKS :: AppConfig -> AppConfig
decodeJWKS conf =
conf { configJWKS = parseSecret <$> configJwtSecret conf }
parseSecret :: ByteString -> JWKSet
parseSecret :: ByteString -> JwkSet
parseSecret bytes =
fromMaybe (maybe secret (\jwk' -> JWT.JWKSet [jwk']) maybeJWK)
fromMaybe (maybe secret (\jwk' -> JWT.JwkSet [jwk']) maybeJWK)
maybeJWKSet
where
maybeJWKSet = JSON.decodeStrict bytes :: Maybe JWKSet
maybeJWK = JSON.decodeStrict bytes :: Maybe JWK
secret = JWT.JWKSet [JWT.fromKeyMaterial keyMaterial]
keyMaterial = JWT.OctKeyMaterial . JWT.OctKeyParameters $ JOSE.Base64Octets bytes
maybeJWKSet = JSON.decodeStrict bytes :: Maybe JwkSet
maybeJWK = JSON.decodeStrict bytes :: Maybe Jwk
secret = JWT.JwkSet [JWT.SymmetricJwk bytes Nothing (Just JWT.Sig) (Just $ JWT.Signed JWT.HS256)]
-- | Read database uri from a separate file if `db-uri` is a filepath.
readDbUriFile :: Maybe Text -> AppConfig -> IO AppConfig