remove orphan MonadRandom instance

To avoid problems with orphan instances, introduce

    newtype JOSE e m a

Which behaves like `Except e m a` but also has

    instance (MonadRandom m) => MonadRandom (JOSE e m)

This is an API breaking change and therefore requires a major
version bump before release.

Fixes: #91

example/JWS.hs

@@ -2,7 +2,6 @@ module JWS where
 
 import System.Exit (exitFailure)
 
-import Control.Monad.Except (runExceptT)
 import Data.Aeson (decode, encode)
 import qualified Data.ByteString.Lazy as L
 
@@ -19,7 +18,7 @@ doJwsSign :: [String] -> IO ()
 doJwsSign [jwkFilename, payloadFilename] = do
   Just jwk <- decode <$> L.readFile jwkFilename
   payload <- L.readFile payloadFilename
-  result <- runExceptT $ do
+  result <- runJOSE $ do
     h <- makeJWSHeader jwk
     signJWS payload [(h :: JWSHeader Protection, jwk)]
   case result of
@@ -38,7 +37,7 @@ doJwsVerify :: [String] -> IO ()
 doJwsVerify [jwkFilename, jwsFilename] = do
   Just jwk <- decode <$> L.readFile jwkFilename
   Just jws <- decode <$> L.readFile jwsFilename
-  result <- runExceptT $ verifyJWS' (jwk :: JWK) (jws :: GeneralJWS JWSHeader)
+  result <- runJOSE $ verifyJWS' (jwk :: JWK) (jws :: GeneralJWS JWSHeader)
   case result of
     Left e -> print (e :: Error) >> exitFailure
     Right s -> L.putStr s

example/Main.hs

@@ -11,7 +11,6 @@ import Data.Aeson (decode, eitherDecode, encode)
 import Data.Text.Strict.Lens (utf8)
 import System.Posix.Files (getFileStatus, isDirectory)
 
-import Control.Monad.Except (runExceptT)
 import Control.Lens (preview, re, review, set, view)
 
 import Crypto.JWT
@@ -54,7 +53,7 @@ doJwtSign :: [String] -> IO ()
 doJwtSign [jwkFilename, claimsFilename] = do
   Just k <- decode <$> L.readFile jwkFilename
   Just claims <- decode <$> L.readFile claimsFilename
-  result <- runExceptT $ makeJWSHeader k >>= \h -> signClaims k h claims
+  result <- runJOSE $ makeJWSHeader k >>= \h -> signClaims k h claims
   case result of
     Left e -> print (e :: Error) >> exitFailure
     Right jwt -> L.putStr (encodeCompact jwt)
@@ -77,7 +76,7 @@ doJwtVerify [jwkFilename, jwtFilename, aud] = do
   let
     aud' = fromJust $ preview stringOrUri aud
     conf = defaultJWTValidationSettings (== aud')
-    go k = runExceptT (decodeCompact jwtData >>= verifyClaims conf k)
+    go k = runJOSE $ decodeCompact jwtData >>= verifyClaims conf k
 
   jwkDir <- isDirectory <$> getFileStatus jwkFilename
   result <-

src/Crypto/JOSE/Error.hs

@@ -13,6 +13,7 @@
 -- limitations under the License.
 
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -33,12 +34,16 @@ module Crypto.JOSE.Error
   , CompactDecodeError(..)
   , _CompactInvalidNumberOfParts
   , _CompactInvalidText
+
+  , JOSE
+  , runJOSE
+  , unwrapJOSE
   ) where
 
 import Data.Semigroup ((<>))
 import Numeric.Natural
 
-import Control.Monad.Trans (MonadTrans(..))
+import Control.Monad.Except
 import qualified Crypto.PubKey.RSA as RSA
 import Crypto.Error (CryptoError)
 import Crypto.Random (MonadRandom(..))
@@ -118,10 +123,39 @@ data Error
 makeClassyPrisms ''Error
 
 
-instance (
-    MonadRandom m
-  , MonadTrans t
-  , Functor (t m)
-  , Monad (t m)
-  ) => MonadRandom (t m) where
+newtype JOSE e m a = JOSE (ExceptT e m a)
+
+-- | Run the 'JOSE' computation.  Result is an @Either e a@
+-- where @e@ is the error type (typically 'Error' or 'JWTError')
+runJOSE :: JOSE e m a -> m (Either e a)
+runJOSE = runExceptT . (\(JOSE m) -> m)
+
+-- | Get the inner 'ExceptT' value of the 'JOSE' computation.
+-- Typically 'runJOSE' would be preferred, unless you specifically
+-- need an 'ExceptT' value.
+unwrapJOSE :: JOSE e m a -> ExceptT e m a
+unwrapJOSE (JOSE m) = m
+
+
+instance (Functor m) => Functor (JOSE e m) where
+  fmap f (JOSE ma) = JOSE (fmap f ma)
+
+instance (Monad m) => Applicative (JOSE e m) where
+  pure = JOSE . pure
+  JOSE mf <*> JOSE ma = JOSE (mf <*> ma)
+
+instance (Monad m) => Monad (JOSE e m) where
+  JOSE ma >>= f = JOSE (ma >>= unwrapJOSE . f)
+
+instance MonadTrans (JOSE e) where
+  lift = JOSE . lift
+
+instance (Monad m) => MonadError e (JOSE e m) where
+  throwError = JOSE . throwError
+  catchError (JOSE m) handle = JOSE (catchError m (unwrapJOSE . handle))
+
+instance (MonadIO m) => MonadIO (JOSE e m) where
+  liftIO = JOSE . liftIO
+
+instance (MonadRandom m) => MonadRandom (JOSE e m) where
     getRandomBytes = lift . getRandomBytes

test/JWS.hs

@@ -22,7 +22,6 @@ import Data.Monoid ((<>))
 import Control.Lens hiding ((.=))
 import Control.Lens.Extras (is)
 import Control.Lens.Cons.Extras (recons)
-import Control.Monad.Except (runExceptT)
 import Data.Aeson
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Base64.URL as B64U
@@ -221,8 +220,7 @@ appendixA1Spec = describe "RFC 7515 A.1.  Example JWS using HMAC SHA-256" $ do
     fmap encodeCompact jws `shouldBe` Right compactJWS
 
   it "computes the HMAC correctly" $
-    fst (withDRG drg $
-      runExceptT (sign alg_ (k ^. jwkMaterial) (signingInput' ^. recons)))
+    fst (withDRG drg $ runJOSE $ (sign alg_ (k ^. jwkMaterial) (signingInput' ^. recons)))
       `shouldBe` (Right mac :: Either Error BS.ByteString)
 
   it "validates the JWS correctly" $
@@ -275,15 +273,15 @@ jwkRSA1024 = fromJust $ decode $
 appendixA2Spec :: Spec
 appendixA2Spec = describe "RFC 7515 A.2. Example JWS using RSASSA-PKCS-v1_5 SHA-256" $ do
   it "computes the signature correctly" $
-    fst (withDRG drg $ runExceptT (sign JWA.JWS.RS256 (k ^. jwkMaterial) signingInput'))
+    fst (withDRG drg $ runJOSE (sign JWA.JWS.RS256 (k ^. jwkMaterial) signingInput'))
       `shouldBe` (Right sig :: Either Error BS.ByteString)
 
   it "validates the signature correctly" $
     verify JWA.JWS.RS256 (k ^. jwkMaterial) signingInput' sig
       `shouldBe` (Right True :: Either Error Bool)
 
   it "prohibits signing with 1024-bit key" $
-    fst (withDRG drg (runExceptT $
+    fst (withDRG drg (runJOSE $
       signJWS signingInput' (Identity (newJWSHeader ((), JWA.JWS.RS256), jwkRSA1024))))
         `shouldBe` (Left KeySizeTooSmall :: Either Error (CompactJWS JWSHeader))
 
@@ -366,7 +364,7 @@ appendixA5Spec = describe "RFC 7515 A.5.  Example Unsecured JWS" $ do
     decodeCompact exampleJWS `shouldBe` jws
 
   where
-    jws = fst $ withDRG drg $ runExceptT $
+    jws = fst $ withDRG drg $ runJOSE $
       signJWS examplePayloadBytes (Identity (newJWSHeader ((), JWA.JWS.None), undefined))
       :: Either Error (CompactJWS JWSHeader)
     exampleJWS = "eyJhbGciOiJub25lIn0\
@@ -514,7 +512,7 @@ cfrgSpec = describe "RFC 8037 signature/validation test vectors" $ do
     sig = BS.pack sigOctets
     signingInput = "eyJhbGciOiJFZERTQSJ9.RXhhbXBsZSBvZiBFZDI1NTE5IHNpZ25pbmc"
   it "computes the correct signature" $
-    fst (withDRG drg $ runExceptT (sign JWA.JWS.EdDSA (view jwkMaterial k) signingInput))
+    fst (withDRG drg $ runJOSE (sign JWA.JWS.EdDSA (view jwkMaterial k) signingInput))
       `shouldBe` (Right sig :: Either Error BS.ByteString)
   it "validates signatures correctly" $
     verify JWA.JWS.EdDSA (view jwkMaterial k) signingInput sig

test/JWT.hs

@@ -22,7 +22,6 @@ import Data.Monoid ((<>))
 
 import Control.Lens
 import Control.Lens.Extras (is)
-import Control.Monad.Except (runExceptT)
 import Control.Monad.Trans (liftIO)
 import Control.Monad.Reader (runReaderT)
 import Data.Aeson hiding ((.=))
@@ -65,7 +64,7 @@ spec = do
 
     it "JWT compact round-trip" $ do
       k <- genJWK $ RSAGenParam 256
-      res <- runExceptT $ do
+      res <- runJOSE $ do
         token <- signClaims k (newJWSHeader ((), RS512)) emptyClaimsSet
         token' <- decodeCompact . encodeCompact $ token
         liftIO $ token' `shouldBe` token

test/Properties.hs

@@ -12,10 +12,12 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Properties where
 
 import Control.Applicative (liftA2)
-import Control.Monad.Except (ExceptT)
+import Control.Monad.IO.Class
 
 import Control.Lens ((&), set, view)
 import Crypto.Error (onCryptoFailure)
@@ -36,6 +38,10 @@ import Crypto.JOSE.Types
 import Crypto.JOSE.JWK
 import Crypto.JOSE.JWS
 
+
+instance (MonadIO m) => MonadRandom (PropertyT m) where
+  getRandomBytes = liftIO . getRandomBytes
+
 properties :: TestTree
 properties = testGroup "Properties"
   [ testProperty "SizedBase64Integer round-trip" (prop_roundTrip genSizedBase64Integer)
@@ -68,10 +74,10 @@ prop_rsaSignAndVerify = property $ do
   k <- evalIO $ genJWK (RSAGenParam keylen)
   alg_ <- forAll $ Gen.element [RS256, RS384, RS512, PS256, PS384, PS512]
   collect alg_
-  msg' <- evalExceptT
+  msg' <- evalExceptT $ unwrapJOSE
     ( signJWS msg [(newJWSHeader (Protected, alg_), k)]
       >>= verifyJWS defaultValidationSettings k
-      :: ExceptT Error (PropertyT IO) B.ByteString
+      :: JOSE Error (PropertyT IO) B.ByteString
     )
   msg' === msg
 
@@ -102,10 +108,10 @@ prop_bestJWSAlg = property $ do
     Left _ -> assert False
     Right alg_ -> do
       collect alg_
-      msg' <- evalExceptT
+      msg' <- evalExceptT $ unwrapJOSE
         ( signJWS msg [(newJWSHeader (Protected, alg_), k)]
           >>= verifyJWS defaultValidationSettings k
-          :: ExceptT Error (PropertyT IO) B.ByteString
+          :: JOSE Error (PropertyT IO) B.ByteString
         )
       msg' === msg