refactor: move jwt error messages to Error.hs module

src/PostgREST/Auth.hs

@@ -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.KeyError _)     = JwtDecodeErr KeyError
-      jwtDecodeError (JWT.BadAlgorithm _) = JwtDecodeError "Wrong or unsupported encoding algorithm"
+      jwtDecodeError (JWT.BadAlgorithm _) = JwtDecodeErr BadAlgorithm
-      jwtDecodeError JWT.BadCrypto        = JwtDecodeError "JWT cryptographic operation failed"
+      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 "exp" isValidExpClaim JWTExpired >>
-          verifyClaim mclaims "nbf" isValidNbfClaim "JWT not yet valid" >>
+          verifyClaim mclaims "nbf" isValidNbfClaim JWTNotYetValid >>
-          verifyClaim mclaims "iat" isValidIatClaim "JWT issued at future" >>
+          verifyClaim mclaims "iat" isValidIatClaim JWTIssuedAtFuture >>
-          verifyClaim mclaims "aud" isValidAudClaim "JWT not in audience" >>
+          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

src/PostgREST/Error.hs

@@ -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 JwtSecretMissing = "PGRST300"
-  code (JwtDecodeError _) = "PGRST301"
+  code (JwtDecodeErr _) = "PGRST301"
-  code JwtTokenRequired   = "PGRST302"
+  code JwtTokenRequired = "PGRST302"
-  code (JwtClaimsError _) = "PGRST303"
+  code (JwtClaimsErr _) = "PGRST303"
 
-  message JwtSecretMissing     = "Server lacks JWT secret"
+  message JwtSecretMissing = "Server lacks JWT secret"
-  message (JwtDecodeError msg) = msg
+  message (JwtDecodeErr e) = case e of
-  message JwtTokenRequired     = "Anonymous access is disabled"
+    EmptyAuthHeader        -> "Empty JWT is sent in Authorization header"
-  message (JwtClaimsError msg) = msg
+    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