Extracted JWT validation functions to a separate module.
This change introduces a PostgREST.Auth.Jwt module containing JWT validation functions. The reason to extract them from Auth is to enable JwtCache module to reuse them without introducing module dependency cycle.
This commit is contained in:
Michał Kłeczek
committed by
Steve Chavez
Steve Chavez
parent
7e3fb2ba08
commit
a409a2cb94
@@ -49,6 +49,7 @@ library
|
||||
PostgREST.App
|
||||
PostgREST.AppState
|
||||
PostgREST.Auth
|
||||
PostgREST.Auth.Jwt
|
||||
PostgREST.Auth.JwtCache
|
||||
PostgREST.Auth.Types
|
||||
PostgREST.CLI
|
||||
|
||||
+14
-131
@@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-|
|
||||
Module : PostgREST.Auth
|
||||
Description : PostgREST authentication functions.
|
||||
@@ -10,8 +11,6 @@ Authentication should always be implemented in an external service.
|
||||
In the test suite there is an example of simple login function that can be used for a
|
||||
very simple authentication system inside the PostgreSQL database.
|
||||
-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module PostgREST.Auth
|
||||
( getResult
|
||||
, getJwtDur
|
||||
@@ -19,159 +18,43 @@ module PostgREST.Auth
|
||||
, middleware
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.Aeson.Key as K
|
||||
import qualified Data.Aeson.KeyMap as KM
|
||||
import qualified Data.Aeson.Types as JSON
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Internal as BS
|
||||
import qualified Data.ByteString.Lazy.Char8 as LBS
|
||||
import qualified Data.Scientific as Sci
|
||||
import qualified Data.Text as T
|
||||
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.Monad.Except (liftEither)
|
||||
import Data.Either.Combinators (mapLeft)
|
||||
import Data.List (lookup)
|
||||
import Data.Time.Clock (UTCTime, nominalDiffTimeToSeconds)
|
||||
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import System.TimeIt (timeItT)
|
||||
import Data.List (lookup)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import System.TimeIt (timeItT)
|
||||
|
||||
import PostgREST.AppState (AppState, getConfig, getJwtCacheState,
|
||||
getTime)
|
||||
import PostgREST.Auth.JwtCache (lookupJwtCache)
|
||||
import PostgREST.Auth.Types (AuthResult (..))
|
||||
import PostgREST.Config (AppConfig (..), FilterExp (..),
|
||||
JSPath, JSPathExp (..))
|
||||
import PostgREST.Error (Error (..), JwtClaimsError (..),
|
||||
JwtDecodeError (..), JwtError (..))
|
||||
import PostgREST.Config (AppConfig (..))
|
||||
import PostgREST.Error (Error (..), JwtError (..))
|
||||
|
||||
import Protolude
|
||||
|
||||
-- | Receives the JWT secret and audience (from config) and a JWT and returns a
|
||||
-- JSON object of JWT claims.
|
||||
parseToken :: AppConfig -> Maybe ByteString -> UTCTime -> ExceptT Error IO JSON.Value
|
||||
parseToken _ Nothing _ = return JSON.emptyObject
|
||||
parseToken _ (Just "") _ = throwE . JwtErr $ JwtDecodeErr EmptyAuthHeader
|
||||
parseToken AppConfig{..} (Just tkn) time = do
|
||||
secret <- liftEither . maybeToRight (JwtErr JwtSecretMissing) $ configJWKS
|
||||
tknWith3Parts <- liftEither $ hasThreeParts tkn
|
||||
eitherContent <- liftIO $ JWT.decode (JWT.keys secret) Nothing tknWith3Parts
|
||||
content <- liftEither . mapLeft (JwtErr . jwtDecodeError) $ eitherContent
|
||||
liftEither $ mapLeft JwtErr $ verifyClaims content
|
||||
where
|
||||
hasThreeParts :: ByteString -> Either Error ByteString
|
||||
hasThreeParts token = case length $ BS.split (BS.c2w '.') token of
|
||||
3 -> Right token
|
||||
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 m) = JwtDecodeErr $ KeyError m
|
||||
jwtDecodeError (JWT.BadAlgorithm m) = JwtDecodeErr $ BadAlgorithm m
|
||||
jwtDecodeError JWT.BadCrypto = JwtDecodeErr BadCrypto
|
||||
-- Control never reaches here, the decode function only returns the above three
|
||||
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 JWTExpired >>
|
||||
verifyClaim mclaims "nbf" isValidNbfClaim JWTNotYetValid >>
|
||||
verifyClaim mclaims "iat" isValidIatClaim JWTIssuedAtFuture >>
|
||||
verifyClaim mclaims "aud" isValidAudClaim JWTNotInAudience >>
|
||||
return jclaims
|
||||
_ -> Left $ JwtClaimsErr ParsingClaimsFailed
|
||||
-- TODO: We could enable JWE support here (encrypted tokens)
|
||||
verifyClaims _ = Left $ JwtDecodeErr UnsupportedTokenType
|
||||
|
||||
verifyClaim mclaims claim func err = do
|
||||
isValid <- maybe (Right True) func (KM.lookup claim mclaims)
|
||||
unless isValid $ Left $ JwtClaimsErr err
|
||||
|
||||
allowedSkewSeconds = 30 :: Int64
|
||||
now = floor . nominalDiffTimeToSeconds $ utcTimeToPOSIXSeconds time
|
||||
sciToInt = fromMaybe 0 . Sci.toBoundedInteger
|
||||
allStrings = all (\case (JSON.String _) -> True; _ -> False)
|
||||
|
||||
isValidExpClaim :: JSON.Value -> Either JwtError Bool
|
||||
isValidExpClaim (JSON.Number secs) = Right $ now <= (sciToInt secs + allowedSkewSeconds)
|
||||
isValidExpClaim _ = Left $ JwtClaimsErr ExpClaimNotNumber
|
||||
|
||||
isValidNbfClaim :: JSON.Value -> Either JwtError Bool
|
||||
isValidNbfClaim (JSON.Number secs) = Right $ now >= (sciToInt secs - allowedSkewSeconds)
|
||||
isValidNbfClaim _ = Left $ JwtClaimsErr NbfClaimNotNumber
|
||||
|
||||
isValidIatClaim :: JSON.Value -> Either JwtError Bool
|
||||
isValidIatClaim (JSON.Number secs) = Right $ now >= (sciToInt secs - allowedSkewSeconds)
|
||||
isValidIatClaim _ = Left $ JwtClaimsErr IatClaimNotNumber
|
||||
|
||||
isValidAudClaim :: JSON.Value -> Either JwtError Bool
|
||||
isValidAudClaim JSON.Null = Right True -- {"aud": null} is valid for all audiences
|
||||
isValidAudClaim (JSON.String str) = Right $ maybe (const True) (==) configJwtAudience str
|
||||
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 $ JwtClaimsErr AudClaimNotStringOrArray
|
||||
|
||||
parseClaims :: Monad m =>
|
||||
AppConfig -> JSON.Value -> ExceptT Error m AuthResult
|
||||
parseClaims AppConfig{..} jclaims@(JSON.Object mclaims) = do
|
||||
-- role defaults to anon if not specified in jwt
|
||||
role <- liftEither . maybeToRight (JwtErr JwtTokenRequired) $
|
||||
unquoted <$> walkJSPath (Just jclaims) configJwtRoleClaimKey <|> configDbAnonRole
|
||||
return AuthResult
|
||||
{ authClaims = mclaims & KM.insert "role" (JSON.toJSON $ decodeUtf8 role)
|
||||
, authRole = role
|
||||
}
|
||||
where
|
||||
walkJSPath :: Maybe JSON.Value -> JSPath -> Maybe JSON.Value
|
||||
walkJSPath x [] = x
|
||||
walkJSPath (Just (JSON.Object o)) (JSPKey key:rest) = walkJSPath (KM.lookup (K.fromText key) o) rest
|
||||
walkJSPath (Just (JSON.Array ar)) (JSPIdx idx:rest) = walkJSPath (ar V.!? idx) rest
|
||||
walkJSPath (Just (JSON.Array ar)) [JSPFilter (EqualsCond txt)] = findFirstMatch (==) txt ar
|
||||
walkJSPath (Just (JSON.Array ar)) [JSPFilter (NotEqualsCond txt)] = findFirstMatch (/=) txt ar
|
||||
walkJSPath (Just (JSON.Array ar)) [JSPFilter (StartsWithCond txt)] = findFirstMatch T.isPrefixOf txt ar
|
||||
walkJSPath (Just (JSON.Array ar)) [JSPFilter (EndsWithCond txt)] = findFirstMatch T.isSuffixOf txt ar
|
||||
walkJSPath (Just (JSON.Array ar)) [JSPFilter (ContainsCond txt)] = findFirstMatch T.isInfixOf txt ar
|
||||
walkJSPath _ _ = Nothing
|
||||
|
||||
findFirstMatch matchWith pattern = foldr checkMatch Nothing
|
||||
where
|
||||
checkMatch (JSON.String txt) acc
|
||||
| pattern `matchWith` txt = Just $ JSON.String txt
|
||||
| otherwise = acc
|
||||
checkMatch _ acc = acc
|
||||
|
||||
unquoted :: JSON.Value -> BS.ByteString
|
||||
unquoted (JSON.String t) = encodeUtf8 t
|
||||
unquoted v = LBS.toStrict $ JSON.encode v
|
||||
-- impossible case - just added to please -Wincomplete-patterns
|
||||
parseClaims _ _ = return AuthResult { authClaims = KM.empty, authRole = mempty }
|
||||
import qualified Data.Aeson.KeyMap as KM
|
||||
import PostgREST.Auth.Jwt (parseAndDecodeClaims,
|
||||
parseClaims)
|
||||
import Protolude
|
||||
|
||||
-- | Validate authorization header.
|
||||
-- Parse and store JWT claims for future use in the request.
|
||||
middleware :: AppState -> Wai.Middleware
|
||||
middleware appState app req respond = do
|
||||
conf <- getConfig appState
|
||||
cfg@AppConfig{..} <- getConfig appState
|
||||
time <- getTime appState
|
||||
|
||||
let token = Wai.extractBearerAuth =<< lookup HTTP.hAuthorization (Wai.requestHeaders req)
|
||||
parseJwt = runExceptT $ parseToken conf token time >>= parseClaims conf
|
||||
parseAuthToken = maybe (const $ throwError (JwtErr JwtSecretMissing)) parseAndDecodeClaims configJWKS
|
||||
parseJwt = runExceptT $ maybe (pure KM.empty) parseAuthToken token >>= parseClaims cfg time
|
||||
jwtCacheState = getJwtCacheState appState
|
||||
|
||||
-- If ServerTimingEnabled -> calculate JWT validation time
|
||||
-- If JwtCacheMaxLifetime -> cache JWT validation result
|
||||
req' <- case (configServerTimingEnabled conf, configJwtCacheMaxLifetime conf) of
|
||||
req' <- case (configServerTimingEnabled, configJwtCacheMaxLifetime) of
|
||||
(True, 0) -> do
|
||||
(dur, authResult) <- timeItT parseJwt
|
||||
return $ req { Wai.vault = Wai.vault req & Vault.insert authResultKey authResult & Vault.insert jwtDurKey dur }
|
||||
|
||||
@@ -0,0 +1,155 @@
|
||||
{-|
|
||||
Module : PostgREST.Auth.Jwt
|
||||
Description : PostgREST JWT support functions.
|
||||
|
||||
This module provides functions to deal with JWT parsing and validation (http://jwt.io).
|
||||
-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE ImpredicativeTypes #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE QuantifiedConstraints #-}
|
||||
|
||||
module PostgREST.Auth.Jwt
|
||||
( parseAndDecodeClaims
|
||||
, parseClaims) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.Aeson.Key as K
|
||||
import qualified Data.Aeson.KeyMap as KM
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Internal as BS
|
||||
import qualified Data.ByteString.Lazy.Char8 as LBS
|
||||
import qualified Data.Scientific as Sci
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector as V
|
||||
import qualified Jose.Jwk as JWT
|
||||
import qualified Jose.Jwt as JWT
|
||||
|
||||
import Control.Monad.Except (liftEither)
|
||||
import Data.Either.Combinators (mapLeft)
|
||||
import Data.Text ()
|
||||
import Data.Time.Clock (UTCTime, nominalDiffTimeToSeconds)
|
||||
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
|
||||
|
||||
import PostgREST.Auth.Types (AuthResult (..))
|
||||
import PostgREST.Config (AppConfig (..), FilterExp (..), JSPath,
|
||||
JSPathExp (..))
|
||||
import PostgREST.Error (Error (..),
|
||||
JwtClaimsError (AudClaimNotStringOrArray, ExpClaimNotNumber, IatClaimNotNumber, JWTExpired, JWTIssuedAtFuture, JWTNotInAudience, JWTNotYetValid, NbfClaimNotNumber, ParsingClaimsFailed),
|
||||
JwtDecodeError (..), JwtError (..))
|
||||
|
||||
import Data.Aeson ((.:?))
|
||||
import Data.Aeson.Types (parseMaybe)
|
||||
import Jose.Jwk (JwkSet)
|
||||
import Protolude hiding (first)
|
||||
|
||||
parseAndDecodeClaims :: (MonadError Error m, MonadIO m) => JwkSet -> ByteString -> m JSON.Object
|
||||
parseAndDecodeClaims jwkSet token = parseToken jwkSet token >>= decodeClaims
|
||||
|
||||
decodeClaims :: MonadError Error m => JWT.JwtContent -> m JSON.Object
|
||||
decodeClaims (JWT.Jws (_, claims)) = maybe (throwError (JwtErr $ JwtClaimsErr ParsingClaimsFailed)) pure (JSON.decodeStrict claims)
|
||||
decodeClaims _ = throwError $ JwtErr $ JwtDecodeErr UnsupportedTokenType
|
||||
|
||||
validateClaims :: MonadError Error m => UTCTime -> Maybe Text -> JSON.Object -> m ()
|
||||
validateClaims time getConfigAud claims = liftEither $ maybeToLeft () (fmap JwtErr . getAlt $ JwtClaimsErr <$> checkForErrors time getConfigAud claims)
|
||||
|
||||
data ValidAud = VANull | VAString Text | VAArray [Text] deriving Generic
|
||||
instance JSON.FromJSON ValidAud where
|
||||
parseJSON JSON.Null = pure VANull
|
||||
parseJSON o = JSON.genericParseJSON JSON.defaultOptions { JSON.sumEncoding = JSON.UntaggedValue } o
|
||||
|
||||
checkForErrors :: (Monad m, forall a. Monoid (m a)) => UTCTime -> Maybe Text -> JSON.Object -> m JwtClaimsError
|
||||
checkForErrors time cfgAud = mconcat
|
||||
[
|
||||
claim "exp" ExpClaimNotNumber $ inThePast JWTExpired
|
||||
, claim "nbf" NbfClaimNotNumber $ inTheFuture JWTNotYetValid
|
||||
, claim "iat" IatClaimNotNumber $ inTheFuture JWTIssuedAtFuture
|
||||
, claim "aud" AudClaimNotStringOrArray checkAud
|
||||
]
|
||||
where
|
||||
allowedSkewSeconds = 30 :: Int64
|
||||
sciToInt = fromMaybe 0 . Sci.toBoundedInteger
|
||||
toSec = floor . nominalDiffTimeToSeconds . utcTimeToPOSIXSeconds
|
||||
now = toSec time
|
||||
|
||||
inTheFuture = checkTime ((now + allowedSkewSeconds) <)
|
||||
inThePast = checkTime ((now - allowedSkewSeconds) >)
|
||||
|
||||
checkTime cond = checkValue (cond. sciToInt)
|
||||
|
||||
checkAud = \case
|
||||
(VAString aud) -> liftMaybe cfgAud >>= checkValue (aud /=) JWTNotInAudience
|
||||
(VAArray auds) | (not . null) auds -> liftMaybe cfgAud >>= checkValue (not . (`elem` auds)) JWTNotInAudience
|
||||
_ -> mempty
|
||||
|
||||
liftMaybe = maybe mempty pure
|
||||
|
||||
checkValue invalid msg val =
|
||||
if invalid val then
|
||||
pure msg
|
||||
else
|
||||
mempty
|
||||
|
||||
claim key parseError checkParsed = maybe (pure parseError) (maybe mempty checkParsed) . parseMaybe (.:? key)
|
||||
|
||||
-- | Receives the JWT secret and audience (from config) and a JWT and returns a
|
||||
-- JSON object of JWT claims.
|
||||
parseToken :: (MonadError Error m, MonadIO m) => JwkSet -> ByteString -> m JWT.JwtContent
|
||||
parseToken _ "" = throwError $ JwtErr $ JwtDecodeErr EmptyAuthHeader
|
||||
parseToken secret tkn = do
|
||||
-- secret <- liftEither . maybeToRight (JwtErr JwtSecretMissing) $ configJWKS
|
||||
tknWith3Parts <- hasThreeParts tkn
|
||||
eitherContent <- liftIO $ JWT.decode (JWT.keys secret) Nothing tknWith3Parts
|
||||
liftEither . mapLeft (JwtErr . jwtDecodeError) $ eitherContent
|
||||
--liftEither $ mapLeft JwtErr $ verifyClaims content
|
||||
where
|
||||
--hasThreeParts :: ByteString -> Either Error ByteString
|
||||
hasThreeParts token = case length $ BS.split (BS.c2w '.') token of
|
||||
3 -> pure token
|
||||
n -> throwError $ 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 m) = JwtDecodeErr $ KeyError m
|
||||
jwtDecodeError (JWT.BadAlgorithm m) = JwtDecodeErr $ BadAlgorithm m
|
||||
jwtDecodeError JWT.BadCrypto = JwtDecodeErr BadCrypto
|
||||
-- Control never reaches here, the decode function only returns the above three
|
||||
jwtDecodeError _ = JwtDecodeErr UnreachableDecodeError
|
||||
|
||||
parseClaims :: (MonadError Error m, MonadIO m) => AppConfig -> UTCTime -> JSON.Object -> m AuthResult
|
||||
parseClaims AppConfig{configJwtAudience, configJwtRoleClaimKey, configDbAnonRole} time mclaims = do
|
||||
validateClaims time configJwtAudience mclaims
|
||||
-- role defaults to anon if not specified in jwt
|
||||
role <- liftEither . maybeToRight (JwtErr JwtTokenRequired) $
|
||||
unquoted <$> walkJSPath (Just $ JSON.Object mclaims) configJwtRoleClaimKey <|> configDbAnonRole
|
||||
pure AuthResult
|
||||
{ authClaims = mclaims & KM.insert "role" (JSON.toJSON $ decodeUtf8 role)
|
||||
, authRole = role
|
||||
}
|
||||
where
|
||||
walkJSPath :: Maybe JSON.Value -> JSPath -> Maybe JSON.Value
|
||||
walkJSPath x [] = x
|
||||
walkJSPath (Just (JSON.Object o)) (JSPKey key:rest) = walkJSPath (KM.lookup (K.fromText key) o) rest
|
||||
walkJSPath (Just (JSON.Array ar)) (JSPIdx idx:rest) = walkJSPath (ar V.!? idx) rest
|
||||
walkJSPath (Just (JSON.Array ar)) [JSPFilter (EqualsCond txt)] = findFirstMatch (==) txt ar
|
||||
walkJSPath (Just (JSON.Array ar)) [JSPFilter (NotEqualsCond txt)] = findFirstMatch (/=) txt ar
|
||||
walkJSPath (Just (JSON.Array ar)) [JSPFilter (StartsWithCond txt)] = findFirstMatch T.isPrefixOf txt ar
|
||||
walkJSPath (Just (JSON.Array ar)) [JSPFilter (EndsWithCond txt)] = findFirstMatch T.isSuffixOf txt ar
|
||||
walkJSPath (Just (JSON.Array ar)) [JSPFilter (ContainsCond txt)] = findFirstMatch T.isInfixOf txt ar
|
||||
walkJSPath _ _ = Nothing
|
||||
|
||||
findFirstMatch matchWith pattern = foldr checkMatch Nothing
|
||||
where
|
||||
checkMatch (JSON.String txt) acc
|
||||
| pattern `matchWith` txt = Just $ JSON.String txt
|
||||
| otherwise = acc
|
||||
checkMatch _ acc = acc
|
||||
|
||||
unquoted :: JSON.Value -> BS.ByteString
|
||||
unquoted (JSON.String t) = encodeUtf8 t
|
||||
unquoted v = LBS.toStrict $ JSON.encode v
|
||||
Reference in New Issue
Block a user