Allow IO in JWTSettings' validationKeys

This commit is contained in:
Julian K. Arni 2022-04-14 11:03:03 +02:00
parent c48a6702b7
commit 3006e90126
2 changed files with 6 additions and 5 deletions

View file

@ -33,7 +33,7 @@ data JWTSettings = JWTSettings
-- | Algorithm used to sign JWT.
, jwtAlg :: Maybe Jose.Alg
-- | Keys used to validate JWT.
, validationKeys :: Jose.JWKSet
, validationKeys :: IO Jose.JWKSet
-- | An @aud@ predicate. The @aud@ is a string or URI that identifies the
-- intended recipient of the JWT.
, audienceMatches :: Jose.StringOrURI -> IsMatch
@ -44,7 +44,7 @@ defaultJWTSettings :: Jose.JWK -> JWTSettings
defaultJWTSettings k = JWTSettings
{ signingKey = k
, jwtAlg = Nothing
, validationKeys = Jose.JWKSet [k]
, validationKeys = pure $ Jose.JWKSet [k]
, audienceMatches = const Matches }
-- | The policies to use when generating cookies.

View file

@ -58,14 +58,15 @@ makeJWT v cfg expiry = runExceptT $ do
verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a)
verifyJWT jwtCfg input = do
verifiedJWT <- liftIO $ runExceptT $ do
keys <- validationKeys jwtCfg
verifiedJWT <- runExceptT $ do
unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)
Jose.verifyClaims
(jwtSettingsToJwtValidationSettings jwtCfg)
(validationKeys jwtCfg)
keys
unverifiedJWT
return $ case verifiedJWT of
Left (_ :: Jose.JWTError) -> Nothing
Right v -> case decodeJWT v of
Left _ -> Nothing
Right v' -> Just v'
Right v' -> Just v'