refactor: move jwt error messages to Error.hs module

This commit is contained in:
Taimoor Zaeem
2025-05-31 06:41:22 -05:00
committed by Steve Chavez
parent 72f6036432
commit aebdc716c7
2 changed files with 73 additions and 32 deletions
+19 -18
View File
@@ -50,7 +50,8 @@ import PostgREST.Auth.JwtCache (lookupJwtCache)
import PostgREST.Auth.Types (AuthResult (..))
import PostgREST.Config (AppConfig (..), FilterExp (..),
JSPath, JSPathExp (..))
import PostgREST.Error (Error (..), JwtError (..))
import PostgREST.Error (Error (..), JwtClaimsError (..),
JwtDecodeError (..), JwtError (..))
import Protolude
@@ -58,7 +59,7 @@ import Protolude
-- JSON object of JWT claims.
parseToken :: AppConfig -> Maybe ByteString -> UTCTime -> ExceptT Error IO JSON.Value
parseToken _ Nothing _ = return JSON.emptyObject
parseToken _ (Just "") _ = throwE . JwtErr $ JwtDecodeError "Empty JWT is sent in Authorization header"
parseToken _ (Just "") _ = throwE . JwtErr $ JwtDecodeErr EmptyAuthHeader
parseToken AppConfig{..} (Just tkn) time = do
secret <- liftEither . maybeToRight (JwtErr JwtSecretMissing) $ configJWKS
tknWith3Parts <- liftEither $ hasThreeParts tkn
@@ -69,33 +70,33 @@ parseToken AppConfig{..} (Just tkn) time = do
hasThreeParts :: ByteString -> Either Error ByteString
hasThreeParts token = case length $ BS.split (BS.c2w '.') token of
3 -> Right token
n -> Left $ JwtErr $ JwtDecodeError ("Expected 3 parts in JWT; got " <> show n)
n -> Left $ JwtErr $ JwtDecodeErr $ UnexpectedParts n
jwtDecodeError :: JWT.JwtError -> JwtError
-- The only errors we can get from JWT.decode function are:
-- BadAlgorithm
-- KeyError
-- BadCrypto
jwtDecodeError (JWT.KeyError _) = JwtDecodeError "No suitable key or wrong key type"
jwtDecodeError (JWT.BadAlgorithm _) = JwtDecodeError "Wrong or unsupported encoding algorithm"
jwtDecodeError JWT.BadCrypto = JwtDecodeError "JWT cryptographic operation failed"
jwtDecodeError (JWT.KeyError _) = JwtDecodeErr KeyError
jwtDecodeError (JWT.BadAlgorithm _) = JwtDecodeErr BadAlgorithm
jwtDecodeError JWT.BadCrypto = JwtDecodeErr BadCrypto
-- Control never reaches here, the decode function only returns the above three
jwtDecodeError _ = JwtDecodeError "JWT couldn't be decoded"
jwtDecodeError _ = JwtDecodeErr UnreachableDecodeError
verifyClaims :: JWT.JwtContent -> Either JwtError JSON.Value
verifyClaims (JWT.Jws (_, claims)) = case JSON.decodeStrict claims of
Just jclaims@(JSON.Object mclaims) ->
verifyClaim mclaims "exp" isValidExpClaim "JWT expired" >>
verifyClaim mclaims "nbf" isValidNbfClaim "JWT not yet valid" >>
verifyClaim mclaims "iat" isValidIatClaim "JWT issued at future" >>
verifyClaim mclaims "aud" isValidAudClaim "JWT not in audience" >>
verifyClaim mclaims "exp" isValidExpClaim JWTExpired >>
verifyClaim mclaims "nbf" isValidNbfClaim JWTNotYetValid >>
verifyClaim mclaims "iat" isValidIatClaim JWTIssuedAtFuture >>
verifyClaim mclaims "aud" isValidAudClaim JWTNotInAudience >>
return jclaims
_ -> Left $ JwtClaimsError "Parsing claims failed"
_ -> Left $ JwtClaimsErr ParsingClaimsFailed
-- TODO: We could enable JWE support here (encrypted tokens)
verifyClaims _ = Left $ JwtDecodeError "Unsupported token type"
verifyClaims _ = Left $ JwtDecodeErr UnsupportedTokenType
verifyClaim mclaims claim func err = do
isValid <- maybe (Right True) func (KM.lookup claim mclaims)
unless isValid $ Left $ JwtClaimsError err
unless isValid $ Left $ JwtClaimsErr err
allowedSkewSeconds = 30 :: Int64
now = floor . nominalDiffTimeToSeconds $ utcTimeToPOSIXSeconds time
@@ -104,15 +105,15 @@ parseToken AppConfig{..} (Just tkn) time = do
isValidExpClaim :: JSON.Value -> Either JwtError Bool
isValidExpClaim (JSON.Number secs) = Right $ now <= (sciToInt secs + allowedSkewSeconds)
isValidExpClaim _ = Left $ JwtClaimsError "The JWT 'exp' claim must be a number"
isValidExpClaim _ = Left $ JwtClaimsErr ExpClaimNotNumber
isValidNbfClaim :: JSON.Value -> Either JwtError Bool
isValidNbfClaim (JSON.Number secs) = Right $ now >= (sciToInt secs - allowedSkewSeconds)
isValidNbfClaim _ = Left $ JwtClaimsError "The JWT 'nbf' claim must be a number"
isValidNbfClaim _ = Left $ JwtClaimsErr NbfClaimNotNumber
isValidIatClaim :: JSON.Value -> Either JwtError Bool
isValidIatClaim (JSON.Number secs) = Right $ now >= (sciToInt secs - allowedSkewSeconds)
isValidIatClaim _ = Left $ JwtClaimsError "The JWT 'iat' claim must be a number"
isValidIatClaim _ = Left $ JwtClaimsErr IatClaimNotNumber
isValidAudClaim :: JSON.Value -> Either JwtError Bool
isValidAudClaim JSON.Null = Right True -- {"aud": null} is valid for all audiences
@@ -120,7 +121,7 @@ parseToken AppConfig{..} (Just tkn) time = do
isValidAudClaim (JSON.Array arr)
| null arr = Right True -- {"aud": []} is valid for all audiences
| allStrings arr = Right $ maybe True (\a -> JSON.String a `elem` arr) configJwtAudience
isValidAudClaim _ = Left $ JwtClaimsError "The JWT 'aud' claim must be a string or an array of strings"
isValidAudClaim _ = Left $ JwtClaimsErr AudClaimNotStringOrArray
parseClaims :: Monad m =>
AppConfig -> JSON.Value -> ExceptT Error m AuthResult
+54 -14
View File
@@ -14,6 +14,8 @@ module PostgREST.Error
, PgError(..)
, Error(..)
, JwtError (..)
, JwtDecodeError(..)
, JwtClaimsError(..)
, errorPayload
, status
) where
@@ -644,10 +646,32 @@ data Error
deriving Show
data JwtError
= JwtDecodeError Text
= JwtDecodeErr JwtDecodeError
| JwtSecretMissing
| JwtTokenRequired
| JwtClaimsError Text
| JwtClaimsErr JwtClaimsError
deriving Show
data JwtDecodeError
= EmptyAuthHeader
| UnexpectedParts Int
| KeyError
| BadAlgorithm
| BadCrypto
| UnsupportedTokenType
| UnreachableDecodeError
deriving Show
data JwtClaimsError
= JWTExpired
| JWTNotYetValid
| JWTIssuedAtFuture
| JWTNotInAudience
| ParsingClaimsFailed
| ExpClaimNotNumber
| NbfClaimNotNumber
| IatClaimNotNumber
| AudClaimNotStringOrArray
deriving Show
instance PgrstError Error where
@@ -693,14 +717,14 @@ instance ErrorBody Error where
hint (PgErr err) = hint err
instance PgrstError JwtError where
status JwtDecodeError{} = HTTP.unauthorized401
status JwtDecodeErr{} = HTTP.unauthorized401
status JwtSecretMissing = HTTP.status500
status JwtTokenRequired = HTTP.unauthorized401
status JwtClaimsError{} = HTTP.unauthorized401
status JwtClaimsErr{} = HTTP.unauthorized401
headers (JwtDecodeError m) = [invalidTokenHeader m]
headers e@(JwtDecodeErr _) = [invalidTokenHeader $ message e]
headers JwtTokenRequired = [requiredTokenHeader]
headers (JwtClaimsError m) = [invalidTokenHeader m]
headers e@(JwtClaimsErr _) = [invalidTokenHeader $ message e]
headers _ = mempty
instance JSON.ToJSON JwtError where
@@ -708,15 +732,31 @@ instance JSON.ToJSON JwtError where
(code err) (message err) (details err) (hint err)
instance ErrorBody JwtError where
code JwtSecretMissing = "PGRST300"
code (JwtDecodeError _) = "PGRST301"
code JwtTokenRequired = "PGRST302"
code (JwtClaimsError _) = "PGRST303"
code JwtSecretMissing = "PGRST300"
code (JwtDecodeErr _) = "PGRST301"
code JwtTokenRequired = "PGRST302"
code (JwtClaimsErr _) = "PGRST303"
message JwtSecretMissing = "Server lacks JWT secret"
message (JwtDecodeError msg) = msg
message JwtTokenRequired = "Anonymous access is disabled"
message (JwtClaimsError msg) = msg
message JwtSecretMissing = "Server lacks JWT secret"
message (JwtDecodeErr e) = case e of
EmptyAuthHeader -> "Empty JWT is sent in Authorization header"
UnexpectedParts n -> "Expected 3 parts in JWT; got " <> show n
KeyError -> "No suitable key or wrong key type"
BadAlgorithm -> "Wrong or unsupported encoding algorithm"
BadCrypto -> "JWT cryptographic operation failed"
UnsupportedTokenType -> "Unsupported token type"
UnreachableDecodeError -> "JWT couldn't be decoded"
message JwtTokenRequired = "Anonymous access is disabled"
message (JwtClaimsErr e) = case e of
JWTExpired -> "JWT expired"
JWTNotYetValid -> "JWT not yet valid"
JWTIssuedAtFuture -> "JWT issued at future"
JWTNotInAudience -> "JWT not in audience"
ParsingClaimsFailed -> "Parsing claims failed"
ExpClaimNotNumber -> "The JWT 'exp' claim must be a number"
NbfClaimNotNumber -> "The JWT 'nbf' claim must be a number"
IatClaimNotNumber -> "The JWT 'iat' claim must be a number"
AudClaimNotStringOrArray -> "The JWT 'aud' claim must be a string or an array of strings"
details _ = Nothing