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.
Possible solutions include…

Type application:

```haskell
{-# LANGUAGE TypeApplications #-}
decodeCompact @SignedJWT s >>= verifyClaims settings k
```

Type annotation:

```haskell
do
  jwt <- decodeCompact s
  verifyClaims settings k (jwt :: SignedJWT)
```

Explicitly typed coercion function:

```haskell
let
  fixType = id :: SignedJWT -> SignedJWT
in
  verifyClaims settings k . fixType =<< decodeCompact s
```

I used type applications in the test suite to address the ambiguity.

Fixes: #122

CHANGELOG.md

@@ -1,5 +1,29 @@
 ## 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 is to use
+  a type annotation, type application, or explicit coercion
+  function, as in the below examples:
+
+  ```haskell
+  -- type application
+  {-# LANGUAGE TypeApplications #-}
+  decodeCompact @SignedJWT s >>= verifyClaims settings k
+
+  -- type annotation
+  do
+    jwt <- decodeCompact s
+    verifyClaims settings k (jwt :: SignedJWT)
+
+  -- coercion function
+  let
+    fixType = id :: SignedJWT -> SignedJWT
+  in
+    verifyClaims settings k . fixType =<< decodeCompact s
+  ```
+
 - Added `unsafeGetPayload`, `unsafeGetJWTPayload` and
   `unsafeGetJWTClaimsSet` functions.  These enable access to
   the JWS/JWT payload without cryptographic verification.  As
@@ -77,6 +101,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
@@ -155,8 +156,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')
 @
 
 -}
@@ -621,10 +622,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 }
 
@@ -678,13 +685,18 @@ 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
+  -- ^ Validation settings
   -> k
-  -> SignedJWT
+  -- ^ Key store
+  -> SignedJWTWithHeader h
+  -- ^ JWT.  Simple use cases may find the 'SignedJWT' type synonym useful for
+  -- fixing the type of @h@.
   -> m payload
 verifyJWT conf k jws =
   -- It is important, for security reasons, that the signature get
@@ -701,12 +713,17 @@ 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
+  -- ^ Validation settings
   -> k
-  -> SignedJWT
+  -- ^ Key store
+  -> SignedJWTWithHeader h
+  -- ^ JWT.  Simple use cases may find the 'SignedJWT' type synonym useful for
+  -- fixing the type of @h@.
   -> m ClaimsSet
 verifyClaims = verifyJWT
 
@@ -720,14 +737,20 @@ 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
+  -- ^ Validation settings
   -> k
+  -- ^ Key store
   -> UTCTime
-  -> SignedJWT
+  -- ^ Validation time
+  -> SignedJWTWithHeader h
+  -- ^ JWT.  Simple use cases may find the 'SignedJWT' type synonym useful for
+  -- fixing the type of @h@.
   -> m payload
 verifyJWTAt a k t jwt = runReaderT (verifyJWT a k jwt) (WrappedUTCTime t)
 
@@ -740,13 +763,19 @@ 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
+  -- ^ Validation settings
   -> k
+  -- ^ Key store
   -> UTCTime
-  -> SignedJWT
+  -- ^ Validation time
+  -> SignedJWTWithHeader h
+  -- ^ JWT.  Simple use cases may find the 'SignedJWT' type synonym useful for
+  -- fixing the type of @h@.
   -> m ClaimsSet
 verifyClaimsAt = verifyJWTAt
 
@@ -760,11 +789,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
@@ -774,9 +809,15 @@ 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 ()
+  -- ^ 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".
   -> ClaimsSet
-  -> m SignedJWT
+  -- ^ Payload
+  -> 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

@@ -14,6 +14,7 @@
 
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
 
 module JWT
   ( spec
@@ -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 @SignedJWT exampleJWT >>= verifyClaims settings k) now
         `shouldBe` (Right exampleClaimsSet :: Either JWTError ClaimsSet)
-      runReaderT (decodeCompact exampleJWT >>= verifyJWT settings k) now
+      runReaderT (decodeCompact @SignedJWT exampleJWT >>= verifyJWT settings k) now
         `shouldBe` (Right super :: Either JWTError Super)
 
   describe "RFC 7519 §6.1.  Example Unsecured JWT" $ do
@@ -352,7 +353,7 @@ spec = do
         <> "eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFt"
         <> "cGxlLmNvbS9pc19yb290Ijp0cnVlfQ"
         <> "."
-      jwt = decodeCompact exampleJWT
+      jwt = decodeCompact @SignedJWT exampleJWT
       k = fromJust $ decode "{\"kty\":\"oct\",\"k\":\"\"}" :: JWK
 
     describe "when the current time is prior to the Expiration Time" $
@@ -367,7 +368,7 @@ spec = do
 
     describe "when signature is invalid and token is expired" $
       it "fails on sig validation (claim validation not reached)" $ do
-        let jwt' = decodeCompact (exampleJWT <> "badsig")
+        let jwt' = decodeCompact @SignedJWT (exampleJWT <> "badsig")
         (runReaderT (jwt' >>= verifyClaims conf k) (utcTime "2012-01-01 00:00:00")
           :: Either JWTError ClaimsSet)
           `shouldSatisfy` is (_Left . _JWSInvalidSignature)