Code review and feature additions

.gitignore

@@ -1,4 +1,5 @@
-dist
+/dist
+/dist-newstyle
 .cabal-sandbox
 cabal.sandbox.config
 .stack-work

jose.cabal

@@ -54,36 +54,42 @@ library
     Crypto.JOSE.JWA.JWS
     Crypto.JOSE.JWA.JWE
     Crypto.JOSE.JWA.JWE.Alg
+    Crypto.JOSE.Types.WrappedURI
 
   other-modules:
     Crypto.JOSE.TH
     Crypto.JOSE.Types.Internal
-    Crypto.JOSE.Types.Orphans
+    Crypto.JOSE.Types.WrappedNonEmpty
 
   build-depends:
-    base >= 4.8 && < 5
-    , attoparsec
-    , base64-bytestring == 1.0.*
-    , concise >= 0.1
-    , containers >= 0.5
-    , cryptonite >= 0.7
-    , lens >= 4.16
-    , memory >= 0.7
-    , monad-time >= 0.1
-    , mtl >= 2
-    , semigroups >= 0.15
-    , template-haskell >= 2.4
-    , safe >= 0.3
-    , aeson >= 0.8.0.1
-    , unordered-containers == 0.2.*
-    , bytestring == 0.10.*
-    , text >= 1.1
-    , time >= 1.5
-    , network-uri >= 2.6
-    , QuickCheck >= 2
-    , quickcheck-instances
-    , x509 >= 1.4
-    , vector
+    aeson                >= 1.4.2 && < 1.5,
+    attoparsec           >= 0.13.2 && < 0.14,
+    base                 >= 4.8 && < 5,
+    base64-bytestring    == 1.0.*,
+    bytestring           == 0.10.*,
+    concise              >= 0.1 && < 0.2,
+    containers           >= 0.5 && < 0.7,
+    contravariant        >= 1.4 && < 1.5,
+    cryptonite           >= 0.7 && < 0.26,
+    exceptions           >= 0.10.0 && < 0.11,
+    lens                 >= 4.16 && < 4.18,
+    mtl                  >= 2 && < 2.3,
+    memory               >= 0.7 && < 0.15,
+    modern-uri           >= 0.3.0 && < 0.4,
+    monad-time           >= 0.1 && < 0.4,
+    network-uri          >= 2.6 && < 2.7,
+    QuickCheck           >= 2 && < 2.13,
+    quickcheck-instances >= 0.3 && < 0.4,
+    safe                 >= 0.3 && < 0.4,
+    semigroups           >= 0.15 && < 0.19,
+    semigroupoids        >= 5 && < 6,
+    template-haskell     >= 2.4 && < 2.15,
+    text                 >= 1.1 && < 1.3,
+    time                 >= 1.5 && < 1.10,
+    unordered-containers == 0.2.*,
+    vector               >= 0.12 && < 0.13,
+    waargonaut           >= 0.5 && < 0.6,
+    x509                 >= 1.4 && < 1.8
 
   ghc-options:    -Wall
   hs-source-dirs: src
@@ -103,6 +109,8 @@ test-suite tests
     JWT
     Properties
     Types
+    WrappedExceptT
+  ghc-options:    -Wall
 
   build-depends:
     base
@@ -135,6 +143,7 @@ test-suite tests
     , hspec
     , QuickCheck
     , quickcheck-instances
+    , modern-uri
 
 executable jose-example
   if !flag(demos)

src/Crypto/JOSE.hs

@@ -31,6 +31,5 @@ import Crypto.JOSE.Error
 import Crypto.JOSE.JWK
 import Crypto.JOSE.JWK.Store
 import Crypto.JOSE.JWS
-import Crypto.JOSE.Types (base64url)
 
 {-# ANN module ("HLint: ignore Use import/export shortcut" :: String) #-}

src/Crypto/JOSE/Error.hs

@@ -14,8 +14,6 @@
 
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 {-|
 
@@ -38,16 +36,13 @@ module Crypto.JOSE.Error
 import Data.Semigroup ((<>))
 import Numeric.Natural
 
-import Control.Monad.Trans (MonadTrans(..))
 import qualified Crypto.PubKey.RSA as RSA
 import Crypto.Error (CryptoError)
-import Crypto.Random (MonadRandom(..))
 import Control.Lens (Getter, to)
 import Control.Lens.TH (makeClassyPrisms, makePrisms)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding.Error as T
 
-
 -- | The wrong number of parts were found when decoding a
 -- compact JOSE object.
 --
@@ -117,12 +112,3 @@ data Error
   --   that matched the allowed algorithms
   deriving (Eq, Show)
 makeClassyPrisms ''Error
-
-
-instance (
-    MonadRandom m
-  , MonadTrans t
-  , Functor (t m)
-  , Monad (t m)
-  ) => MonadRandom (t m) where
-    getRandomBytes = lift . getRandomBytes

src/Crypto/JOSE/Header.hs

@@ -36,7 +36,13 @@ module Crypto.JOSE.Header
   , headerRequired
   , headerRequiredProtected
   , headerOptional
+  , headerOptional'
+  , headerOptionalNonEmpty
+  , headerOptionalURI
   , headerOptionalProtected
+  , headerOptionalProtected'
+  , headerOptionalProtectedNonEmpty
+  , headerOptionalProtectedURI
 
   -- * Parsing headers
   , parseParams
@@ -45,41 +51,25 @@ module Crypto.JOSE.Header
   -- * Encoding headers
   , protectedParamsEncoded
   , unprotectedParams
-
-
-  -- * Header fields shared by JWS and JWE
-  , HasAlg(..)
-  , HasJku(..)
-  , HasJwk(..)
-  , HasKid(..)
-  , HasX5u(..)
-  , HasX5c(..)
-  , HasX5t(..)
-  , HasX5tS256(..)
-  , HasTyp(..)
-  , HasCty(..)
-  , HasCrit(..)
   ) where
 
 
 import Data.List.NonEmpty (NonEmpty)
 import Data.Monoid ((<>))
 import Data.Proxy (Proxy(..))
 
-import Control.Lens (Lens', Getter, to)
+import Control.Lens (Lens', Getter, to, Getting, view, _Wrapped)
 import Data.Aeson (FromJSON(..), Object, Value, encode, object)
 import Data.Aeson.Types (Pair, Parser)
 import qualified Data.ByteString.Base64.URL.Lazy as B64UL
 import qualified Data.ByteString.Lazy as L
 import qualified Data.HashMap.Strict as M
 import qualified Data.Text as T
 
-import qualified Crypto.JOSE.JWA.JWS as JWA.JWS
-import Crypto.JOSE.JWK (JWK)
-import Crypto.JOSE.Types.Orphans ()
+import Crypto.JOSE.Types.WrappedURI(WrappedURI)
+import Crypto.JOSE.Types.WrappedNonEmpty(WrappedNonEmpty)
 import Crypto.JOSE.Types.Internal (unpad)
-import qualified Crypto.JOSE.Types as Types
-
+import Text.URI(URI)
 
 -- | A thing with parameters.
 --
@@ -235,6 +225,34 @@ headerOptional k hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of
     getUnprotected
   (Nothing, Nothing)  -> pure Nothing
 
+headerOptional'
+  :: (FromJSON a, ProtectionIndicator p)
+  => Getting b a b
+  -> T.Text
+  -> Maybe Object
+  -> Maybe Object
+  -> Parser (Maybe (HeaderParam p b))
+headerOptional' j k hp hu =
+  fmap (fmap (fmap (view j))) (headerOptional k hp hu)
+
+headerOptionalNonEmpty
+  :: (FromJSON a, ProtectionIndicator p)
+  => T.Text
+  -> Maybe Object
+  -> Maybe Object
+  -> Parser (Maybe (HeaderParam p (NonEmpty a)))
+headerOptionalNonEmpty =
+  headerOptional' (_Wrapped :: Getting (NonEmpty a) (WrappedNonEmpty a) (NonEmpty a))
+
+headerOptionalURI
+  :: ProtectionIndicator p
+  => T.Text
+  -> Maybe Object
+  -> Maybe Object
+  -> Parser (Maybe (HeaderParam p URI))
+headerOptionalURI =
+  headerOptional' (_Wrapped :: Getting URI WrappedURI URI)
+
 -- | Parse an optional parameter that, if present, MUST be carried
 -- in the protected header.
 --
@@ -250,6 +268,33 @@ headerOptionalProtected k hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of
   (Just v, _) -> Just <$> parseJSON v
   _           -> pure Nothing
 
+headerOptionalProtected'
+  :: FromJSON a
+  => Getting b a b
+  -> T.Text
+  -> Maybe Object
+  -> Maybe Object
+  -> Parser (Maybe b)
+headerOptionalProtected' j k hp hu =
+  fmap (fmap (view j)) (headerOptionalProtected k hp hu)
+
+headerOptionalProtectedNonEmpty
+  :: FromJSON a
+  => T.Text
+  -> Maybe Object
+  -> Maybe Object
+  -> Parser (Maybe (NonEmpty a))
+headerOptionalProtectedNonEmpty =
+  headerOptionalProtected' (_Wrapped :: Getting (NonEmpty a) (WrappedNonEmpty a) (NonEmpty a))
+
+headerOptionalProtectedURI
+  :: T.Text
+  -> Maybe Object
+  -> Maybe Object
+  -> Parser (Maybe URI)
+headerOptionalProtectedURI =
+  headerOptionalProtected' (_Wrapped :: Getting URI WrappedURI URI)
+
 -- | Parse a required parameter that may be carried in either
 -- the protected or the unprotected header.
 --
@@ -311,36 +356,3 @@ parseCrit
 parseCrit reserved exts o = mapM (mapM (critObjectParser reserved exts o))
   -- TODO fail on duplicate strings
 
-
-class HasAlg a where
-  alg :: Lens' (a p) (HeaderParam p JWA.JWS.Alg)
-
-class HasJku a where
-  jku :: Lens' (a p) (Maybe (HeaderParam p Types.URI))
-
-class HasJwk a where
-  jwk :: Lens' (a p) (Maybe (HeaderParam p JWK))
-
-class HasKid a where
-  kid :: Lens' (a p) (Maybe (HeaderParam p T.Text))
-
-class HasX5u a where
-  x5u :: Lens' (a p) (Maybe (HeaderParam p Types.URI))
-
-class HasX5c a where
-  x5c :: Lens' (a p) (Maybe (HeaderParam p (NonEmpty Types.SignedCertificate)))
-
-class HasX5t a where
-  x5t :: Lens' (a p) (Maybe (HeaderParam p Types.Base64SHA1))
-
-class HasX5tS256 a where
-  x5tS256 :: Lens' (a p) (Maybe (HeaderParam p Types.Base64SHA256))
-
-class HasTyp a where
-  typ :: Lens' (a p) (Maybe (HeaderParam p T.Text))
-
-class HasCty a where
-  cty :: Lens' (a p) (Maybe (HeaderParam p T.Text))
-
-class HasCrit a where
-  crit :: Lens' (a p) (Maybe (NonEmpty T.Text))

src/Crypto/JOSE/JWA/JWK.hs

@@ -107,8 +107,7 @@ import qualified Crypto.JOSE.JWA.JWS as JWA.JWS
 import qualified Crypto.JOSE.TH
 import qualified Crypto.JOSE.Types as Types
 import qualified Crypto.JOSE.Types.Internal as Types
-import Crypto.JOSE.Types.Orphans ()
-
+import Crypto.JOSE.Types.WrappedNonEmpty (parseNonEmpty, kvNonEmpty, gettingGenMaybeNonEmpty)
 
 -- | \"crv\" (Curve) Parameter
 --
@@ -159,7 +158,7 @@ instance FromJSON RSAPrivateKeyOptionalParameters where
     o .: "dp" <*>
     o .: "dq" <*>
     o .: "qi" <*>
-    o .:? "oth")
+    (o `parseNonEmpty` "oth"))
 
 instance ToJSON RSAPrivateKeyOptionalParameters where
   toJSON RSAPrivateKeyOptionalParameters{..} = object $ [
@@ -168,7 +167,7 @@ instance ToJSON RSAPrivateKeyOptionalParameters where
     , "dp" .= rsaDp
     , "dq" .= rsaDq
     , "qi" .= rsaQi
-    ] ++ maybe [] ((:[]) . ("oth" .=)) rsaOth
+    ] ++ maybe [] ((:[]) . ("oth" `kvNonEmpty`)) rsaOth
 
 instance Arbitrary RSAPrivateKeyOptionalParameters where
   arbitrary = RSAPrivateKeyOptionalParameters
@@ -177,7 +176,7 @@ instance Arbitrary RSAPrivateKeyOptionalParameters where
     <*> arbitrary
     <*> arbitrary
     <*> arbitrary
-    <*> arbitrary
+    <*> gettingGenMaybeNonEmpty
 
 
 -- | RSA private key parameters