diff --git a/postgrest.cabal b/postgrest.cabal index 91dd4504e..7e21f21f6 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -49,6 +49,7 @@ library PostgREST.App PostgREST.AppState PostgREST.Auth + PostgREST.Auth.Jwt PostgREST.Auth.JwtCache PostgREST.Auth.Types PostgREST.CLI diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs index 8a6b3efed..857714c03 100644 --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -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 } diff --git a/src/PostgREST/Auth/Jwt.hs b/src/PostgREST/Auth/Jwt.hs new file mode 100644 index 000000000..3223ff744 --- /dev/null +++ b/src/PostgREST/Auth/Jwt.hs @@ -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