libjwt-typed 0.1 → 0.2

raw patch · 20 files changed

+916/−727 lines, 20 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• README.md +32/−12
• bench/Algorithms.hs +12/−11
• bench/Benchmarks.hs +17/−43
• bench/Benchmarks/Jose.hs +14/−8
• bench/Benchmarks/Libjwt.hs +92/−81
• libjwt-typed.cabal +3/−1
• src/Libjwt/Algorithms.hs +112/−0
• src/Libjwt/FFI/Jwt.hs +6/−3
• src/Libjwt/Header.hs +41/−41
• src/Libjwt/Jwt.hs +62/−70
• src/Libjwt/Keys.hs +77/−0
• src/Web/Libjwt.hs +26/−24
• src/Web/Libjwt/Tutorial.hs +2/−2
• test/Env.hs +23/−5
• test/Generators.hs +38/−36
• test/Interop/JWTDecoding.hs +165/−213
• test/Interop/JWTEncoding.hs +125/−134
• test/Interop/JWTHelpers.hs +40/−19
• test/Properties.hs +19/−24

@@ -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.

@@ -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)

@@ -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 =

@@ -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"

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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"

@@ -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

@@ -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 

@@ -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+

@@ -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

@@ -48,9 +48,9 @@ instance ToPrivateClaims UserClaims instance FromPrivateClaims UserClaims -hmac512 :: Alg+hmac512 :: Algorithm Secret hmac512 =-  HS512+  HMAC512     "MjZkMDY2OWFiZmRjYTk5YjczZWFiZjYzMmRjMzU5NDYyMjMxODBjMTg3ZmY5OTZjM2NhM2NhN2Mx\     \YzFiNDNlYjc4NTE1MjQxZGI0OWM1ZWI2ZDUyZmMzZDlhMmFiNjc5OWJlZTUxNjE2ZDRlYTNkYjU5\     \Y2IwMDZhYWY1MjY1OTQgIC0K"

@@ -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--

@@ -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 =

@@ -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

@@ -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

@@ -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

@@ -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