diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,16 @@ `libjwt-typed` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 0.2 + +New features + +* Ability to **use public keys only if you do not intend to sign tokens**. This feature is backwards incompatible: + * Function `signJwt` has been removed in favor of `sign` and `sign'` + * Signing and decoding functions now depend on the new `Algorithm k` type and their contexts have been extended to accomodate new key classes (`SigningKey` and `DecodingKey` respectively) + * JWT header `alg` is now an enumeration, handling of all key data has been moved to `Algorithm` + + ## 0.1 * Initially created. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -78,11 +78,11 @@ ```haskell {-# LANGUAGE OverloadedStrings #-} -import Web.Libjwt ( Alg(HS512) ) +import Web.Libjwt -hmac512 :: Alg +hmac512 :: Algorithm Secret hmac512 = - HS512 + HMAC512 "MjZkMDY2OWFiZmRjYTk5YjczZWFiZjYzMmRjMzU5NDYyMjMxODBjMTg3ZmY5OTZjM2NhM2NhN2Mx\ \YzFiNDNlYjc4NTE1MjQxZGI0OWM1ZWI2ZDUyZmMzZDlhMmFiNjc5OWJlZTUxNjE2ZDRlYTNkYjU5\ \Y2IwMDZhYWY1MjY1OTQgIC0K" @@ -96,10 +96,8 @@ Obtaining or reading keys is beyond the scope of this library. It accepts PEM-encoded RSA/ECDSA keys as `ByteString`s ```haskell -import Web.Libjwt ( Alg(..) - , EcKeyPair(..) - , RsaKeyPair(..) - ) +import Web.Libjwt + import qualified Data.ByteString.Char8 as C8 rsa2048KeyPair :: RsaKeyPair @@ -118,8 +116,8 @@ ] in FromRsaPem { privKey = private, pubKey = public } -rs512 :: Alg -rs512 = RS512 rsa2048KeyPair +rsa512 :: Algorithm RsaKeyPair +rsa512 = RSA512 rsa2048KeyPair ecP521KeyPair :: EcKeyPair ecP521KeyPair = @@ -137,8 +135,8 @@ ] in FromEcPem { ecPrivKey = private, ecPubKey = public } -es512 :: Alg -es512 = ES512 ecP521KeyPair +ecdsa512 :: Algorithm EcKeyPair +ecdsa512 = ECDSA512 ecP521KeyPair ``` A key of size 2048 bits or larger MUST be used for RSA algorithms. @@ -148,6 +146,28 @@ and the SHA-384 hash function, and ECDSA with the P-521 curve [secp521r1] and the SHA-512 hash function." +As of version **0.2**, you do not need private keys as long as you only decode tokens. This is obviously a type-safe feature, so you cannot pass a public-key to the signing function. +Type system checks it for you. + +```haskell +import Web.Libjwt + +import qualified Data.ByteString.Char8 as C8 + +rsaPub :: RsaPubKey +rsaPub = + let public = C8.pack $ unlines + [ "-----BEGIN PUBLIC KEY-----" + , "MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAwCXp2P+qboao0tjUyU+D" + -- ... + , "-----END PUBLIC KEY-----" + ] + in FromRsaPub { rsaPublicKey = public } + +rsa512 :: Algorithm RsaPubKey +rsa512 = RSA512 rsaPub +``` + ## Usage ### Create a payload @@ -341,7 +361,7 @@ ``` -JWT validation is monoid. You can append additional validations based on public and private claims, for example `checkIssuer "myApp" <> checkClaim (== True) #isRoot`. You will certainly like the fact that private claims' types are fullly known, so you can operate on type-safe Haskell values (`checkClaim ( > 0) #isRoot` will not compile). The `mempty` validation (the default validation) checks (according to [the rules in the RFC](https://tools.ietf.org/html/rfc7519#section-4.1) ) whether: +JWT validation is a monoid. You can append additional validations based on public and private claims, for example `checkIssuer "myApp" <> checkClaim (== True) #isRoot`. You will certainly like the fact that private claims' types are fullly known, so you can operate on type-safe Haskell values (`checkClaim ( > 0) #isRoot` will not compile). The `mempty` validation (the default validation) checks (according to [the rules in the RFC](https://tools.ietf.org/html/rfc7519#section-4.1) ) whether: * token has not expired (`exp` claim), * token is ready to use (`nbf` claim), * token is intended for you (`aud` claim) diff --git a/bench/Algorithms.hs b/bench/Algorithms.hs --- a/bench/Algorithms.hs +++ b/bench/Algorithms.hs @@ -13,7 +13,8 @@ ) where -import Web.Libjwt ( Alg(..) +import Web.Libjwt ( Algorithm(..) + , Secret , EcKeyPair(..) , RsaKeyPair(..) ) @@ -30,9 +31,9 @@ import Data.Maybe ( fromJust ) -hs512 :: Alg +hs512 :: Algorithm Secret hs512 = - HS512 + HMAC512 "MjZkMDY2OWFiZmRjYTk5YjczZWFiZjYzMmRjMzU5NDYyMjMxODBjMTg3ZmY5OTZjM2NhM2NhN2Mx\ \YzFiNDNlYjc4NTE1MjQxZGI0OWM1ZWI2ZDUyZmMzZDlhMmFiNjc5OWJlZTUxNjE2ZDRlYTNkYjU5\ \Y2IwMDZhYWY1MjY1OTQgIC0K" @@ -81,11 +82,11 @@ ] in FromRsaPem { privKey = private, pubKey = public } -rs256 :: Alg -rs256 = RS256 rsa2048KeyPair +rs256 :: Algorithm RsaKeyPair +rs256 = RSA256 rsa2048KeyPair -rs512 :: Alg -rs512 = RS512 rsa2048KeyPair +rs512 :: Algorithm RsaKeyPair +rs512 = RSA512 rsa2048KeyPair ecP256KeyPair :: EcKeyPair ecP256KeyPair = @@ -104,8 +105,8 @@ ] in FromEcPem { ecPrivKey = private, ecPubKey = public } -es256 :: Alg -es256 = ES256 ecP256KeyPair +es256 :: Algorithm EcKeyPair +es256 = ECDSA256 ecP256KeyPair ecP521KeyPair :: EcKeyPair ecP521KeyPair = @@ -128,8 +129,8 @@ ] in FromEcPem { ecPrivKey = private, ecPubKey = public } -es512 :: Alg -es512 = ES512 ecP521KeyPair +es512 :: Algorithm EcKeyPair +es512 = ECDSA512 ecP521KeyPair jwkHS512 :: (Jose.Alg, JWK) jwkHS512 = diff --git a/bench/Benchmarks.hs b/bench/Benchmarks.hs --- a/bench/Benchmarks.hs +++ b/bench/Benchmarks.hs @@ -1,4 +1,3 @@ - module Main ( main ) @@ -17,74 +16,49 @@ "signing" [ bgroup "HMAC512" - [ my $ mySigning <*> pure hs512 - , jose $ joseSigning <*> pure jwkHS512 + [ my $ My.signing <*> pure hs512 + , jose $ Jose.signing <*> pure jwkHS512 ] , bgroup "RSA512" - [ my $ mySigning <*> pure rs512 - , jose $ joseSigning <*> pure jwkRS512 + [ my $ My.signing <*> pure rs512 + , jose $ Jose.signing <*> pure jwkRS512 ] , bgroup "ECDSA256" - [ my $ mySigning <*> pure es256 - , jose $ joseSigning <*> pure jwkES256 + [ my $ My.signing <*> pure es256 + , jose $ Jose.signing <*> pure jwkES256 ] , bgroup "ECDSA512" - [ my $ mySigning <*> pure es512 - , jose $ joseSigning <*> pure jwkES512 + [ my $ My.signing <*> pure es512 + , jose $ Jose.signing <*> pure jwkES512 ] ] , bgroup "decoding" [ bgroup "HMAC512" - [ my $ myDecoding <*> pure hs512 - , jose $ joseDecoding <*> pure jwkHS512 + [ my $ My.decoding <*> pure hs512 + , jose $ Jose.decoding <*> pure jwkHS512 ] , bgroup "RSA512" - [ my $ myDecoding <*> pure rs512 - , jose $ joseDecoding <*> pure jwkRS512 + [ my $ My.decoding <*> pure rs512 + , jose $ Jose.decoding <*> pure jwkRS512 ] , bgroup "ECDSA256" - [ my $ myDecoding <*> pure es256 - , jose $ joseDecoding <*> pure jwkES256 + [ my $ My.decoding <*> pure es256 + , jose $ Jose.decoding <*> pure jwkES256 ] , bgroup "ECDSA512" - [ my $ myDecoding <*> pure es512 - , jose $ joseDecoding <*> pure jwkES512 + [ my $ My.decoding <*> pure es512 + , jose $ Jose.decoding <*> pure jwkES512 ] ] ] where jose = bgroup "jose" - joseSigning = - [ Jose.signSimple - , Jose.signCustomClaims - , Jose.signCustomClaimsWithNs - , Jose.signComplexClaims - ] - joseDecoding = - [ Jose.decodeSimple - , Jose.decodeCustomClaims - , Jose.decodeCustomClaimsWithNs - , Jose.decodeComplexClaims - ] - - my = bgroup "libjwt" - mySigning = - [ My.signSimple - , My.signCustomClaims - , My.signWithNs - , My.signComplexCustomClaims - ] - myDecoding = - [ My.decodeSimple - , My.decodeCustomClaims - , My.decodeWithNs - , My.decodeComplexCustomClaims - ] + my = bgroup "libjwt" diff --git a/bench/Benchmarks/Jose.hs b/bench/Benchmarks/Jose.hs --- a/bench/Benchmarks/Jose.hs +++ b/bench/Benchmarks/Jose.hs @@ -2,14 +2,8 @@ {-# LANGUAGE RecordWildCards #-} module Benchmarks.Jose - ( signSimple - , decodeSimple - , signCustomClaims - , decodeCustomClaims - , signCustomClaimsWithNs - , decodeCustomClaimsWithNs - , signComplexClaims - , decodeComplexClaims + ( signing + , decoding ) where @@ -60,6 +54,18 @@ import Data.UUID ( UUID ) import Data.List.NonEmpty ( NonEmpty ) + +signing :: [(Alg, JWK) -> Benchmark] +signing = + [signSimple, signCustomClaims, signCustomClaimsWithNs, signComplexClaims] + +decoding :: [(Alg, JWK) -> Benchmark] +decoding = + [ decodeSimple + , decodeCustomClaims + , decodeCustomClaimsWithNs + , decodeComplexClaims + ] doSign :: Alg -> JWK -> ClaimsSet -> IO ByteString diff --git a/bench/Benchmarks/Libjwt.hs b/bench/Benchmarks/Libjwt.hs --- a/bench/Benchmarks/Libjwt.hs +++ b/bench/Benchmarks/Libjwt.hs @@ -6,14 +6,7 @@ {-# LANGUAGE TypeOperators #-} module Benchmarks.Libjwt - ( signSimple - , signCustomClaims - , signWithNs - , signComplexCustomClaims - , decodeSimple - , decodeCustomClaims - , decodeWithNs - , decodeComplexCustomClaims + ( signing, decoding ) where @@ -42,6 +35,22 @@ import Prelude hiding ( exp ) +signing :: SigningKey k => [Algorithm k -> Benchmark] +signing = + [ signSimple + , signCustomClaims + , signWithNs + , signComplexCustomClaims + ] + +decoding :: SigningKey k => [Algorithm k -> Benchmark] +decoding = + [ decodeSimple + , decodeCustomClaims + , decodeWithNs + , decodeComplexCustomClaims + ] + basePayload :: BenchEnv -> Payload Empty 'NoNs basePayload LocalEnv {..} = def { iss = Iss (Just "benchmarks") , aud = Aud ["https://example.com"] @@ -52,31 +61,27 @@ } prepareToken - :: Encode (PrivateClaims pc ns) - => Alg - -> (Alg -> BenchEnv -> Jwt pc ns) + :: (SigningKey k, Encode (PrivateClaims pc ns)) + => Algorithm k + -> (BenchEnv -> Payload pc ns) -> IO ByteString -prepareToken a jwt = getToken . signJwt . jwt a <$> localEnv +prepareToken a mkPayload = getToken . sign a . mkPayload <$> localEnv type SimpleJwt = Jwt Empty 'NoNs -mkSimpleJwt :: Alg -> BenchEnv -> SimpleJwt -mkSimpleJwt a e = Jwt { header = Header a JWT, payload = basePayload e } - -signSimple :: Alg -> Benchmark +signSimple :: SigningKey k => Algorithm k -> Benchmark signSimple a = env localEnv $ bench "simple" . nf benchmark - where benchmark = getToken . signJwt . mkSimpleJwt a + where benchmark = getToken . sign a . basePayload -decodeSimple :: Alg -> Benchmark +decodeSimple :: SigningKey k => Algorithm k -> Benchmark decodeSimple a = - env (prepareToken a mkSimpleJwt) $ bench "simple" . whnfAppIO benchmark + env (prepareToken a basePayload) $ bench "simple" . whnfAppIO benchmark where - benchmark :: ByteString -> IO (ValidationNEL ValidationFailure SimpleJwt) - benchmark = - fmap (fmap getValid) - . jwtFromByteString validationSettings (checkIssuer "benchmarks") a + benchmark + :: ByteString -> IO (ValidationNEL ValidationFailure (Validated SimpleJwt)) + benchmark = jwtFromByteString validationSettings (checkIssuer "benchmarks") a @@ -85,27 +90,30 @@ '["userName" ->> Text, "isRoot" ->> Bool, "clientId" ->> UUID, "created" ->> UTCTime, "scope" ->> Flag Scope] 'NoNs -mkCustomJwt :: Alg -> BenchEnv -> CustomJwt -mkCustomJwt a e@LocalEnv {..} = Jwt - { header = Header a JWT - , payload = (basePayload e) - { privateClaims = toPrivateClaims - ( #userName ->> shortPrintableText - , #isRoot ->> flipBit - , #clientId ->> uuid - , #created ->> currentTimeUtc - , #scope ->> Flag Login - ) - } +customPayload :: BenchEnv + -> Payload + '["userName" ->> Text, "isRoot" ->> Bool, "clientId" ->> UUID, + "created" ->> UTCTime, "scope" ->> Flag Scope] + 'NoNs +customPayload e@LocalEnv {..} = (basePayload e) + { privateClaims = toPrivateClaims + ( #userName ->> shortPrintableText + , #isRoot ->> flipBit + , #clientId ->> uuid + , #created ->> currentTimeUtc + , #scope ->> Flag Login + ) } -signCustomClaims :: Alg -> Benchmark +signCustomClaims :: SigningKey k => Algorithm k -> Benchmark signCustomClaims a = env localEnv $ bench "custom-claims" . nf benchmark - where benchmark = getToken . signJwt . mkCustomJwt a + where benchmark = getToken . sign a . customPayload -decodeCustomClaims :: Alg -> Benchmark +decodeCustomClaims :: SigningKey k => Algorithm k -> Benchmark decodeCustomClaims a = - env (prepareToken a mkCustomJwt) $ bench "custom-claims" . whnfAppIO benchmark + env (prepareToken a customPayload) + $ bench "custom-claims" + . whnfAppIO benchmark where benchmark :: ByteString -> IO (ValidationNEL ValidationFailure (Validated CustomJwt)) @@ -118,28 +126,29 @@ '["userName" ->> Text, "isRoot" ->> Bool, "clientId" ->> UUID, "created" ->> UTCTime, "scope" ->> Flag Scope] ( 'SomeNs "https://www.example.com/test") -mkCustomJwtWithNs :: Alg -> BenchEnv -> CustomJwtWithNs -mkCustomJwtWithNs a e@LocalEnv {..} = Jwt - { header = Header a JWT - , payload = (basePayload e) - { privateClaims = toPrivateClaims $ withNs - (Ns @"https://www.example.com/test") - ( #userName ->> shortPrintableText - , #isRoot ->> flipBit - , #clientId ->> uuid - , #created ->> currentTimeUtc - , #scope ->> Flag Login - ) - } +customPayloadWithNs :: BenchEnv + -> Payload + '["userName" ->> Text, "isRoot" ->> Bool, "clientId" ->> UUID, + "created" ->> UTCTime, "scope" ->> Flag Scope] + ('SomeNs "https://www.example.com/test") +customPayloadWithNs e@LocalEnv {..} = (basePayload e) + { privateClaims = toPrivateClaims $ withNs + (Ns @"https://www.example.com/test") + ( #userName ->> shortPrintableText + , #isRoot ->> flipBit + , #clientId ->> uuid + , #created ->> currentTimeUtc + , #scope ->> Flag Login + ) } -signWithNs :: Alg -> Benchmark +signWithNs :: SigningKey k => Algorithm k -> Benchmark signWithNs a = env localEnv $ bench "custom-claims-with-ns" . nf benchmark - where benchmark = getToken . signJwt . mkCustomJwtWithNs a + where benchmark = getToken . sign a . customPayloadWithNs -decodeWithNs :: Alg -> Benchmark +decodeWithNs :: SigningKey k => Algorithm k -> Benchmark decodeWithNs a = - env (prepareToken a mkCustomJwtWithNs) + env (prepareToken a customPayloadWithNs) $ bench "custom-claims-with-ns" . whnfAppIO benchmark where @@ -155,37 +164,39 @@ '["user_name" ->> Text, "is_root" ->> Bool, "client_id" ->> UUID, "created" ->> UTCTime, "accounts" ->> NonEmpty (UUID, Text), "scopes" ->> [Flag Scope], "emails" ->> [String]] 'NoNs -mkComplexJwt :: Alg -> BenchEnv -> ComplexJwt -mkComplexJwt a e@LocalEnv {..} = Jwt - { header = Header a JWT - , payload = (basePayload e) - { privateClaims = toPrivateClaims - ( #user_name ->> shortPrintableText - , #is_root ->> flipBit - , #client_id ->> uuid - , #created ->> currentTimeUtc - , #accounts ->> accountList - , #scopes - ->> [ Flag Login - , Flag Extended - , Flag UserRead - , Flag UserWrite - , Flag AccountRead - , Flag AccountWrite - ] - , #emails ->> emailsList - ) - } +complexPayload :: BenchEnv + -> Payload + '["user_name" ->> Text, "is_root" ->> Bool, "client_id" ->> UUID, + "created" ->> UTCTime, "accounts" ->> NonEmpty (UUID, Text), + "scopes" ->> [Flag Scope], "emails" ->> [String]] + 'NoNs +complexPayload e@LocalEnv {..} = (basePayload e) + { privateClaims = toPrivateClaims + ( #user_name ->> shortPrintableText + , #is_root ->> flipBit + , #client_id ->> uuid + , #created ->> currentTimeUtc + , #accounts ->> accountList + , #scopes + ->> [ Flag Login + , Flag Extended + , Flag UserRead + , Flag UserWrite + , Flag AccountRead + , Flag AccountWrite + ] + , #emails ->> emailsList + ) } -signComplexCustomClaims :: Alg -> Benchmark +signComplexCustomClaims :: SigningKey k => Algorithm k -> Benchmark signComplexCustomClaims a = env localEnv $ bench "complex-claims" . nf benchmark - where benchmark = getToken . signJwt . mkComplexJwt a + where benchmark = getToken . sign a . complexPayload -decodeComplexCustomClaims :: Alg -> Benchmark +decodeComplexCustomClaims :: SigningKey k => Algorithm k -> Benchmark decodeComplexCustomClaims a = - env (prepareToken a mkComplexJwt) + env (prepareToken a complexPayload) $ bench "complex-claims" . whnfAppIO benchmark where diff --git a/libjwt-typed.cabal b/libjwt-typed.cabal --- a/libjwt-typed.cabal +++ b/libjwt-typed.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: libjwt-typed -version: 0.1 +version: 0.2 synopsis: A Haskell implementation of JSON Web Token (JWT) description: A Haskell implementation of JSON Web Token (JWT) . @@ -49,6 +49,7 @@ CHANGELOG.md tested-with: GHC == 8.8.3 GHC == 8.10.1 + GHC == 8.10.2 source-repository head type: git @@ -108,6 +109,7 @@ Libjwt.Encoding Libjwt.Decoding Libjwt.Keys + Libjwt.Algorithms Libjwt.JsonByteString Libjwt.FFI.Jwt other-modules: Libjwt.FFI.Jsmn diff --git a/src/Libjwt/Algorithms.hs b/src/Libjwt/Algorithms.hs new file mode 100644 --- /dev/null +++ b/src/Libjwt/Algorithms.hs @@ -0,0 +1,112 @@ +-- This Source Code Form is subject to the terms of the Mozilla Public +-- License, v. 2.0. If a copy of the MPL was not distributed with this +-- file, You can obtain one at http://mozilla.org/MPL/2.0/. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Algorithms used to sign and validate JWT signatures +module Libjwt.Algorithms + ( Algorithm(..) + , RsaKey + , EcKey + , toHeaderAlg + , jwtAlgWithKey + ) +where + +import Libjwt.Header ( Alg(..) ) +import Libjwt.FFI.Libjwt +import Libjwt.Keys + +import Data.Kind ( Constraint ) + +import GHC.TypeLits + +-- | Cryptographic algorithm used to secure the JWT +data Algorithm k where + -- | HMAC SHA-256 (secret key must be __at least 256 bits in size__) + HMAC256 ::Secret -> Algorithm Secret + -- | HMAC SHA-384 (secret key must be __at least 384 bits in size__) + HMAC384 ::Secret -> Algorithm Secret + -- | HMAC SHA-512 (secret key must be __at least 512 bits in size__) + HMAC512 ::Secret -> Algorithm Secret + -- | RSASSA-PKCS1-v1_5 SHA-256 (a key of size __2048 bits or larger__ must be used with this algorithm) + RSA256 ::RsaKey r => r -> Algorithm r + -- | RSASSA-PKCS1-v1_5 SHA-384 (a key of size __2048 bits or larger__ must be used with this algorithm) + RSA384 ::RsaKey r => r -> Algorithm r + -- | RSASSA-PKCS1-v1_5 SHA-512 (a key of size __2048 bits or larger__ must be used with this algorithm) + RSA512 ::RsaKey r => r -> Algorithm r + -- | ECDSA with P-256 curve and SHA-256 + ECDSA256 ::EcKey e => e -> Algorithm e + -- | ECDSA with P-384 curve and SHA-384 + ECDSA384 ::EcKey e => e -> Algorithm e + -- | ECDSA with P-521 curve and SHA-512 + ECDSA512 ::EcKey e => e -> Algorithm e + -- | None + AlgNone ::Algorithm () + +deriving stock instance Show k => Show (Algorithm k) + +type family RsaKey t :: Constraint where + RsaKey RsaKeyPair = () + RsaKey RsaPubKey = () + RsaKey a = TypeError ('Text "RSASSA-PKCS-v1_5 cannot be used with " ':<>: 'ShowType a) + +type family EcKey t :: Constraint where + EcKey EcKeyPair = () + EcKey EcPubKey = () + EcKey a = TypeError ('Text "ECDSA cannot be used with " ':<>: 'ShowType a) + +jwtAlgWithKey :: Algorithm k -> (JwtAlgT, k) +jwtAlgWithKey (HMAC256 secret) = (jwtAlgHs256, secret) +jwtAlgWithKey (HMAC384 secret) = (jwtAlgHs384, secret) +jwtAlgWithKey (HMAC512 secret) = (jwtAlgHs512, secret) +jwtAlgWithKey (RSA256 key ) = (jwtAlgRs256, key) +jwtAlgWithKey (RSA384 key ) = (jwtAlgRs384, key) +jwtAlgWithKey (RSA512 key ) = (jwtAlgRs512, key) +jwtAlgWithKey (ECDSA256 key ) = (jwtAlgEs256, key) +jwtAlgWithKey (ECDSA384 key ) = (jwtAlgEs384, key) +jwtAlgWithKey (ECDSA512 key ) = (jwtAlgEs512, key) +jwtAlgWithKey AlgNone = (jwtAlgNone, ()) + +-- | Get the header parameter "alg" from the algorithm +-- +-- +------------+-----------+ +-- |Algorithm | 'alg' | +-- +============+===========+ +-- |'HMAC256' | 'HS256' | +-- +------------+-----------+ +-- |'HMAC384' | 'HS384' | +-- +------------+-----------+ +-- |'HMAC512' | 'HS512' | +-- +------------+-----------+ +-- |'RSA256' | 'RS256' | +-- +------------+-----------+ +-- |'RSA384' | 'RS384' | +-- +------------+-----------+ +-- |'RSA512' | 'RS512' | +-- +------------+-----------+ +-- |'ECDSA256' | 'ES256' | +-- +------------+-----------+ +-- |'ECDSA384' | 'ES384' | +-- +------------+-----------+ +-- |'ECDSA512' | 'ES512' | +-- +------------+-----------+ +-- +toHeaderAlg :: Algorithm k -> Alg +toHeaderAlg (HMAC256 _) = HS256 +toHeaderAlg (HMAC384 _) = HS384 +toHeaderAlg (HMAC512 _) = HS512 +toHeaderAlg (RSA256 _) = RS256 +toHeaderAlg (RSA384 _) = RS384 +toHeaderAlg (RSA512 _) = RS512 +toHeaderAlg (ECDSA256 _) = ES256 +toHeaderAlg (ECDSA384 _) = ES384 +toHeaderAlg (ECDSA512 _) = ES512 +toHeaderAlg AlgNone = None diff --git a/src/Libjwt/FFI/Jwt.hs b/src/Libjwt/FFI/Jwt.hs --- a/src/Libjwt/FFI/Jwt.hs +++ b/src/Libjwt/FFI/Jwt.hs @@ -70,6 +70,7 @@ , useAsCString , packCString , packCStringLen + , null ) import Data.ByteString.Unsafe ( unsafePackMallocCString , unsafeUseAsCStringLen @@ -85,6 +86,8 @@ import System.IO.Unsafe ( unsafePerformIO ) +import Prelude hiding ( null ) + -- | IO restricted to calling /libjwt/ and /jsmn/ newtype JwtIO a = JIO (IO a) deriving newtype (Functor, Applicative, Monad, MonadThrow, MonadCatch) @@ -98,9 +101,9 @@ mkJwtT :: JwtIO JwtT mkJwtT = JIO $ mkJwtT_ "jwt_new" c_jwt_new -jwtDecode :: Maybe ByteString -> ByteString -> JwtIO JwtT -jwtDecode maybeKey token = JIO - $ maybe ($ (nullPtr, 0)) unsafeUseAsCStringLen maybeKey doDecode +jwtDecode :: ByteString -> ByteString -> JwtIO JwtT +jwtDecode key token = JIO + $ (if null key then ($ (nullPtr, 0)) else unsafeUseAsCStringLen key) doDecode where doDecode (p_key, key_len) = useAsCString token $ \p_token -> mkJwtT_ "jwt_decode" diff --git a/src/Libjwt/Header.hs b/src/Libjwt/Header.hs --- a/src/Libjwt/Header.hs +++ b/src/Libjwt/Header.hs @@ -15,61 +15,61 @@ ) where +import Libjwt.Decoding import Libjwt.Encoding -import Libjwt.Keys -import Libjwt.FFI.Libjwt import Libjwt.FFI.Jwt - -import Control.Monad ( when ) +import Libjwt.FFI.Libjwt import Data.ByteString ( ByteString ) -import qualified Data.ByteString as ByteString +import qualified Data.CaseInsensitive as CI + -- | @"alg"@ header parameter data Alg = None - -- | HMAC SHA-256 (secret key must be __at least 256 bits in size__) - | HS256 Secret - -- | HMAC SHA-384 (secret key must be __at least 384 bits in size__) - | HS384 Secret - -- | HMAC SHA-512 (secret key must be __at least 512 bits in size__) - | HS512 Secret - -- | RSASSA-PKCS1-v1_5 SHA-256 (a key of size __2048 bits or larger__ must be used with this algorithm) - | RS256 RsaKeyPair - -- | RSASSA-PKCS1-v1_5 SHA-384 (a key of size __2048 bits or larger__ must be used with this algorithm) - | RS384 RsaKeyPair - -- | RSASSA-PKCS1-v1_5 SHA-512 (a key of size __2048 bits or larger__ must be used with this algorithm) - | RS512 RsaKeyPair - -- | ECDSA with P-256 curve and SHA-256 - | ES256 EcKeyPair - -- | ECDSA with P-384 curve and SHA-384 - | ES384 EcKeyPair - -- | ECDSA with P-521 curve and SHA-512 - | ES512 EcKeyPair + | HS256 + | HS384 + | HS512 + | RS256 + | RS384 + | RS512 + | ES256 + | ES384 + | ES512 deriving stock (Show, Eq) +instance Decode Alg where + decode = fmap matchJwtAlg . jwtGetAlg + where + matchJwtAlg jwtAlg | jwtAlg == jwtAlgHs256 = HS256 + | jwtAlg == jwtAlgHs384 = HS384 + | jwtAlg == jwtAlgHs512 = HS512 + | jwtAlg == jwtAlgRs256 = RS256 + | jwtAlg == jwtAlgRs384 = RS384 + | jwtAlg == jwtAlgRs512 = RS512 + | jwtAlg == jwtAlgEs256 = ES256 + | jwtAlg == jwtAlgEs384 = ES384 + | jwtAlg == jwtAlgEs512 = ES512 + | otherwise = None + -- | @"typ"@ header parameter data Typ = JWT | Typ (Maybe ByteString) deriving stock (Show, Eq) +instance Encode Typ where + encode (Typ (Just s)) = addHeader "typ" s + encode _ = nullEncode + +instance Decode Typ where + decode = + fmap + ( maybe (Typ Nothing) + $ \s -> if CI.mk s == "jwt" then JWT else Typ $ Just s + ) + . getHeader "typ" + -- | JWT header representation data Header = Header { alg :: Alg, typ :: Typ } deriving stock (Show, Eq) -instance Encode Header where - encode header jwt = encodeAlg (alg header) jwt >> encodeTyp (typ header) jwt - where - encodeAlg None = jwtSetAlg jwtAlgNone ByteString.empty >> forceTyp - encodeAlg (HS256 secret) = jwtSetAlg jwtAlgHs256 $ reveal secret - encodeAlg (HS384 secret) = jwtSetAlg jwtAlgHs384 $ reveal secret - encodeAlg (HS512 secret) = jwtSetAlg jwtAlgHs512 $ reveal secret - encodeAlg (RS256 pem ) = jwtSetAlg jwtAlgRs256 $ privKey pem - encodeAlg (RS384 pem ) = jwtSetAlg jwtAlgRs384 $ privKey pem - encodeAlg (RS512 pem ) = jwtSetAlg jwtAlgRs512 $ privKey pem - encodeAlg (ES256 pem ) = jwtSetAlg jwtAlgEs256 $ ecPrivKey pem - encodeAlg (ES384 pem ) = jwtSetAlg jwtAlgEs384 $ ecPrivKey pem - encodeAlg (ES512 pem ) = jwtSetAlg jwtAlgEs512 $ ecPrivKey pem - - encodeTyp (Typ (Just s)) = addHeader "typ" s - encodeTyp _ = nullEncode - - forceTyp = when (typ header == JWT) . addHeader "typ" "JWT" +instance Decode Header where + decode jwt = Header <$> decode jwt <*> decode jwt diff --git a/src/Libjwt/Jwt.hs b/src/Libjwt/Jwt.hs --- a/src/Libjwt/Jwt.hs +++ b/src/Libjwt/Jwt.hs @@ -6,7 +6,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -19,7 +18,7 @@ , Encoded , getToken , sign - , signJwt + , sign' , Decoded , getDecoded , decodeString @@ -32,6 +31,7 @@ ) where +import Libjwt.Algorithms import Libjwt.Encoding import Libjwt.Exceptions ( SomeDecodeException , AlgorithmMismatch(..) @@ -51,13 +51,13 @@ import Control.Monad.Extra ( unlessM ) import Control.Monad.Time -import Control.Monad ( (<=<) ) +import Control.Monad ( (<=<) + , when + ) import Data.ByteString ( ByteString ) import qualified Data.ByteString.Char8 as C8 -import qualified Data.CaseInsensitive as CI - import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) import System.IO.Error ( ioeGetErrorType ) @@ -67,38 +67,58 @@ deriving stock instance Show (PrivateClaims pc ns) => Show (Jwt pc ns) deriving stock instance Eq (PrivateClaims pc ns) => Eq (Jwt pc ns) -instance Encode (PrivateClaims pc ns) => Encode (Jwt pc ns) where - encode Jwt { header, payload } jwt = encode payload jwt >> encode header jwt - -- | base64url-encoded value of type @t@ newtype Encoded t = MkEncoded { getToken :: ByteString -- ^ octets of the UTF-8 representation } deriving stock (Show, Eq) --- | Compute the encoded JWT value with the JWS Signature in the manner defined for the algorithm @alg@ . +-- | Compute the encoded JWT value with the JWS Signature in the manner defined for the @algorithm@. -- 'typ' of the JWT 'Header' is set to "JWT" +-- 'alg' of the JWT 'Header' is set according to the algorithm used (see 'toHeaderAlg') -- -- Creates the serialized ouput, that is: -- @ -- BASE64URL(UTF8(JWT Header)) || . || BASE64URL(JWT Payload) || . || BASE64URL(JWT Signature) -- @ sign - :: Encode (PrivateClaims pc ns) => Alg -> Payload pc ns -> Encoded (Jwt pc ns) -sign alg payload = - signJwt $ Jwt { header = Header { alg, typ = JWT }, payload } + :: (Encode (PrivateClaims pc ns), SigningKey k) + => Algorithm k -- ^ algorithm + -> Payload pc ns -- ^ JWT payload + -> Encoded (Jwt pc ns) +sign = sign' JWT --- | Compute the encoded JWT value with the JWS Signature in the manner defined for the algorithm 'alg' present in the JWT's 'header' . +-- | Compute the encoded JWT value with the JWS Signature in the manner defined for the @algorithm@ . +-- 'typ' of the JWT 'Header' is set to @typ@ +-- 'alg' of the JWT 'Header' is set according to the algorithm used (see 'toHeaderAlg') -- -- Creates the serialized ouput, that is: -- @ -- BASE64URL(UTF8(JWT Header)) || . || BASE64URL(JWT Payload) || . || BASE64URL(JWT Signature) -- @ -signJwt :: Encode (PrivateClaims pc ns) => Jwt pc ns -> Encoded (Jwt pc ns) -signJwt it = MkEncoded $ unsafePerformJwtIO signTokenJwtIo +sign' + :: (Encode (PrivateClaims pc ns), SigningKey k) + => Typ -- ^ typ + -> Algorithm k -- ^ algorithm + -> Payload pc ns -- ^ JWT payload + -> Encoded (Jwt pc ns) +sign' ty algorithm = signJwt jwtAlg (getSigningKey key) ty + where (jwtAlg, key) = jwtAlgWithKey algorithm + +signJwt + :: Encode (PrivateClaims pc ns) + => JwtAlgT + -> ByteString + -> Typ + -> Payload pc ns + -> Encoded (Jwt pc ns) +signJwt jwtAlg key ty it = MkEncoded $ unsafePerformJwtIO signTokenJwtIo where signTokenJwtIo = do jwt <- mkJwtT encode it jwt + encode ty jwt + jwtSetAlg jwtAlg key jwt + when (jwtAlg == jwtAlgNone && ty == JWT) $ addHeader "typ" "JWT" jwt jwtEncode jwt {-# NOINLINE signJwt #-} @@ -109,17 +129,17 @@ -- | See 'decodeByteString' decodeString - :: (MonadThrow m, Decode (PrivateClaims pc ns)) - => Alg + :: (MonadThrow m, Decode (PrivateClaims pc ns), DecodingKey k) + => Algorithm k -> String -> m (Decoded (Jwt pc ns)) -decodeString alg = decodeByteString alg . C8.pack +decodeString algorithm = decodeByteString algorithm . C8.pack -- | Parse the base64url-encoded representation to extract the serialized values for the components of the JWT. -- Verify that: -- -- (1) @token@ is a valid UTF-8 encoded representation of a completely valid JSON object, --- (1) input JWT signature matches, +-- (1) input JWT signature matches the @algorithm@, -- (1) the correct algorithm was used, -- (1) all required fields are present. -- @@ -127,61 +147,32 @@ -- If step 3 fails, 'AlgorithmMismatch' will be thrown. -- If the last step fails, 'Libjwt.Exceptions.MissingClaim' will be thrown. decodeByteString - :: forall ns pc m - . (MonadThrow m, Decode (PrivateClaims pc ns)) - => Alg - -> ByteString + :: forall ns pc m k + . (MonadThrow m, Decode (PrivateClaims pc ns), DecodingKey k) + => Algorithm k -- ^ algorithm used to verify the signature + -> ByteString -- ^ token -> m (Decoded (Jwt pc ns)) -decodeByteString alg token = either throwM (pure . MkDecoded) +decodeByteString algorithm token = either throwM (pure . MkDecoded) $ unsafePerformJwtIO decodeTokenJwtIo where decodeTokenJwtIo :: JwtIO (Either SomeDecodeException (Jwt pc ns)) - decodeTokenJwtIo = try $ do - jwt <- safeJwtDecode alg token - unlessM (matchAlg alg <$> jwtGetAlg jwt) $ throwM AlgorithmMismatch - Jwt <$> decodeHeader jwt <*> decode jwt + decodeTokenJwtIo = + let (jwtAlg, key) = jwtAlgWithKey algorithm + in try $ do + jwt <- safeJwtDecode (getDecodingKey key) token + unlessM ((== jwtAlg) <$> jwtGetAlg jwt) $ throwM AlgorithmMismatch + Jwt <$> decode jwt <*> decode jwt - decodeHeader = fmap (Header alg) . decodeTyp - decodeTyp = - fmap - ( maybe (Typ Nothing) - $ \s -> if CI.mk s == "jwt" then JWT else Typ $ Just s - ) - . getHeader "typ" - - matchAlg (HS256 _) = (== jwtAlgHs256) - matchAlg (HS384 _) = (== jwtAlgHs384) - matchAlg (HS512 _) = (== jwtAlgHs512) - matchAlg (RS256 _) = (== jwtAlgRs256) - matchAlg (RS384 _) = (== jwtAlgRs384) - matchAlg (RS512 _) = (== jwtAlgRs512) - matchAlg (ES256 _) = (== jwtAlgEs256) - matchAlg (ES384 _) = (== jwtAlgEs384) - matchAlg (ES512 _) = (== jwtAlgEs512) - matchAlg None = (== jwtAlgNone) - {-# NOINLINE decodeByteString #-} -safeJwtDecode :: Alg -> ByteString -> JwtIO JwtT -safeJwtDecode alg token = - catchIf (\e -> ioeGetErrorType e == InvalidArgument) - (jwtDecode (getKey alg) token) +safeJwtDecode :: ByteString -> ByteString -> JwtIO JwtT +safeJwtDecode key token = + catchIf (\e -> ioeGetErrorType e == InvalidArgument) (jwtDecode key token) $ const $ throwM $ DecodeException $ C8.unpack token - where - getKey (HS256 secret) = Just $ reveal secret - getKey (HS384 secret) = Just $ reveal secret - getKey (HS512 secret) = Just $ reveal secret - getKey (RS256 pem ) = Just $ pubKey pem - getKey (RS384 pem ) = Just $ pubKey pem - getKey (RS512 pem ) = Just $ pubKey pem - getKey (ES256 pem ) = Just $ ecPubKey pem - getKey (ES384 pem ) = Just $ ecPubKey pem - getKey (ES512 pem ) = Just $ ecPubKey pem - getKey None = Nothing -- | Successfully validated value of type @t@ newtype Validated t = MkValid { getValid :: t } @@ -210,13 +201,14 @@ -- | See 'jwtFromByteString' jwtFromString - :: (Decode (PrivateClaims pc ns), MonadTime m, MonadThrow m) + :: (Decode (PrivateClaims pc ns), MonadTime m, MonadThrow m, DecodingKey k) => ValidationSettings -> JwtValidation pc ns - -> Alg + -> Algorithm k -> String -> m (ValidationNEL ValidationFailure (Validated (Jwt pc ns))) -jwtFromString settings v alg = validateJwt settings v <=< decodeString alg +jwtFromString settings v algorithm = + validateJwt settings v <=< decodeString algorithm -- | @jwtFromByteString = 'validateJwt' settings v <=< 'decodeByteString' alg@ -- @@ -227,7 +219,7 @@ -- -- (1) @token@ is a valid UTF-8 encoded representation of a completely valid JSON object, -- (1) input JWT signature matches, --- (1) the correct algorithm was used, +-- (1) the correct @algorithm@ was used, -- (1) all required fields are present. -- -- If steps 1-2 are unuccessful, 'DecodeException' will be thrown. @@ -248,12 +240,12 @@ -- -- 'aud' claim is checked against 'appName'. jwtFromByteString - :: (Decode (PrivateClaims pc ns), MonadTime m, MonadThrow m) + :: (Decode (PrivateClaims pc ns), MonadTime m, MonadThrow m, DecodingKey k) => ValidationSettings -- ^ 'leeway' and 'appName' -> JwtValidation pc ns -- ^ additional validation rules - -> Alg -- ^ algorithm used to verify the signature + -> Algorithm k -- ^ algorithm used to verify the signature -> ByteString -- ^ base64url-encoded representation (a token) -> m (ValidationNEL ValidationFailure (Validated (Jwt pc ns))) -jwtFromByteString settings v alg = - validateJwt settings v <=< decodeByteString alg +jwtFromByteString settings v algorithm = + validateJwt settings v <=< decodeByteString algorithm diff --git a/src/Libjwt/Keys.hs b/src/Libjwt/Keys.hs --- a/src/Libjwt/Keys.hs +++ b/src/Libjwt/Keys.hs @@ -10,11 +10,16 @@ module Libjwt.Keys ( Secret(..) , RsaKeyPair(..) + , RsaPubKey(..) , EcKeyPair(..) + , EcPubKey(..) + , SigningKey(..) + , DecodingKey(..) ) where import Data.ByteString ( ByteString ) +import qualified Data.ByteString as ByteString import qualified Data.ByteString.UTF8 as UTF8 @@ -95,6 +100,25 @@ data RsaKeyPair = FromRsaPem { privKey :: ByteString, pubKey :: ByteString } deriving stock (Show, Eq) +-- | RSA public-key (/PEM-encoded/) used in /RSA/ algorithms for decoding +-- +-- > +-- >rsaPub = +-- > let public = C8.pack $ unlines +-- > [ "-----BEGIN PUBLIC KEY-----" +-- > , "MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAwCXp2P+qboao0tjUyU+D" +-- > , "3YI+sgBn8dkGaxOvPFLBFQMNkhbL0HEoRKNnQCubZNc0jXnMK5hCeGRnDS7lYclR" +-- > , "OXocRWUn5s2W3jP5xn7lM4otIpuE3FStthMCrPSEQiBCXE4cyKiHaZqmbqXlHAHV" +-- > , "EuGMM7oddiB6s3zjwf2h1v0SEiHf5ZFzTVarStablqh6wVDAiYyM+8aUM0x9p3Jc" +-- > , "aWW+eDk/UU3jCfCke7R3t2rbD1ZCj1cO08Uir3Lhf65TfU+iIrgLU3umV4B3gRcp" +-- > , "d8iz0ZTLaG8Qnm0GsPQjR3PTZYECxEnFaRgXcQLHYYMAW9YaX6T3rlTGZAaP5Ybo" +-- > , "xQIDAQAB" +-- > , "-----END PUBLIC KEY-----" +-- > ] +-- > in FromRsaPub { rsaPublicKey = public } +newtype RsaPubKey = FromRsaPub { rsaPublicKey :: ByteString } + deriving stock (Show, Eq) + -- | Elliptic curves parameters used in /ECDSA/ algorithms -- -- According to RFC, the following curves are to be used: @@ -132,3 +156,56 @@ -- > in FromEcPem { ecPrivKey = private, ecPubKey = public } data EcKeyPair = FromEcPem { ecPrivKey :: ByteString, ecPubKey :: ByteString } deriving stock (Show, Eq) + +-- | Elliptic curve public key (/PEM-encoded/) used in /ECDSA/ algorithms for decoding +-- +-- +-- > ecPub = +-- > let public = C8.pack $ unlines +-- > [ "-----BEGIN PUBLIC KEY-----" +-- > , "MFkwEwYHKoZIzj0CAQYIKoZIzj0DAQcDQgAEKZL0X84AvdnGZdsIdAS60OnvF3FN" +-- > , "lsrCnaXRoJUVdOYZldzb4po2uDXF5W58DS8C31fV+z+0lTG5RvuAqfkdbA==" +-- > , "-----END PUBLIC KEY-----" +-- > ] +-- > in FromEcPub { ecPublicKey = public } +newtype EcPubKey = FromEcPub { ecPublicKey :: ByteString } + deriving stock (Show, Eq) + +-- | Class of keys that can be used (only) for decoding +class DecodingKey k where + getDecodingKey :: k -> ByteString + +instance DecodingKey Secret where + getDecodingKey = reveal + +instance DecodingKey RsaKeyPair where + getDecodingKey = pubKey + +instance DecodingKey RsaPubKey where + getDecodingKey = rsaPublicKey + +instance DecodingKey EcKeyPair where + getDecodingKey = ecPubKey + +instance DecodingKey EcPubKey where + getDecodingKey = ecPublicKey + +instance DecodingKey () where + getDecodingKey _ = ByteString.empty + +-- | Class of keys that can be used for signing +class DecodingKey k => SigningKey k where + getSigningKey :: k -> ByteString + +instance SigningKey Secret where + getSigningKey = reveal + +instance SigningKey RsaKeyPair where + getSigningKey = privKey + +instance SigningKey EcKeyPair where + getSigningKey = ecPrivKey + +instance SigningKey () where + getSigningKey _ = ByteString.empty + diff --git a/src/Web/Libjwt.hs b/src/Web/Libjwt.hs --- a/src/Web/Libjwt.hs +++ b/src/Web/Libjwt.hs @@ -136,36 +136,36 @@ To sign a token, you need to choose the algorithm. -+----------+---------------------------------------+ -|Algorithm | Description | -+==========+=======================================+ -|'HS256' | HMAC with SHA-256 | -+----------+---------------------------------------+ -|'HS384' | HMAC with SHA-384 | -+----------+---------------------------------------+ -|'HS512' | HMAC with SHA-512 | -+----------+---------------------------------------+ -|'RS256' | RSASSA-PKCS1-v1_5 with SHA-256 | -+----------+---------------------------------------+ -|'RS384' | RSASSA-PKCS1-v1_5 with SHA-384 | -+----------+---------------------------------------+ -|'RS512' | RSASSA-PKCS1-v1_5 with SHA-512 | -+----------+---------------------------------------+ -|'ES256' | ECDSA with curve P-256 and SHA-256 | -+----------+---------------------------------------+ -|'ES384' | ECDSA with curve P-384 and SHA-384 | -+----------+---------------------------------------+ -|'ES512' | ECDSA with curve P-521 and SHA-512 | -+----------+---------------------------------------+ ++------------+---------------------------------------+-------------+ +|Algorithm | Description | Key type | ++============+=======================================+=============+ +|'HMAC256' | HMAC with SHA-256 | 'Secret' | ++------------+---------------------------------------+ | +|'HMAC384' | HMAC with SHA-384 | | ++------------+---------------------------------------+ | +|'HMAC512' | HMAC with SHA-512 | | ++------------+---------------------------------------+-------------+ +|'RSA256' | RSASSA-PKCS1-v1_5 with SHA-256 | 'RsaKeyPair'| ++------------+---------------------------------------+ 'RsaPubKey' | +|'RSA384' | RSASSA-PKCS1-v1_5 with SHA-384 | | ++------------+---------------------------------------+ | +|'RSA512' | RSASSA-PKCS1-v1_5 with SHA-512 | | ++------------+---------------------------------------+-------------+ +|'ECDSA256' | ECDSA with curve P-256 and SHA-256 | 'EcKeyPair' | ++------------+---------------------------------------+ 'EcPubKey' | +|'ECDSA384' | ECDSA with curve P-384 and SHA-384 | | ++------------+---------------------------------------+ | +|'ECDSA512' | ECDSA with curve P-521 and SHA-512 | | ++------------+---------------------------------------+-------------+ The complete example: @ {-# LANGUAGE OverloadedStrings #-} -hmac512 :: 'Alg' +hmac512 :: 'Algorithm' 'Secret' hmac512 = - 'HS512' + 'HMAC512' "MjZkMDY2OWFiZmRjYTk5YjczZWFiZjYzMmRjMzU5NDYyMjMxODBjMTg3ZmY5OTZjM2NhM2NhN2Mx\\ \\YzFiNDNlYjc4NTE1MjQxZGI0OWM1ZWI2ZDUyZmMzZDlhMmFiNjc5OWJlZTUxNjE2ZDRlYTNkYjU5\\ \\Y2IwMDZhYWY1MjY1OTQgIC0K" @@ -244,6 +244,7 @@ module Web.Libjwt ( module Libjwt.Jwt + , module Libjwt.Algorithms , module Libjwt.Exceptions , module Libjwt.Header , module Libjwt.Keys @@ -259,6 +260,7 @@ ) where +import Libjwt.Algorithms ( Algorithm(..) ) import Libjwt.ASCII ( ASCII(..) ) import Libjwt.Decoding ( Decode ) import Libjwt.Encoding ( Encode ) @@ -269,7 +271,7 @@ import Libjwt.Header import Libjwt.Jwt ( Jwt(..) , sign - , signJwt + , sign' , Encoded , getToken , jwtFromString diff --git a/src/Web/Libjwt/Tutorial.hs b/src/Web/Libjwt/Tutorial.hs --- a/src/Web/Libjwt/Tutorial.hs +++ b/src/Web/Libjwt/Tutorial.hs @@ -48,9 +48,9 @@ instance ToPrivateClaims UserClaims instance FromPrivateClaims UserClaims -hmac512 :: Alg +hmac512 :: Algorithm Secret hmac512 = - HS512 + HMAC512 "MjZkMDY2OWFiZmRjYTk5YjczZWFiZjYzMmRjMzU5NDYyMjMxODBjMTg3ZmY5OTZjM2NhM2NhN2Mx\ \YzFiNDNlYjc4NTE1MjQxZGI0OWM1ZWI2ZDUyZmMzZDlhMmFiNjc5OWJlZTUxNjE2ZDRlYTNkYjU5\ \Y2IwMDZhYWY1MjY1OTQgIC0K" diff --git a/test/Env.hs b/test/Env.hs --- a/test/Env.hs +++ b/test/Env.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} @@ -8,6 +9,7 @@ , EcKeyPair(..) ) + import Control.Arrow ( left ) import Control.Monad.Catch @@ -22,9 +24,12 @@ import Data.Either.Extra ( fromEither ) -import Data.Time.Clock ( UTCTime ) +import Data.Time.Clock ( UTCTime + , NominalDiffTime + ) import Data.Time.Clock.POSIX ( POSIXTime , posixSecondsToUTCTime + , utcTimeToPOSIXSeconds ) import Data.UUID ( UUID ) @@ -144,11 +149,26 @@ newtype TestEnv a = MkTest { runTest :: ReaderT UTCTime (Either SomeException) a } deriving newtype (Functor, Applicative, Monad, MonadTime, MonadThrow, MonadCatch) +expectationOk :: Expectation +expectationOk = pure () + pass :: TestEnv Expectation -pass = MkTest (pure alwaysTrue) where alwaysTrue = pure () +pass = MkTest (pure expectationOk) +fail :: String -> TestEnv Expectation +fail reason = MkTest (pure $ expectationFailure reason) + +withTime :: (UTCTime -> a) -> TestEnv a +withTime f = f <$> currentTime + +withEpochTime :: (POSIXTime -> a) -> TestEnv a +withEpochTime f = withTime (f . utcTimeToPOSIXSeconds) + +epochTime :: NominalDiffTime +epochTime = 1595386660 + presetTime :: UTCTime -presetTime = posixSecondsToUTCTime 1595386660 +presetTime = posixSecondsToUTCTime epochTime runTestWithPresetTime :: TestEnv a -> Either SomeException a runTestWithPresetTime = runTestWithGivenTime presetTime @@ -179,5 +199,3 @@ ++ displayException e ) . runTestWithGivenTime t0 - - diff --git a/test/Generators.hs b/test/Generators.hs --- a/test/Generators.hs +++ b/test/Generators.hs @@ -2,12 +2,14 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} @@ -16,9 +18,8 @@ module Generators ( JwtString(..) , JwtText(..) - , genHeader - , genJwt - , shrinkJwt + , SomeAlgorithm(..) + , genAlgorithm ) where @@ -139,27 +140,6 @@ instance Arbitrary a => Arbitrary (Flag a) where arbitrary = coerce $ arbitrary @a -instance Arbitrary Alg where - arbitrary = genAlg - -genAlg :: Gen Alg -genAlg = elements [hs256, hs512, rs256, rs512, es256, es384, es512, None] - where - hs256 = - HS256 - "MWNmYzExODA5OWFjOGM3NDNmMmM5Zjg5ZDc0YTM3M2VhMGNkMzA2MDY3ZjFhZDk5N2I3OTc5Yjdm\ - \NDg3NDBkMiAgLQo" - hs512 = - HS512 - "MjZkMDY2OWFiZmRjYTk5YjczZWFiZjYzMmRjMzU5NDYyMjMxODBjMTg3ZmY5OTZjM2NhM2NhN2Mx\ - \YzFiNDNlYjc4NTE1MjQxZGI0OWM1ZWI2ZDUyZmMzZDlhMmFiNjc5OWJlZTUxNjE2ZDRlYTNkYjU5\ - \Y2IwMDZhYWY1MjY1OTQgIC0K" - rs256 = RS256 E.testRsa2048KeyPair - rs512 = RS512 E.testRsa2048KeyPair - es256 = ES256 E.testEcP256KeyPair - es384 = ES384 E.testEcP384KeyPair - es512 = ES512 E.testEcP521KeyPair - instance Arbitrary ValidationSettings where arbitrary = Settings <$> genLeeway <*> arbitrary where genLeeway = arbitrary `suchThat` (>= 0) @@ -188,21 +168,43 @@ shrink = shrinkMap (T . T.pack . correctJwtString) $ S . T.unpack . correctJwtText -instance Arbitrary Header where - arbitrary = genHeader - -genHeader :: Gen Header -genHeader = Header <$> genAlg <*> pure JWT +data SomeAlgorithm = forall k . (Show k, SigningKey k) => SomeAlgorithm (Algorithm k) +deriving stock instance Show SomeAlgorithm -instance Arbitrary (PrivateClaims ts ns) => Arbitrary (Jwt ts ns) where - arbitrary = genJwt - shrink = shrinkJwt +instance Arbitrary SomeAlgorithm where + arbitrary = genAlgorithm -genJwt :: Arbitrary (PrivateClaims ts ns) => Gen (Jwt ts ns) -genJwt = Jwt <$> genHeader <*> arbitrary +genAlgorithm :: Gen SomeAlgorithm +genAlgorithm = elements + [ SomeAlgorithm hs256 + , SomeAlgorithm hs512 + , SomeAlgorithm rs256 + , SomeAlgorithm rs384 + , SomeAlgorithm rs512 + , SomeAlgorithm es256 + , SomeAlgorithm es384 + , SomeAlgorithm es512 + , SomeAlgorithm AlgNone + ] + where + hs256 = + HMAC256 + "MWNmYzExODA5OWFjOGM3NDNmMmM5Zjg5ZDc0YTM3M2VhMGNkMzA2MDY3ZjFhZDk5N2I3OTc5YjdmNDg3NDBkMiAgLQo" + hs512 = + HMAC512 + "MjZkMDY2OWFiZmRjYTk5YjczZWFiZjYzMmRjMzU5NDYyMjMxODBjMTg3ZmY5OTZjM2NhM2NhN2Mx\ + \YzFiNDNlYjc4NTE1MjQxZGI0OWM1ZWI2ZDUyZmMzZDlhMmFiNjc5OWJlZTUxNjE2ZDRlYTNkYjU5\ + \Y2IwMDZhYWY1MjY1OTQgIC0K" + rs256 = RSA256 E.testRsa2048KeyPair + rs384 = RSA384 E.testRsa2048KeyPair + rs512 = RSA512 E.testRsa2048KeyPair + es256 = ECDSA256 E.testEcP256KeyPair + es384 = ECDSA384 E.testEcP384KeyPair + es512 = ECDSA512 E.testEcP521KeyPair -shrinkJwt :: Arbitrary (PrivateClaims pc ns) => Jwt pc ns -> [Jwt pc ns] -shrinkJwt jwt = shrinkMap (\payload' -> jwt { payload = payload' }) payload jwt +instance Arbitrary Typ where + arbitrary = frequency + [(16, pure JWT), (3, pure $ Typ Nothing), (1, pure $ Typ $ Just "some-typ")] instance Arbitrary (PrivateClaims ts ns) => Arbitrary (Payload ts ns) where arbitrary = diff --git a/test/Interop/JWTDecoding.hs b/test/Interop/JWTDecoding.hs --- a/test/Interop/JWTDecoding.hs +++ b/test/Interop/JWTDecoding.hs @@ -46,21 +46,32 @@ spec :: Spec spec = do - describe "HS256" - $ runTests - $ HS256 - "MWNmYzExODA5OWFjOGM3NDNmMmM5Zjg5ZDc0YTM3M2VhMGNkMzA2MDY3ZjFhZDk5N2I3OTc5Yjdm\ - \NDg3NDBkMiAgLQo" - describe "none" $ runTests None - describe "RS256" $ runTests $ RS256 E.testRsa2048KeyPair + testAlgValidation + describe "HS256" $ runTests hmac256 + describe "none" $ runTests none + describe "RS256" $ runTests rsa256 -runTests :: Alg -> Spec -runTests a = sequence_ $ tests <*> [a] +testAlgValidation :: Spec +testAlgValidation = + let maliciousSigner = JWT.HMACSecret $ getDecodingKey E.testRsa2048KeyPair + token = TE.encodeUtf8 $ JWT.encodeSigned maliciousSigner mempty mempty + in E.specify "alg-validation" + $ fmap + ( const + $ expectationFailure + $ "Web.JWT: unexpectedly decoded token\n" + ++ show token + ) + (decodeByteString @ 'NoNs @Empty (RSA256 E.testRsa2048KeyPair) token + ) + `catch` (\AlgorithmMismatch -> E.pass) -tests :: [Alg -> Spec] +runTests :: SomeAlgorithm -> Spec +runTests sa = sequence_ $ tests <*> [sa] + +tests :: [SomeAlgorithm -> Spec] tests = [ basicTest - , typTest , richHeaderTest , audSingleTest , audListTest @@ -74,73 +85,77 @@ , invalidTokenTest ] -basicTest :: Alg -> Spec -basicTest a = - let joseHeader = - JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing - cs = mempty { JWT.iss = JWT.stringOrURI "libjwt-typed-test" - , JWT.sub = JWT.stringOrURI "test" - , JWT.iat = JWT.numericDate 1595386660 - , JWT.nbf = JWT.numericDate 1595386660 - } - in E.specify "basic" $ mkTest joseHeader cs a nullClaims +basicTest :: SomeAlgorithm -> Spec +basicTest sa = + let joseHeader = JWT.JOSEHeader (Just "JWT") Nothing Nothing Nothing -- Web.JWT always replaces 'alg' + cs = mempty { JWT.iss = JWT.stringOrURI "libjwt-typed-test" + , JWT.sub = JWT.stringOrURI "test" + , JWT.iat = JWT.numericDate E.epochTime + , JWT.nbf = JWT.numericDate E.epochTime + } + in E.specify "basic" + $ mkTest joseHeader cs sa + =<< jwtPayload + ( withIssuer "libjwt-typed-test" + <> withSubject "test" + <> issuedNow + <> notBeforeNow + ) + () -typTest :: Alg -> Spec -typTest a = +richHeaderTest :: SomeAlgorithm -> Spec +richHeaderTest sa = let joseHeader = - JWT.JOSEHeader (Just "jose") Nothing (mkJWTAlgorithm a) Nothing - cs = mempty { JWT.iss = JWT.stringOrURI "libjwt-typed-test" - , JWT.sub = JWT.stringOrURI "test-typ" - } - in E.xspecify "typ" $ mkTest joseHeader cs a nullClaims -- Web.JWT always uses JWT - -richHeaderTest :: Alg -> Spec -richHeaderTest a = - let joseHeader = JWT.JOSEHeader (Just "JWT") - (Just "test") - (mkJWTAlgorithm a) - (Just "test") + JWT.JOSEHeader (Just "JWT") (Just "test") Nothing (Just "test") cs = mempty { JWT.iss = JWT.stringOrURI "libjwt-typed-test" , JWT.sub = JWT.stringOrURI "test-rich-header" } - in E.specify "rich-header" $ mkTest joseHeader cs a nullClaims + in E.specify "rich-header" + $ mkTest joseHeader cs sa + =<< jwtPayload + (withIssuer "libjwt-typed-test" <> withSubject "test-rich-header") + () -audSingleTest :: Alg -> Spec -audSingleTest a = - let joseHeader = - JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing - cs = mempty { JWT.iss = JWT.stringOrURI "libjwt-typed-test" - , JWT.sub = JWT.stringOrURI "test-aud-single" +audSingleTest :: SomeAlgorithm -> Spec +audSingleTest sa = + let cs = mempty { JWT.sub = JWT.stringOrURI "test-aud-single" , JWT.aud = Left <$> JWT.stringOrURI "nobody" } - in E.specify "aud-single" $ mkTest joseHeader cs a nullClaims + in E.specify "aud-single" + $ mkTest mempty cs sa + =<< jwtPayload + (withSubject "test-aud-single" <> withRecipient "nobody") + () -audListTest :: Alg -> Spec -audListTest a = - let joseHeader = - JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing - cs = mempty - { JWT.iss = JWT.stringOrURI "libjwt-typed-test" - , JWT.sub = JWT.stringOrURI "test-aud-list" +audListTest :: SomeAlgorithm -> Spec +audListTest sa = + let cs = mempty + { JWT.sub = JWT.stringOrURI "test-aud-list" , JWT.aud = fmap Right . sequence $ [JWT.stringOrURI] <*> ["nobody-1", "nobody-2", "nobody-3"] } - in E.specify "aud-list" $ mkTest joseHeader cs a nullClaims + in E.specify "aud-list" + $ mkTest mempty cs sa + =<< jwtPayload + ( withSubject "test-aud-list" + <> withRecipient "nobody-1" + <> withRecipient "nobody-2" + <> withRecipient "nobody-3" + ) + () data PreferredContact = Email | Phone deriving stock (Show, Eq, Generic) instance AFlag PreferredContact -unregisteredClaimsTest :: Alg -> Spec -unregisteredClaimsTest a = +unregisteredClaimsTest :: SomeAlgorithm -> Spec +unregisteredClaimsTest sa = let - joseHeader = JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing - cs = mempty - { JWT.iss = JWT.stringOrURI "libjwt-typed-test" - , JWT.sub = JWT.stringOrURI "test-unregistered" + cs = mempty + { JWT.sub = JWT.stringOrURI "test-unregistered" , JWT.unregisteredClaims = JWT.ClaimsMap $ Map.fromList [ ("name" , JSON.String "John Doe") , ("userId" , JSON.Number 12345) @@ -150,23 +165,21 @@ , ("createdAt" , JSON.String "2020-07-31T11:45:00Z") ] } - in - E.specify "unregistered-claims" $ mkTest joseHeader cs a $ toPrivateClaims - ( #name ->> ("John Doe" :: String) - , #userId ->> (12345 :: Int) - , #isAdmin ->> False - , #preferredContact ->> Flag Email - , #systemId ->> E.testJTI - , #createdAt ->> Just (read "2020-07-31 11:45:00 UTC" :: UTCTime) - ) + in E.specify "unregistered-claims" $ mkTest mempty cs sa =<< jwtPayload + (withSubject "test-unregistered") + ( #name ->> ("John Doe" :: String) + , #userId ->> (12345 :: Int) + , #isAdmin ->> False + , #preferredContact ->> Flag Email + , #systemId ->> E.testJTI + , #createdAt ->> Just (read "2020-07-31 11:45:00 UTC" :: UTCTime) + ) -unregisteredClaimsOptionsTest :: Alg -> Spec -unregisteredClaimsOptionsTest a = +unregisteredClaimsOptionsTest :: SomeAlgorithm -> Spec +unregisteredClaimsOptionsTest sa = let - joseHeader = JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing - cs = mempty - { JWT.iss = JWT.stringOrURI "libjwt-typed-test" - , JWT.sub = JWT.stringOrURI "test-unregistered-opt" + cs = mempty + { JWT.sub = JWT.stringOrURI "test-unregistered-opt" , JWT.unregisteredClaims = JWT.ClaimsMap $ Map.fromList [ ("name", JSON.String "John Doe") , ("userId" , JSON.Number 12345) @@ -174,27 +187,25 @@ , ("preferredContact", JSON.String "email") ] } - in - E.specify "unregistered-claims-options" - $ mkTest joseHeader cs a - $ toPrivateClaims - ( #name ->> ("John Doe" :: String) - , #userId ->> (12345 :: Int) - , #isAdmin ->> False - , #preferredContact ->> Just (Flag Email) - , #systemId ->> (Nothing :: Maybe UUID.UUID) - , #prefs ->> ([] :: [String]) - ) + in E.specify "unregistered-claims-options" + $ mkTest mempty cs sa + =<< jwtPayload + (withSubject "test-unregistered-opt") + ( #name ->> ("John Doe" :: String) + , #userId ->> (12345 :: Int) + , #isAdmin ->> False + , #preferredContact ->> Just (Flag Email) + , #systemId ->> (Nothing :: Maybe UUID.UUID) + , #prefs ->> ([] :: [String]) + ) -unregisteredClaimsNsTest :: Alg -> Spec -unregisteredClaimsNsTest a = +unregisteredClaimsNsTest :: SomeAlgorithm -> Spec +unregisteredClaimsNsTest sa = let - joseHeader = JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing - cs = mempty - { JWT.iss = JWT.stringOrURI "libjwt-typed-test" - , JWT.sub = JWT.stringOrURI "test-unregistered" - , JWT.iat = JWT.numericDate 1595386660 - , JWT.nbf = JWT.numericDate 1595386660 + cs = mempty + { JWT.sub = JWT.stringOrURI "test-unregistered" + , JWT.iat = JWT.numericDate E.epochTime + , JWT.nbf = JWT.numericDate E.epochTime , JWT.unregisteredClaims = JWT.ClaimsMap $ Map.fromList [ ("http://example.com/name" , JSON.String "John Doe") , ("http://example.com/userId" , JSON.Number 12345) @@ -202,47 +213,42 @@ , ("http://example.com/systemId", JSON.String $ UUID.toText E.testJTI) ] } - in - E.specify "unregistered-claims-ns" - $ mkTest joseHeader cs a - $ toPrivateClaims - $ withNs - (Ns @"http://example.com") - ( #name ->> ("John Doe" :: String) - , #userId ->> (12345 :: Int) - , #isAdmin ->> False - , #systemId ->> E.testJTI + in E.specify "unregistered-claims-ns" $ mkTest mempty cs sa =<< jwtPayload + (withSubject "test-unregistered" <> issuedNow <> notBeforeNow) + (withNs + (Ns @"http://example.com") + ( #name ->> ("John Doe" :: String) + , #userId ->> (12345 :: Int) + , #isAdmin ->> False + , #systemId ->> E.testJTI + ) ) -utfTest :: Alg -> Spec -utfTest a = - let joseHeader = - JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing - cs = mempty - { JWT.iss = JWT.stringOrURI "libjwt-typed-test" - , JWT.sub = JWT.stringOrURI "test-utf" +utfTest :: SomeAlgorithm -> Spec +utfTest sa = + let cs = mempty + { JWT.sub = JWT.stringOrURI "test-utf" , JWT.unregisteredClaims = JWT.ClaimsMap $ Map.fromList [ ("name" , JSON.String "孔子") , ("status", JSON.String "不患人之不己知，患不知人也") ] } - in E.specify "utf" $ mkTest joseHeader cs a $ toPrivateClaims + in E.specify "utf" $ mkTest mempty cs sa =<< jwtPayload + (withSubject "test-utf") (#name ->> ("孔子" :: String), #status ->> ("不患人之不己知，患不知人也" :: T.Text)) -invalidClaimTest :: Alg -> Spec -invalidClaimTest a = - let joseHeader = - JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing - cs = mempty +invalidClaimTest :: SomeAlgorithm -> Spec +invalidClaimTest sa = + let cs = mempty { JWT.iss = JWT.stringOrURI "libjwt-typed-test" , JWT.sub = JWT.stringOrURI "invalid-claim-test" , JWT.unregisteredClaims = JWT.ClaimsMap $ Map.singleton "not-a-number" JSON.Null } - token = jwtEncode cs joseHeader a + token = jwtEncode cs mempty sa in E.specify "invalid-claim" $ decodeTest @'["not-a-number" ->> Int] @ 'NoNs - a + sa token (\decoded -> expectationFailure @@ -253,31 +259,24 @@ ) `catch` (\(Missing missing) -> pure $ missing `shouldBe` "not-a-number") -invalidOptClaimTest :: Alg -> Spec -invalidOptClaimTest a = - let - joseHeader = JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing - cs = mempty - { JWT.iss = JWT.stringOrURI "libjwt-typed-test" - , JWT.sub = JWT.stringOrURI "invalid-opt-claim-test" - , JWT.unregisteredClaims = JWT.ClaimsMap - $ Map.singleton "maybeNumber" JSON.Null - } - in - E.specify "invalid-opt-claim" - $ mkTest joseHeader cs a - $ toPrivateClaims - $ #maybeNumber - ->> (Nothing :: Maybe Int) +invalidOptClaimTest :: SomeAlgorithm -> Spec +invalidOptClaimTest sa = + let cs = mempty + { JWT.sub = JWT.stringOrURI "invalid-opt-claim-test" + , JWT.unregisteredClaims = JWT.ClaimsMap + $ Map.singleton "maybeNumber" JSON.Null + } + in E.specify "invalid-opt-claim" $ mkTest mempty cs sa =<< jwtPayload + (withSubject "invalid-opt-claim-test") + (#maybeNumber ->> (Nothing :: Maybe Int)) -validTokenTest :: Alg -> Spec -validTokenTest a = +validTokenTest :: SomeAlgorithm -> Spec +validTokenTest sa = let - t0 = 1597945008 - ttl = 60 - t1 = t0 + 30 - joseHeader = JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing - cs = mempty + t0 = 1597945008 + ttl = 60 + t1 = t0 + 30 + cs = mempty { JWT.iss = JWT.stringOrURI "libjwt-typed-test" , JWT.sub = JWT.stringOrURI "valid-token-test" , JWT.iat = JWT.numericDate t0 @@ -289,8 +288,8 @@ in E.specifyWithTime t1 "valid-token" $ validationTest @'["number" ->> Int] @ 'NoNs - a - (jwtEncode cs joseHeader a) + sa + (jwtEncode cs mempty sa) ( checkAge 3600 <> checkIssuer "libjwt-typed-test" <> checkSubject "valid-token-test" @@ -300,14 +299,13 @@ (V.Success _) -> True (V.Failure _) -> False -invalidTokenTest :: Alg -> Spec -invalidTokenTest a = +invalidTokenTest :: SomeAlgorithm -> Spec +invalidTokenTest sa = let - t0 = 1597945008 - ttl = 60 - t1 = t0 + 120 - joseHeader = JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing - cs = mempty + t0 = 1597945008 + ttl = 60 + t1 = t0 + 120 + cs = mempty { JWT.iss = JWT.stringOrURI "libjwt-typed-test" , JWT.sub = JWT.stringOrURI "invalid-token-test" , JWT.iat = JWT.numericDate t0 @@ -319,8 +317,8 @@ in E.specifyWithTime t1 "invalid-token" $ validationTest @'["number" ->> Int] @ 'NoNs - a - (jwtEncode cs joseHeader a) + sa + (jwtEncode cs mempty sa) ( checkAge 3600 <> checkIssuer "libjwt-typed-test" <> checkSubject "valid-token-test" @@ -340,40 +338,42 @@ ) => JWT.JOSEHeader -> JWT.JWTClaimsSet - -> Alg - -> PrivateClaims cs ns + -> SomeAlgorithm + -> Payload cs ns -> E.TestEnv Expectation -mkTest inHeader inClaims a expected = - let token = jwtEncode inClaims inHeader a - in handle (handleDecodeException token) $ decodeTest a token $ \jwt -> do - expectHeader inHeader $ header jwt - expectPayload inClaims (payload jwt) expected +mkTest inHeader inClaims sa expected = + let token = jwtEncode inClaims inHeader sa + in handle (handleDecodeException token) $ decodeTest sa token $ \actual -> + actual `shouldBe` expected decodeTest :: Decode (PrivateClaims pc ns) - => Alg + => SomeAlgorithm -> T.Text - -> (Jwt pc ns -> Expectation) + -> (Payload pc ns -> Expectation) -> E.TestEnv Expectation -decodeTest a token test = - fmap (test . getDecoded) $ E.MkTest $ decodeByteString a $ TE.encodeUtf8 token +decodeTest (SomeAlgorithm a) token test = + fmap (test . payload . getDecoded) + $ E.MkTest + $ decodeByteString a + $ TE.encodeUtf8 token validationTest :: Decode (PrivateClaims pc ns) - => Alg + => SomeAlgorithm -> T.Text -> JwtValidation pc ns -> ( ValidationNEL ValidationFailure (Validated (Jwt pc ns)) -> Expectation ) -> E.TestEnv Expectation -validationTest a token validation test = +validationTest (SomeAlgorithm a) token validation test = fmap test $ E.MkTest $ jwtFromByteString defaultValidationSettings validation a $ TE.encodeUtf8 token -jwtEncode :: JWT.JWTClaimsSet -> JWT.JOSEHeader -> Alg -> T.Text +jwtEncode :: JWT.JWTClaimsSet -> JWT.JOSEHeader -> SomeAlgorithm -> T.Text jwtEncode inClaims inHeader = maybe (JWT.encodeUnsigned inClaims inHeader) (\signer -> JWT.encodeSigned signer inHeader inClaims) @@ -381,56 +381,8 @@ handleDecodeException :: T.Text -> SomeDecodeException -> E.TestEnv Expectation handleDecodeException token e = - pure - $ expectationFailure + E.fail $ "Web.JWT: Decoding token\n" ++ show token ++ "\n\tthrew exception:\n" ++ show e - -expectHeader :: JWT.JOSEHeader -> Header -> Expectation -expectHeader expected got = do - typ got `shouldBe` typ' (JWT.typ expected) - mkJWTAlgorithm (alg got) `shouldBe` JWT.alg expected - where - typ' Nothing = Typ Nothing - typ' (Just "JWT") = JWT - typ' (Just "jwt") = JWT - typ' (Just text ) = Typ $ Just $ TE.encodeUtf8 text - -expectPayload - :: (Show (PrivateClaims cs ns), Eq (PrivateClaims cs ns)) - => JWT.JWTClaimsSet - -> Payload cs ns - -> PrivateClaims cs ns - -> Expectation -expectPayload expected got expectedPc = got `shouldBe` ClaimsSet - { iss = iss' (JWT.iss expected) - , sub = sub' (JWT.sub expected) - , aud = aud' (JWT.aud expected) - , exp = exp' (JWT.exp expected) - , iat = iat' (JWT.iat expected) - , nbf = nbf' (JWT.nbf expected) - , jti = jti' (JWT.jti expected) - , privateClaims = expectedPc - } - where - stringOrURIToString = T.unpack . JWT.stringOrURIToText - - intDateToNumericDate = fromPOSIX . JWT.secondsSinceEpoch - - iss' mt = Iss $ stringOrURIToString <$> mt - - sub' mt = Sub $ stringOrURIToString <$> mt - - aud' Nothing = mempty - aud' (Just (Left s )) = Aud [stringOrURIToString s] - aud' (Just (Right ss)) = Aud $ map stringOrURIToString ss - - exp' md = Exp $ intDateToNumericDate <$> md - - iat' md = Iat $ intDateToNumericDate <$> md - - nbf' md = Nbf $ intDateToNumericDate <$> md - - jti' mt = Jti $ UUID.fromText . JWT.stringOrURIToText =<< mt diff --git a/test/Interop/JWTEncoding.hs b/test/Interop/JWTEncoding.hs --- a/test/Interop/JWTEncoding.hs +++ b/test/Interop/JWTEncoding.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} @@ -14,16 +13,14 @@ where import Web.Libjwt +import Env ( expectationOk ) import qualified Env as E import Interop.JWTHelpers -import Libjwt.NumericDate ( toPOSIX ) import qualified Data.Aeson as JSON import qualified Data.Map.Strict as Map -import Data.Maybe ( fromMaybe ) - import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -40,22 +37,17 @@ spec :: Spec spec = do - describe "HS256" - $ runTests - $ HS256 - "MWNmYzExODA5OWFjOGM3NDNmMmM5Zjg5ZDc0YTM3M2VhMGNkMzA2MDY3ZjFhZDk5N2I3OTc5Yjdm\ - \NDg3NDBkMiAgLQo" - xdescribe "none" $ runTests None -- JWT does not work at all with none - describe "RS256" $ runTests $ RS256 E.testRsa2048KeyPair + describe "HS256" $ runTests hmac256 + xdescribe "none" $ runTests none -- JWT does not work at all with none + describe "RS256" $ runTests rsa256 -runTests :: Alg -> Spec -runTests alg = sequence_ $ tests <*> [alg] +runTests :: SomeAlgorithm -> Spec +runTests sa = sequence_ $ tests <*> [sa] -tests :: [Alg -> Spec] +tests :: [SomeAlgorithm -> Spec] tests = [ basicTest , typTest - , audSingleTest , audListTest , privateClaimsSimpleTest , privateClaimsComplexTest @@ -63,10 +55,10 @@ , utfTest ] -basicTest :: Alg -> Spec -basicTest alg = +basicTest :: SomeAlgorithm -> Spec +basicTest sa = E.specify "basic" - $ mkTest Header { alg, typ = JWT } mempty + $ mkTest sa JWT <$> jwtPayload ( withIssuer "libjwt-typed-test" <> withSubject "test" @@ -75,33 +67,38 @@ <> withJwtId E.testJTI ) () + <*> E.withEpochTime + (\t -> mempty + { JWT.iss = JWT.stringOrURI "libjwt-typed-test" + , JWT.sub = JWT.stringOrURI "test" + , JWT.iat = JWT.numericDate t + , JWT.nbf = JWT.numericDate t + , JWT.jti = JWT.stringOrURI $ T.pack $ UUID.toString E.testJTI + } + ) -typTest :: Alg -> Spec -typTest alg = +typTest :: SomeAlgorithm -> Spec +typTest sa = E.specify "typ" - $ mkTest Header { alg, typ = Typ $ Just "jose" } mempty + $ mkTest sa (Typ $ Just "jose") <$> jwtPayload ( withIssuer "libjwt-typed-test" <> withSubject "test-typ" <> withJwtId E.testJTI ) () - -audSingleTest :: Alg -> Spec -audSingleTest alg = - E.specify "aud-single" - $ mkTest Header { alg, typ = JWT } mempty - <$> jwtPayload - ( withIssuer "libjwt-typed-test" - <> withSubject "test-aud-single" - <> withRecipient "nobody" + <*> pure + (mempty { JWT.iss = JWT.stringOrURI "libjwt-typed-test" + , JWT.sub = JWT.stringOrURI "test-typ" + , JWT.jti = JWT.stringOrURI $ T.pack $ UUID.toString E.testJTI + } ) - () -audListTest :: Alg -> Spec -audListTest alg = + +audListTest :: SomeAlgorithm -> Spec +audListTest sa = E.specify "aud-list" - $ mkTest Header { alg, typ = JWT } mempty + $ mkTest sa JWT <$> jwtPayload ( withIssuer "libjwt-typed-test" <> withSubject "test-aud-list" @@ -110,18 +107,21 @@ <> withRecipient "nobody-3" ) () + <*> pure + (mempty + { JWT.iss = JWT.stringOrURI "libjwt-typed-test" + , JWT.sub = JWT.stringOrURI "test-aud-list" + , JWT.aud = fmap Right + . sequence + $ [JWT.stringOrURI] + <*> ["nobody-1", "nobody-2", "nobody-3"] + } + ) -privateClaimsSimpleTest :: Alg -> Spec -privateClaimsSimpleTest alg = +privateClaimsSimpleTest :: SomeAlgorithm -> Spec +privateClaimsSimpleTest sa = E.specify "private-claims-simple" - $ mkTest - Header { alg, typ = JWT } - (JWT.ClaimsMap $ Map.fromList - [ ("name" , JSON.String "John Doe") - , ("userId" , JSON.Number 12345) - , ("isAdmin", JSON.Bool False) - ] - ) + $ mkTest sa JWT <$> jwtPayload ( withIssuer "libjwt-typed-test" <> withSubject "test-private-claims-simple" @@ -130,6 +130,17 @@ , #userId ->> (12345 :: Int) , #isAdmin ->> False ) + <*> pure + (mempty + { JWT.iss = JWT.stringOrURI "libjwt-typed-test" + , JWT.sub = JWT.stringOrURI "test-private-claims-simple" + , JWT.unregisteredClaims = JWT.ClaimsMap $ Map.fromList + [ ("name" , JSON.String "John Doe") + , ("userId" , JSON.Number 12345) + , ("isAdmin", JSON.Bool False) + ] + } + ) data UserRole = Admin | RegularUser deriving stock (Show, Eq, Generic) @@ -142,17 +153,10 @@ instance ToPrivateClaims ClaimObj instance FromPrivateClaims ClaimObj -privateClaimsComplexTest :: Alg -> Spec -privateClaimsComplexTest alg = +privateClaimsComplexTest :: SomeAlgorithm -> Spec +privateClaimsComplexTest sa = E.specify "private-claims-complex" - $ mkTest - Header { alg, typ = JWT } - (JWT.ClaimsMap $ Map.fromList - [ ("name" , JSON.String "John Doe") - , ("userId", JSON.Number 12345) - , ("role" , JSON.String "regularUser") - ] - ) + $ mkTest sa JWT <$> jwtPayload ( withIssuer "libjwt-typed-test" <> withSubject "test-private-claims-complex" @@ -161,18 +165,22 @@ , userId = 12345 , role = Flag RegularUser } + <*> pure + (mempty + { JWT.iss = JWT.stringOrURI "libjwt-typed-test" + , JWT.sub = JWT.stringOrURI "test-private-claims-complex" + , JWT.unregisteredClaims = JWT.ClaimsMap $ Map.fromList + [ ("name" , JSON.String "John Doe") + , ("userId", JSON.Number 12345) + , ("role" , JSON.String "regularUser") + ] + } + ) -privateClaimsNsTest :: Alg -> Spec -privateClaimsNsTest alg = +privateClaimsNsTest :: SomeAlgorithm -> Spec +privateClaimsNsTest sa = E.specify "private-claims-ns" - $ mkTest - Header { alg, typ = JWT } - (JWT.ClaimsMap $ Map.fromList - [ ("http://example.com/name" , JSON.String "John Doe") - , ("http://example.com/userId" , JSON.Number 12345) - , ("http://example.com/isAdmin", JSON.Bool False) - ] - ) + $ mkTest sa JWT <$> jwtPayload ( withIssuer "libjwt-typed-test" <> withSubject "test-private-claims-ns" @@ -186,43 +194,66 @@ , #isAdmin ->> False ) ) + <*> E.withEpochTime + (\t -> mempty + { JWT.iss = JWT.stringOrURI "libjwt-typed-test" + , JWT.sub = JWT.stringOrURI "test-private-claims-ns" + , JWT.iat = JWT.numericDate t + , JWT.nbf = JWT.numericDate t + , JWT.unregisteredClaims = JWT.ClaimsMap $ Map.fromList + [ ("http://example.com/name" , JSON.String "John Doe") + , ("http://example.com/userId" , JSON.Number 12345) + , ("http://example.com/isAdmin", JSON.Bool False) + ] + } + ) -utfTest :: Alg -> Spec -utfTest alg = +utfTest :: SomeAlgorithm -> Spec +utfTest sa = E.specify "utf" - $ mkTest - Header { alg, typ = JWT } - (JWT.ClaimsMap $ Map.fromList - [("name", JSON.String "孔子"), ("status", JSON.String "不患人之不己知，患不知人也")] - ) + $ mkTest sa JWT <$> jwtPayload (withIssuer "libjwt-typed-test" <> withSubject "test-utf") (#name ->> ("孔子" :: String), #status ->> ("不患人之不己知，患不知人也" :: T.Text)) + <*> pure + (mempty + { JWT.iss = JWT.stringOrURI "libjwt-typed-test" + , JWT.sub = JWT.stringOrURI "test-utf" + , JWT.unregisteredClaims = JWT.ClaimsMap $ Map.fromList + [ ("name", JSON.String "孔子") + , ( "status" + , JSON.String "不患人之不己知，患不知人也" + ) + ] + } + ) mkTest :: Encode (PrivateClaims cs ns) - => Header - -> JWT.ClaimsMap + => SomeAlgorithm + -> Typ -> Payload cs ns + -> JWT.JWTClaimsSet -> Expectation -mkTest outHeader expected payload = - let outJwt = Jwt { header = outHeader, payload } - token = TE.decodeASCII $ getToken $ signJwt outJwt - in expectDecodable token $ \unverifiedJwt -> do - expectHeader outHeader $ JWT.header unverifiedJwt - expectClaimsSet payload expected $ JWT.claims unverifiedJwt - case mkSigner $ alg outHeader of - Nothing -> pure () - Just signer -> - maybe - ( expectationFailure - $ "Web.JWT: Unverifiable token\n" - ++ show token - ++ "\nheader:\n" - ++ show outHeader - ) - (const $ pure ()) - $ JWT.verify signer unverifiedJwt +mkTest sa@(SomeAlgorithm a) typ payload expected = + expectDecodable token $ \unverifiedJwt -> do + expectHeader outHeader $ JWT.header unverifiedJwt + JWT.claims unverifiedJwt `shouldBe` expected + case mkSigner sa of + Nothing -> expectationOk + Just signer -> + maybe + ( expectationFailure + $ "Web.JWT: Unverifiable token\n" + ++ show token + ++ "\nheader:\n" + ++ show outHeader + ) + (const expectationOk) + $ JWT.verify signer unverifiedJwt + where + outHeader = Header { alg = toHeaderAlg a, typ } + token = TE.decodeASCII $ getToken $ sign' typ a payload expectDecodable :: T.Text -> (JWT.JWT JWT.UnverifiedJWT -> Expectation) -> Expectation @@ -242,46 +273,6 @@ typ' JWT = Just "JWT" typ' (Typ mbs) = TE.decodeUtf8 <$> mbs - alg' (HS256 _) = Just JWT.HS256 - alg' (RS256 _) = Just JWT.RS256 - alg' _ = Nothing - -expectClaimsSet - :: Payload cs ns -> JWT.ClaimsMap -> JWT.JWTClaimsSet -> Expectation -expectClaimsSet expected expectedUnreg got = - got - `shouldBe` JWT.JWTClaimsSet (iss' $ iss expected) - (sub' $ sub expected) - (aud' $ aud expected) - (exp' $ exp expected) - (nbf' $ nbf expected) - (iat' $ iat expected) - (jti' $ jti expected) - expectedUnreg - where - stringToStringOrURI s = - fromMaybe (error $ "JWT.stringOrURI on " ++ show s) - $ JWT.stringOrURI - $ T.pack s - - numericDateToIntDate d = - fromMaybe (error $ "JWT.numericDate on " ++ show d) - $ JWT.numericDate - $ toPOSIX d - - iss' (Iss ms) = stringToStringOrURI <$> ms - - sub' (Sub ms) = stringToStringOrURI <$> ms - - aud' (Aud []) = Nothing - aud' (Aud xs) = Just $ Right $ map stringToStringOrURI xs - - exp' (Exp mnd) = numericDateToIntDate <$> mnd - - nbf' (Nbf mnd) = numericDateToIntDate <$> mnd - - iat' (Iat mnd) = numericDateToIntDate <$> mnd - - jti' (Jti muid) = stringToStringOrURI . UUID.toString <$> muid - - + alg' HS256 = Just JWT.HS256 + alg' RS256 = Just JWT.RS256 + alg' _ = Nothing diff --git a/test/Interop/JWTHelpers.hs b/test/Interop/JWTHelpers.hs --- a/test/Interop/JWTHelpers.hs +++ b/test/Interop/JWTHelpers.hs @@ -1,33 +1,54 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + module Interop.JWTHelpers ( mkSigner - , mkJWTAlgorithm + , SomeAlgorithm(..) + , hmac256 + , none + , rsa256 + , toHeaderAlg ) where -import Web.Libjwt ( Alg(..) - , RsaKeyPair(..) +import Web.Libjwt ( Algorithm(..) + , SigningKey(..) , Secret(..) ) +import Libjwt.Algorithms ( toHeaderAlg ) +import qualified Env as E + import Data.Maybe ( fromMaybe ) import qualified Web.JWT as JWT -mkSigner :: Alg -> Maybe JWT.Signer -mkSigner (HS256 secret) = Just $ JWT.HMACSecret $ reveal secret -mkSigner (RS256 pem ) = Just $ mkRSAPrivateKey pem -mkSigner None = Nothing -mkSigner _ = error "Unsupported alg" +data SomeAlgorithm = forall k . SigningKey k => SomeAlgorithm (Algorithm k) -mkRSAPrivateKey :: RsaKeyPair -> JWT.Signer -mkRSAPrivateKey pem = - JWT.RSAPrivateKey - $ fromMaybe (error $ "JWT.readRsaSecret on\n" ++ show pem) - $ JWT.readRsaSecret - $ privKey pem +hmac256 :: SomeAlgorithm +hmac256 = + SomeAlgorithm + $ HMAC256 + "MWNmYzExODA5OWFjOGM3NDNmMmM5Zjg5ZDc0YTM3M2VhMGNkMzA2MDY3ZjFhZDk5N2I3OTc5Yjdm\ + \NDg3NDBkMiAgLQo" -mkJWTAlgorithm :: Alg -> Maybe JWT.Algorithm -mkJWTAlgorithm None = Nothing -mkJWTAlgorithm (HS256 _) = Just JWT.HS256 -mkJWTAlgorithm (RS256 _) = Just JWT.RS256 -mkJWTAlgorithm _ = error "Unsupported algorithm" +none :: SomeAlgorithm +none = SomeAlgorithm AlgNone + +rsa256 :: SomeAlgorithm +rsa256 = SomeAlgorithm $ RSA256 E.testRsa2048KeyPair + +mkSigner :: SomeAlgorithm -> Maybe JWT.Signer +mkSigner (SomeAlgorithm (HMAC256 secret)) = + Just $ JWT.HMACSecret $ reveal secret +mkSigner (SomeAlgorithm (RSA256 pem)) = Just $ mkRSAPrivateKey pem +mkSigner (SomeAlgorithm AlgNone ) = Nothing +mkSigner _ = error "Unsupported alg" + +mkRSAPrivateKey :: SigningKey k => k -> JWT.Signer +mkRSAPrivateKey k = + let rsaSecret = getSigningKey k + in JWT.RSAPrivateKey + $ fromMaybe (error $ "JWT.readRsaSecret on\n" ++ show rsaSecret) + $ JWT.readRsaSecret rsaSecret diff --git a/test/Properties.hs b/test/Properties.hs --- a/test/Properties.hs +++ b/test/Properties.hs @@ -74,39 +74,40 @@ prop_encode_decode_roundtrip_poly :: (Decode (PrivateClaims pc ns), Encode (PrivateClaims pc ns), Show a, Eq a) - => (Jwt pc ns -> a) - -> (a -> Jwt pc ns) + => (Payload pc ns -> a) + -> (a -> Payload pc ns) -> a -> Property prop_encode_decode_roundtrip_poly project embed a = - let jwt = embed a - in left - displayException - ( decodeByteString (alg $ header jwt) (getToken $ signJwt jwt) - <&> project - . getDecoded - ) - === pure a + forAll genAlgorithm $ \(SomeAlgorithm algorithm) -> + left + displayException + ( decodeByteString algorithm (getToken $ sign algorithm $ embed a) + <&> project + . payload + . getDecoded + ) + === pure a -prop_encode_decode_roundtrip_reg_only :: Jwt Empty 'NoNs -> Property +prop_encode_decode_roundtrip_reg_only :: Payload Empty 'NoNs -> Property prop_encode_decode_roundtrip_reg_only = prop_encode_decode_roundtrip_poly id id prop_encode_decode_roundtrip - :: Jwt + :: Payload '["intField" ->> Int, "dateField" ->> UTCTime, "textField" ->> JwtText, "optField" ->> Maybe JwtString, "arrayField" ->> [JwtText], "nonEmptyField" ->> NonEmpty ASCII] 'NoNs -> Property prop_encode_decode_roundtrip = prop_encode_decode_roundtrip_poly id id prop_encode_decode_roundtrip_ns - :: Jwt + :: Payload '["dayField" ->> Day, "arrayField" ->> [Int], "stringField" ->> JwtString] ( 'SomeNs "https://example.com") -> Property prop_encode_decode_roundtrip_ns = prop_encode_decode_roundtrip_poly id id prop_encode_decode_rountrip_comp - :: Jwt + :: Payload '["user_name" ->> JwtText, "is_root" ->> Bool, "type" ->> Flag AccountType, "client_id" ->> UUID, "created" ->> UTCTime, "accounts" ->> NonEmpty (UUID, JwtText)] 'NoNs -> Property @@ -138,15 +139,9 @@ <*> shrink createdAt prop_from_to_generic :: ClaimObj -> Property -prop_from_to_generic claimObj = forAllBlind genHeader $ \header -> - prop_encode_decode_roundtrip_poly - (fromPrivateClaims . privateClaims . payload) - (\claimObj' -> Jwt - { header - , payload = def { privateClaims = toPrivateClaims claimObj' } - } - ) - claimObj +prop_from_to_generic = prop_encode_decode_roundtrip_poly + (fromPrivateClaims . privateClaims) + (\claimObj' -> def { privateClaims = toPrivateClaims claimObj' }) data Account = MkAccount { account_name :: JwtText, account_id :: UUID } deriving stock (Show, Eq, Generic) @@ -166,7 +161,7 @@ shrink (MkAccount name id) = MkAccount <$> shrink name <*> shrink id prop_encode_decode_roundtrip_aeson - :: Jwt '["user_id" ->> Int, "accounts" ->> NonEmpty Account] 'NoNs + :: Payload '["user_id" ->> Int, "accounts" ->> NonEmpty Account] 'NoNs -> Property prop_encode_decode_roundtrip_aeson = prop_encode_decode_roundtrip_poly id id