jwt: support custom header types

Generalise the types of `signJWT`, `verifyJWT`, and related
functions to accept custom JWS header types.  Add new type synonym
`SignedJWTWithHeader h` (keeping `SignedJWT` *as is*).  This change
could break some applications by introducing type ambiguity.  The
solution is to add a type annotation or apply a function like:

```haskell
fixType = id :: SignedJWT -> SignedJWT
```

I applied this technique in the test suite to address such
ambiguity.

Fixes: #122

CHANGELOG.md

@@ -1,5 +1,12 @@
 ## Version NEXT
 
+- Generalised the types of `signJWT`, `verifyJWT` and related
+  functions to accept custom JWS header types.  Added new type
+  synonym `SignedJWTWithHeader h`.  This change could break some
+  applications by introducing ambiguity.  The solution will be
+  to add a type annotation or apply a function like `fixType = id ::
+  SignedJWT -> SignedJWT` to specify the header type. ([#122][]).
+
 - Add `Crypto.JOSE.JWK.negotiateJWSAlg` which chooses the
   cryptographically strongest JWS algorithm for a given key,
   restricted to a given set of algorithms.  ([#118][])
@@ -71,6 +78,7 @@
 [#106]: https://github.com/frasertweedale/hs-jose/issues/106
 [#107]: https://github.com/frasertweedale/hs-jose/issues/107
 [#118]: https://github.com/frasertweedale/hs-jose/issues/118
+[#122]: https://github.com/frasertweedale/hs-jose/issues/122
 
 
 ## Older versions

src/Crypto/JWT.hs

@@ -43,8 +43,9 @@ module Crypto.JWT
   -- * API
   -- ** Creating a JWT
     SignedJWT
-  , signClaims
+  , SignedJWTWithHeader
   , signJWT
+  , signClaims
 
   -- ** Validating a JWT and extracting claims
   , defaultJWTValidationSettings
@@ -151,8 +152,8 @@ verify k s = 'runJOSE' $ do
   let
     k' = 'fromOctets' k      -- turn raw secret into symmetric JWK
     audCheck = const True  -- should be a proper audience check
-  jwt <- 'decodeCompact' s    -- decode JWT
-  'verifyClaims' ('defaultJWTValidationSettings' audCheck) k' jwt
+  jwt <- 'decodeCompact' s   -- decode JWT
+  'verifyClaims' ('defaultJWTValidationSettings' audCheck) k' (jwt :: 'SignedJWT')
 @
 
 -}
@@ -617,10 +618,16 @@ validateIssClaim conf =
     unless (view issuerPredicate conf iss) (throwing_ _JWTNotInIssuer) )
   . preview (claimIss . _Just)
 
--- | A digitally signed or MACed JWT
+-- | A digitally signed or MAC'd JWT, with the JWS header type fixed
+-- at 'JWSHeader'.
 --
-type SignedJWT = CompactJWS JWSHeader
+type SignedJWT = SignedJWTWithHeader JWSHeader
 
+-- | A digitally signed or MAC'd JWT, with caller-specified JWS
+-- header type.  For information about defining custom header types
+-- see /Defining additional header parameters/ in "Crypto.JOSE.JWS".
+--
+type SignedJWTWithHeader h = CompactJWS h
 
 newtype WrappedUTCTime = WrappedUTCTime { getUTCTime :: UTCTime }
 
@@ -656,13 +663,14 @@ verifyJWT
     , HasIssuerPredicate a
     , HasCheckIssuedAt a
     , HasValidationSettings a
+    , HasJWSHeader h, HasParams h
     , AsError e, AsJWTError e, MonadError e m
-    , VerificationKeyStore m (JWSHeader ()) payload k
+    , VerificationKeyStore m (h ()) payload k
     , HasClaimsSet payload, FromJSON payload
     )
   => a
   -> k
-  -> SignedJWT
+  -> SignedJWTWithHeader h
   -> m payload
 verifyJWT conf k jws =
   -- It is important, for security reasons, that the signature get
@@ -679,12 +687,13 @@ verifyClaims
     , HasIssuerPredicate a
     , HasCheckIssuedAt a
     , HasValidationSettings a
+    , HasJWSHeader h, HasParams h
     , AsError e, AsJWTError e, MonadError e m
-    , VerificationKeyStore m (JWSHeader ()) ClaimsSet k
+    , VerificationKeyStore m (h ()) ClaimsSet k
     )
   => a
   -> k
-  -> SignedJWT
+  -> SignedJWTWithHeader h
   -> m ClaimsSet
 verifyClaims = verifyJWT
 
@@ -698,14 +707,15 @@ verifyJWTAt
     , HasIssuerPredicate a
     , HasCheckIssuedAt a
     , HasValidationSettings a
+    , HasJWSHeader h, HasParams h
     , AsError e, AsJWTError e, MonadError e m
-    , VerificationKeyStore (ReaderT WrappedUTCTime m) (JWSHeader ()) payload k
+    , VerificationKeyStore (ReaderT WrappedUTCTime m) (h ()) payload k
     , HasClaimsSet payload, FromJSON payload
     )
   => a
   -> k
   -> UTCTime
-  -> SignedJWT
+  -> SignedJWTWithHeader h
   -> m payload
 verifyJWTAt a k t jwt = runReaderT (verifyJWT a k jwt) (WrappedUTCTime t)
 
@@ -718,13 +728,14 @@ verifyClaimsAt
     , HasIssuerPredicate a
     , HasCheckIssuedAt a
     , HasValidationSettings a
+    , HasJWSHeader h, HasParams h
     , AsError e, AsJWTError e, MonadError e m
-    , VerificationKeyStore (ReaderT WrappedUTCTime m) (JWSHeader ()) ClaimsSet k
+    , VerificationKeyStore (ReaderT WrappedUTCTime m) (h ()) ClaimsSet k
     )
   => a
   -> k
   -> UTCTime
-  -> SignedJWT
+  -> SignedJWTWithHeader h
   -> m ClaimsSet
 verifyClaimsAt = verifyJWTAt
 
@@ -738,11 +749,17 @@ verifyClaimsAt = verifyJWTAt
 --
 signJWT
   :: ( MonadRandom m, MonadError e m, AsError e
+     , HasJWSHeader h, HasParams h
      , ToJSON payload )
   => JWK
-  -> JWSHeader ()
+  -- ^ Signing key
+  -> h ()
+  -- ^ JWS Header.  Commonly this will be 'JWSHeader'.  If your application
+  -- uses additional header fields, see /Defining additional header parameters/
+  -- in "Crypto.JOSE.JWS".
   -> payload
-  -> m SignedJWT
+  -- ^ The payload ('ClaimsSet' or a subtype).
+  -> m (SignedJWTWithHeader h)
 signJWT k h c = signJWS (encode c) (Identity (h, k))
 
 -- | Create a JWS JWT.  Specialisation of 'signJWT' with payload type fixed
@@ -752,9 +769,10 @@ signJWT k h c = signJWS (encode c) (Identity (h, k))
 -- ("Issued At") Claim.  The payload is encoded as-is.
 --
 signClaims
-  :: (MonadRandom m, MonadError e m, AsError e)
+  :: ( MonadRandom m, MonadError e m, AsError e
+     , HasJWSHeader h, HasParams h )
   => JWK
-  -> JWSHeader ()
+  -> h ()
   -> ClaimsSet
-  -> m SignedJWT
+  -> m (SignedJWTWithHeader h)
 signClaims = signJWT

test/Examples.hs

@@ -42,7 +42,7 @@ fromX509VerifySpec =
           (do
             es256jwk <- errorOrJWK
             jwt <- decodeCompact es256token
-            verifyClaimsAt valSettings es256jwk now jwt) `shouldBe`
+            verifyClaimsAt valSettings es256jwk now (jwt :: SignedJWT)) `shouldBe`
           Right expectedClaims
 
       _ -> pure ()

test/JWT.hs

@@ -88,6 +88,7 @@ spec = do
               (defaultJWTValidationSettings (const False))
       headMay []    = Nothing
       headMay (h:_) = Just h
+      fixType = id :: SignedJWT -> SignedJWT
 
   describe "JWT Claims Set" $ do
     it "parses from JSON correctly" $ do
@@ -339,9 +340,9 @@ spec = do
            192,205,154,245,103,208,128,163]
         now = utcTime "2010-01-01 00:00:00"
         settings = defaultJWTValidationSettings (const True)
-      runReaderT (decodeCompact exampleJWT >>= verifyClaims settings k) now
+      runReaderT (decodeCompact exampleJWT >>= verifyClaims settings k . fixType) now
         `shouldBe` (Right exampleClaimsSet :: Either JWTError ClaimsSet)
-      runReaderT (decodeCompact exampleJWT >>= verifyJWT settings k) now
+      runReaderT (decodeCompact exampleJWT >>= verifyJWT settings k . fixType) now
         `shouldBe` (Right super :: Either JWTError Super)
 
   describe "RFC 7519 §6.1.  Example Unsecured JWT" $ do
@@ -357,17 +358,17 @@ spec = do
 
     describe "when the current time is prior to the Expiration Time" $
       it "can be decoded and validated" $
-        runReaderT (jwt >>= verifyClaims conf k) (utcTime "2010-01-01 00:00:00")
+        runReaderT (jwt >>= verifyClaims conf k . fixType) (utcTime "2010-01-01 00:00:00")
           `shouldBe` (Right exampleClaimsSet :: Either JWTError ClaimsSet)
 
     describe "when the current time is after the Expiration Time" $
       it "can be decoded, but not validated" $
-        runReaderT (jwt >>= verifyClaims conf k) (utcTime "2012-01-01 00:00:00")
+        runReaderT (jwt >>= verifyClaims conf k . fixType) (utcTime "2012-01-01 00:00:00")
           `shouldBe` Left JWTExpired
 
     describe "when signature is invalid and token is expired" $
       it "fails on sig validation (claim validation not reached)" $ do
         let jwt' = decodeCompact (exampleJWT <> "badsig")
-        (runReaderT (jwt' >>= verifyClaims conf k) (utcTime "2012-01-01 00:00:00")
+        (runReaderT (jwt' >>= verifyClaims conf k . fixType) (utcTime "2012-01-01 00:00:00")
           :: Either JWTError ClaimsSet)
           `shouldSatisfy` is (_Left . _JWSInvalidSignature)