From f6371a81b2a4c46d92cff6c1bc0a599b2e2710d8 Mon Sep 17 00:00:00 2001
From: Fraser Tweedale <frase@frase.id.au>
Date: Wed, 7 Feb 2024 15:24:08 +1000
Subject: [PATCH] add functions to access unverified payload

Fixes: https://github.com/frasertweedale/hs-jose/issues/126
---
 CHANGELOG.md           |  6 ++++++
 src/Crypto/JOSE/JWS.hs | 37 +++++++++++++++++++++++++++++++------
 src/Crypto/JWT.hs      | 30 ++++++++++++++++++++++++++----
 3 files changed, 63 insertions(+), 10 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 2220192..e698084 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,11 @@
 ## Version NEXT
 
+- Added `footgunGetPayload`, `footgunGetJWTPayload` and
+  `footgunGetJWTClaimsSet` functions.  These enable access to
+  the JWS/JWT payload without cryptographic verification.  As
+  the name imlies, these should be used with the utmost caution!
+  ([#126](https://github.com/frasertweedale/hs-jose/issues/126))
+
 - Add `Crypto.JOSE.JWK.negotiateJWSAlg` which chooses the
   cryptographically strongest JWS algorithm for a given key,
   restricted to a given set of algorithms.  ([#118][])
diff --git a/src/Crypto/JOSE/JWS.hs b/src/Crypto/JOSE/JWS.hs
index e0c8d8a..22ef077 100644
--- a/src/Crypto/JOSE/JWS.hs
+++ b/src/Crypto/JOSE/JWS.hs
@@ -71,6 +71,9 @@ module Crypto.JOSE.JWS
   , HasAlgorithms(..)
   , HasValidationPolicy(..)
 
+  -- * Access payload without verification
+  , footgunGetPayload
+
   -- * Signature data
   , signatures
   , Signature
@@ -363,8 +366,7 @@ instance HasParams JWSHeader where
       ]
 
 
--- | JSON Web Signature data type.  The payload can only be
--- accessed by verifying the JWS.
+-- | JSON Web Signature data type.
 --
 -- Parameterised by the signature container type, the header
 -- 'ProtectionIndicator' type, and the header record type.
@@ -380,9 +382,14 @@ instance HasParams JWSHeader where
 -- 'encodeCompact').
 --
 -- Use 'signJWS' to create a signed/MACed JWS.
+
+-- Use 'verifyJWS', 'verifyJWS'' or 'verifyJWSWithPayload' to verify
+-- a JWS and extract the payload.
 --
--- Use 'verifyJWS' to verify a JWS and extract the payload.
---
+-- Applications generally should not access a payload without
+-- first verifying it.  If you have an exceptional use case, you
+-- can use 'footgunGetPayload' to access the payload.
+
 data JWS t p a = JWS Types.Base64Octets (t (Signature p a))
 
 -- | A JWS that allows multiple signatures, and cannot use
@@ -434,6 +441,20 @@ instance (HasParams a, ProtectionIndicator p) => ToJSON (JWS Identity p a) where
   toJSON (JWS p (Identity s)) = Types.insertToObject "payload" p (toJSON s)
 
 
+-- | Get the payload __without verifying it__.  Do not use this
+-- function unless you have a compelling reason.
+--
+-- Most applications should use 'verifyJWSWithPayload', 'verifyJWS'
+-- or 'verifyJWS'' to verify the JWS and access the payload.
+--
+footgunGetPayload
+  :: (Cons s s Word8 Word8, AsEmpty s)
+  => (s -> m payload)   -- ^ Function to decode payload
+  -> JWS t p a          -- ^ JWS
+  -> m payload
+footgunGetPayload dec (JWS (Types.Base64Octets s) _) = views recons dec s
+
+
 signingInput
   :: (HasParams a, ProtectionIndicator p)
   => Signature p a
@@ -618,6 +639,10 @@ verifyJWS
 verifyJWS = verifyJWSWithPayload pure
 {-# INLINE verifyJWS #-}
 
+-- | Verify a JWS, with explicit payload decoding.  This variant
+-- enables the key store to use information in the payload to locate
+-- verification key(s).
+--
 verifyJWSWithPayload
   ::  ( HasAlgorithms a, HasValidationPolicy a, AsError e, MonadError e m
       , HasJWSHeader h, HasParams h
@@ -631,7 +656,7 @@ verifyJWSWithPayload
   -> k                 -- ^ key or key store
   -> JWS t p h         -- ^ JWS
   -> m payload
-verifyJWSWithPayload dec conf k (JWS p@(Types.Base64Octets p') sigs) =
+verifyJWSWithPayload dec conf k jws@(JWS p sigs) =
   let
     algs :: S.Set Alg
     algs = conf ^. algorithms
@@ -649,7 +674,7 @@ verifyJWSWithPayload dec conf k (JWS p@(Types.Base64Octets p') sigs) =
         then throwing_ _NoUsableKeys
         else pure $ any ((== Right True) . verifySig p sig) keys
   in do
-    payload <- (dec . view recons) p'
+    payload <- footgunGetPayload dec jws
     results <- traverse (validate payload) $ filter shouldValidateSig $ toList sigs
     payload <$ applyPolicy policy results
 {-# INLINE verifyJWSWithPayload #-}
diff --git a/src/Crypto/JWT.hs b/src/Crypto/JWT.hs
index 7f5c205..c420bc1 100644
--- a/src/Crypto/JWT.hs
+++ b/src/Crypto/JWT.hs
@@ -62,6 +62,10 @@ module Crypto.JWT
   , verifyClaimsAt
   , verifyJWTAt
 
+  -- ** Extracting claims without verification
+  , footgunGetJWTPayload
+  , footgunGetJWTClaimsSet
+
   -- ** Claims Set
   , ClaimsSet
   , emptyClaimsSet
@@ -633,15 +637,33 @@ instance Monad m => MonadTime (ReaderT WrappedUTCTime m) where
   monotonicTime = pure 0
 #endif
 
+-- | Get the JWT payload __without verifying it__.  Do not use this
+-- function unless you have a compelling reason.
+--
+-- Most applications should use 'verifyJWT' or one of its variants
+-- to verify the JWT and access the claims.
+--
+-- See also 'footgunGetJWTClaimsSet' which is the same as this
+-- function with the payload type specialised to 'ClaimsSet'.
+--
+footgunGetJWTPayload
+  :: ( FromJSON payload, AsJWTError e, MonadError e m )
+  => SignedJWT -> m payload
+footgunGetJWTPayload = footgunGetPayload f
+  where
+  f = either (throwing _JWTClaimsSetDecodeError) pure . eitherDecode
+
+-- | Variant of 'footgunGetJWTPayload' specialised to 'ClaimsSet'
+footgunGetJWTClaimsSet
+  :: ( AsJWTError e, MonadError e m )
+  => SignedJWT -> m ClaimsSet
+footgunGetJWTClaimsSet = footgunGetJWTPayload
+
 
 -- | Cryptographically verify a JWS JWT, then validate the
 -- Claims Set, returning it if valid.  The claims are validated
 -- at the current system time.
 --
--- This is the only way to get at the claims of a JWS JWT,
--- enforcing that the claims are cryptographically and
--- semantically valid before the application can use them.
---
 -- This function is abstracted over any payload type with 'HasClaimsSet' and
 -- 'FromJSON' instances.  The 'verifyClaims' variant uses 'ClaimsSet' as the
 -- payload type.