jose 0.3.41.2 → 0.4.0.0

raw patch · 23 files changed

+1099/−358 lines, 23 filesdep +QuickCheckdep +cryptonitedep +memorydep −crypto-pubkeydep −crypto-pubkey-typesdep −crypto-randomdep ~aesonPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, cryptonite, memory, mtl, quickcheck-instances, tasty, tasty-hspec, tasty-quickcheck

Dependencies removed: crypto-pubkey, crypto-pubkey-types, crypto-random, cryptohash, ghc-prim, integer-gmp

Dependency ranges changed: aeson

API changes (from Hackage documentation)

Files

• README.md +3/−5
• jose.cabal +21/−14
• src/Crypto/JOSE.hs +1/−3
• src/Crypto/JOSE/AESKW.hs +123/−0
• src/Crypto/JOSE/Classes.hs +0/−61
• src/Crypto/JOSE/Error.hs +2/−0
• src/Crypto/JOSE/JWA/JWE.hs +128/−19
• src/Crypto/JOSE/JWA/JWE/Alg.hs +2/−2
• src/Crypto/JOSE/JWA/JWK.hs +222/−142
• src/Crypto/JOSE/JWE.hs +297/−0
• src/Crypto/JOSE/JWK.hs +26/−11
• src/Crypto/JOSE/JWS.hs +2/−0
• src/Crypto/JOSE/JWS/Internal.hs +19/−19
• src/Crypto/JOSE/Legacy.hs +18/−35
• src/Crypto/JOSE/Types.hs +49/−13
• src/Crypto/JOSE/Types/Internal.hs +4/−0
• src/Crypto/JOSE/Types/Orphans.hs +6/−0
• src/Crypto/JWT.hs +7/−8
• test/AESKW.hs +54/−0
• test/JWS.hs +13/−12
• test/Properties.hs +85/−0
• test/Test.hs +17/−7
• test/Types.hs +0/−7

@@ -5,10 +5,8 @@ Token](https://tools.ietf.org/html/rfc7519).  Encryption (JWE) is not supported but signing is supported.  All key-types and algorithms are supported, but EC and symmetric key-generation is not yet implemented.--EC signing is currently vulnerable to timing attacks therefore its-use is **strongly discouraged**.  (EC validation is safe).+types and algorithms are supported, however, EC signing is currently+vulnerable to timing attacks therefore its use is **strongly+discouraged** (EC validation is safe).  Contributions are welcome.

@@ -1,5 +1,5 @@ name:                jose-version:             0.3.41.2+version:             0.4.0.0 synopsis:   Javascript Object Signing and Encryption and JSON Web Token library description:@@ -28,7 +28,7 @@   README.md author:              Fraser Tweedale maintainer:          frase@frase.id.au-copyright:           Copyright (C) 2013, 2014, 2015  Fraser Tweedale+copyright:           Copyright (C) 2013, 2014, 2015, 2016  Fraser Tweedale category:            Cryptography build-type:          Simple cabal-version:       >= 1.8@@ -36,9 +36,9 @@ library   exposed-modules:     Crypto.JOSE-    Crypto.JOSE.Classes     Crypto.JOSE.Compact     Crypto.JOSE.Error+    Crypto.JOSE.JWE     Crypto.JOSE.JWK     Crypto.JOSE.JWS     Crypto.JOSE.Legacy@@ -46,6 +46,7 @@     Crypto.JWT    other-modules:+    Crypto.JOSE.AESKW     Crypto.JOSE.JWA.JWK     Crypto.JOSE.JWA.JWS     Crypto.JOSE.JWA.JWE@@ -58,27 +59,26 @@    build-depends:     base == 4.*-    , ghc-prim-    , integer-gmp     , attoparsec     , base64-bytestring == 1.0.*     , bifunctors >= 4.0     , byteable == 0.1.*-    , crypto-pubkey >= 0.2.3-    , crypto-pubkey-types >= 0.3.2-    , crypto-random >= 0.0.7 && < 0.0.9-    , cryptohash == 0.11.*+    , cryptonite >= 0.7     , data-default-class     , lens >= 4.3+    , memory >= 0.7+    , mtl >= 2     , template-haskell >= 2.4     , safe >= 0.3     , semigroups >= 0.15-    , aeson >= 0.8.0.1 && < 0.9+    , aeson >= 0.8.0.1 && < 0.10     , 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 @@ -94,9 +94,11 @@   hs-source-dirs: src, test   main-is:        Test.hs   other-modules:+    AESKW     JWK     JWS     JWT+    Properties     Types    build-depends:@@ -105,12 +107,11 @@     , base64-bytestring     , bifunctors     , byteable-    , crypto-pubkey-    , crypto-pubkey-types-    , crypto-random-    , cryptohash+    , cryptonite     , data-default-class     , lens+    , memory+    , mtl     , template-haskell     , safe     , semigroups@@ -122,4 +123,10 @@     , network-uri     , vector     , x509++    , tasty+    , tasty-hspec+    , tasty-quickcheck     , hspec+    , QuickCheck+    , quickcheck-instances

@@ -19,14 +19,12 @@ -} module Crypto.JOSE   (-    module Crypto.JOSE.Classes-  , module Crypto.JOSE.Compact+    module Crypto.JOSE.Compact   , module Crypto.JOSE.Error   , module Crypto.JOSE.JWK   , module Crypto.JOSE.JWS   ) where -import Crypto.JOSE.Classes import Crypto.JOSE.Compact import Crypto.JOSE.Error import Crypto.JOSE.JWK

@@ -0,0 +1,123 @@+-- Copyright (C) 2016  Fraser Tweedale+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++{-# LANGUAGE ScopedTypeVariables #-}++{- |++Advanced Encryption Standard (AES) Key Wrap Algorithm;+<https://https://tools.ietf.org/html/rfc3394>.++-}+module Crypto.JOSE.AESKW+  (+    aesKeyWrap+  , aesKeyUnwrap+  ) where++import Control.Monad.State+import Crypto.Cipher.Types+import Data.Bits (xor)+import Data.ByteArray as BA hiding (replicate, xor)+import Data.Memory.Endian (BE(..), toBE)+import Data.Memory.PtrMethods (memCopy)+import Data.Word (Word64)+import Foreign.Ptr (Ptr, plusPtr)+import Foreign.Storable (peek, peekElemOff, poke, pokeElemOff)+import System.IO.Unsafe (unsafePerformIO)++iv :: Word64+iv = 0xA6A6A6A6A6A6A6A6++aesKeyWrapStep+  :: BlockCipher128 cipher+  => cipher+  -> Ptr Word64   -- ^ register+  -> (Int, Int)   -- ^ step (t) and offset (i)+  -> StateT Word64 IO ()+aesKeyWrapStep cipher p (t, i) = do+  a <- get+  r_i <- lift $ peekElemOff p i+  m :: ScrubbedBytes <-+    lift $ alloc 16 $ \p' -> poke p' a >> pokeElemOff p' 1 r_i+  let b = ecbEncrypt cipher m+  b_hi <- lift $ withByteArray b peek+  b_lo <- lift $ withByteArray b (`peekElemOff` 1)+  put (b_hi `xor` unBE (toBE (fromIntegral t)))+  lift $ pokeElemOff p i b_lo++-- | Wrap a secret.+--+-- Input size must be a multiple of 8 bytes, and at least 16 bytes.+-- Output size is input size plus 8 bytes.+--+aesKeyWrap+  :: (ByteArrayAccess m, ByteArray c, BlockCipher128 cipher)+  => cipher+  -> m+  -> c+aesKeyWrap cipher m = unsafePerformIO $ do+  let n = BA.length m+  c <- withByteArray m $ \p ->+    alloc (n + 8) $ \p' ->+      memCopy (p' `plusPtr` 8) p n+  withByteArray c $ \p -> do+    let coords = zip [1..] (join (replicate 6 [1 .. n `div` 8]))+    a <- execStateT (mapM_ (aesKeyWrapStep cipher p) coords) iv+    poke p a+  return c++aesKeyUnwrapStep+  :: BlockCipher128 cipher+  => cipher+  -> Ptr Word64   -- ^ register+  -> (Int, Int)   -- ^ step (t) and offset (i)+  -> StateT Word64 IO ()+aesKeyUnwrapStep cipher p (t, i) = do+  a <- get+  r_i <- lift $ peekElemOff p i+  let a_t = a `xor` unBE (toBE (fromIntegral t))+  m :: ScrubbedBytes <-+    lift $ alloc 16 $ \p' -> poke p' a_t >> pokeElemOff p' 1 r_i+  let b = ecbDecrypt cipher m+  b_hi <- lift $ withByteArray b peek+  b_lo <- lift $ withByteArray b (`peekElemOff` 1)+  put b_hi+  lift $ pokeElemOff p i b_lo++-- | Unwrap a secret.+--+-- Input size must be a multiple of 8 bytes, and at least 24 bytes.+-- Output size is input size minus 8 bytes.+--+-- Returns 'Nothing' if inherent integrity check fails.  Otherwise,+-- the chance that the key data is corrupt is 2 ^ -64.+--+aesKeyUnwrap+  :: (ByteArrayAccess c, ByteArray m, BlockCipher128 cipher)+  => cipher+  -> c+  -> Maybe m+aesKeyUnwrap cipher c = unsafePerformIO $ do+  let n = BA.length c - 8+  m <- withByteArray c $ \p' ->+    alloc n $ \p ->+      memCopy p (p' `plusPtr` 8) n+  a <- withByteArray c $ \p' -> peek p'+  a' <- withByteArray m $ \p -> do+    let n' = n `div` 8+    let tMax = n' * 6+    let coords = zip [tMax,tMax-1..1] (cycle [n'-1,n'-2..0])+    execStateT (mapM_ (aesKeyUnwrapStep cipher p) coords) a+  return $ if a' == iv then Just m else Nothing

@@ -1,61 +0,0 @@--- Copyright (C) 2013, 2014  Fraser Tweedale------ Licensed under the Apache License, Version 2.0 (the "License");--- you may not use this file except in compliance with the License.--- You may obtain a copy of the License at------      http://www.apache.org/licenses/LICENSE-2.0------ Unless required by applicable law or agreed to in writing, software--- distributed under the License is distributed on an "AS IS" BASIS,--- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.--- See the License for the specific language governing permissions and--- limitations under the License.--{-# LANGUAGE TypeFamilies #-}--{-|--Type classes for use with the JOSE modules.---}-module Crypto.JOSE.Classes-  (-    module Crypto.Random-  , Key(..)-  ) where--import qualified Data.ByteString as B--import Crypto.Random--import qualified Crypto.JOSE.JWA.JWS as JWA.JWS-import Crypto.JOSE.Error---- | A Key that can sign messages and validate signatures according--- to a given 'Alg'.------ Can fail with 'AlgorithmMismatch'----class Key k where-  type KeyGenParam k-  type KeyContent k-  gen :: CPRG g => KeyGenParam k -> g -> (k, g)-  fromKeyContent :: KeyContent k -> k-  sign-    :: CPRG g-    => JWA.JWS.Alg-    -> k-    -> g-    -> B.ByteString-    -> (Either Error B.ByteString, g)-  verify-    :: JWA.JWS.Alg-    -> k-    -> B.ByteString-    -> B.ByteString-    -> Either Error Bool--  -- | Remove secrets from a key-  ---  public :: k -> Maybe k

@@ -23,6 +23,7 @@   ) where  import qualified Crypto.PubKey.RSA as RSA+import Crypto.Error (CryptoError)  -- | All the errors that can occur. --@@ -33,6 +34,7 @@   | KeySizeTooSmall           -- ^ Key size is too small   | OtherPrimesNotSupported   -- ^ RSA private key with >2 primes not supported   | RSAError RSA.Error        -- ^ RSA encryption, decryption or signing error+  | CryptoError CryptoError   -- ^ Various cryptonite library error cases   | CompactEncodeError String -- ^ Cannot produce compact representation of data   | CompactDecodeError String -- ^ Cannot decode compact representation   | JSONDecodeError String    -- ^ JSON (Aeson) decoding error

@@ -22,35 +22,144 @@ -} module Crypto.JOSE.JWA.JWE where +import Control.Applicative+import Data.Maybe (catMaybes)++import qualified Data.HashMap.Strict as M+ import Crypto.JOSE.JWK import Crypto.JOSE.TH import Crypto.JOSE.Types+import Crypto.JOSE.Types.Internal (objectPairs) +import Data.Aeson + -- -- JWA §4.  Cryptographic Algorithms for Encryption --+data AlgWithParams+  = RSA1_5+  | RSA_OAEP+  | RSA_OAEP_256+  | A128KW+  | A192KW+  | A256KW+  | Dir+  | ECDH_ES ECDHParameters+  | ECDH_ES_A128KW ECDHParameters+  | ECDH_ES_A192KW ECDHParameters+  | ECDH_ES_A256KW ECDHParameters+  | A128GCMKW AESGCMParameters+  | A192GCMKW AESGCMParameters+  | A256GCMKW AESGCMParameters+  | PBES2_HS256_A128KW PBES2Parameters+  | PBES2_HS384_A192KW PBES2Parameters+  | PBES2_HS512_A256KW PBES2Parameters+  deriving (Eq, Show) --- | JWA 4.1.  "alg" (Algorithms) Header Parameter Values for JWE+instance FromJSON AlgWithParams where+  parseJSON = withObject "Encryption alg and params" $ \o ->+    case M.lookup "alg" o of+      Nothing -> fail "\"alg\" parameter is required"+      Just "RSA1_5"             -> pure RSA1_5+      Just "RSA-OAEP"           -> pure RSA_OAEP+      Just "RSA-OAEP-256"       -> pure RSA_OAEP_256+      Just "A128KW"             -> pure A128KW+      Just "A192KW"             -> pure A192KW+      Just "A256KW"             -> pure A256KW+      Just "dir"                -> pure Dir+      Just "ECDH-ES"            -> ECDH_ES            <$> parseJSON (Object o)+      Just "ECDH-ES+A128KW"     -> ECDH_ES_A128KW     <$> parseJSON (Object o)+      Just "ECDH-ES+A192KW"     -> ECDH_ES_A192KW     <$> parseJSON (Object o)+      Just "ECDH-ES+A256KW"     -> ECDH_ES_A256KW     <$> parseJSON (Object o)+      Just "A128GCMKW"          -> A128GCMKW          <$> parseJSON (Object o)+      Just "A192GCMKW"          -> A192GCMKW          <$> parseJSON (Object o)+      Just "A256GCMKW"          -> A256GCMKW          <$> parseJSON (Object o)+      Just "PBES2-HS256+A128KW" -> PBES2_HS256_A128KW <$> parseJSON (Object o)+      Just "PBES2-HS384+A192KW" -> PBES2_HS384_A192KW <$> parseJSON (Object o)+      Just "PBES2-HS512+A256KW" -> PBES2_HS512_A256KW <$> parseJSON (Object o)+      _ -> fail $ "unrecognised value; expected: "+         ++ "[\"RSA1_5\",\"RSA-OAEP\",\"RSA-OAEP-256\",\"A128KW\",\"A192KW\",\"A256KW\",\"dir\",\"ECDH-ES\",\"ECDH-ES+A128KW\",\"ECDH-ES+A192KW\",\"ECDH-ES+A256KW\",\"A128GCMKW\",\"A192GCMKW\",\"A256GCMKW\",\"PBES2-HS256+A128KW\",\"PBES2-HS384+A128KW\",\"PBES2-HS512+A128KW\"]"++algObject :: Value -> Value+algObject s = object [("alg", s)]++algWithParamsObject :: ToJSON a => a -> Value -> Value+algWithParamsObject a s = object $ ("alg", s) : objectPairs (toJSON a)++instance ToJSON AlgWithParams where+  toJSON RSA1_5       = algObject "RSA1_5"+  toJSON RSA_OAEP     = algObject "RSA-OAEP"+  toJSON RSA_OAEP_256 = algObject "RSA-OAEP-256"+  toJSON A128KW       = algObject "A128KW"+  toJSON A192KW       = algObject "A192KW"+  toJSON A256KW       = algObject "A256KW"+  toJSON Dir          = algObject "Dir"+  toJSON (ECDH_ES params)             = algWithParamsObject params "ECDH-ES"+  toJSON (ECDH_ES_A128KW params)      = algWithParamsObject params "ECDH-ES+A128KW"+  toJSON (ECDH_ES_A192KW params)      = algWithParamsObject params "ECDH-ES+A192KW"+  toJSON (ECDH_ES_A256KW params)      = algWithParamsObject params "ECDH-ES+A256KW"+  toJSON (A128GCMKW params)           = algWithParamsObject params "A128GCMKW"+  toJSON (A192GCMKW params)           = algWithParamsObject params "A192GCMKW"+  toJSON (A256GCMKW params)           = algWithParamsObject params "A256GCMKW"+  toJSON (PBES2_HS256_A128KW params)  = algWithParamsObject params "PBES2-HS256+A128KW"+  toJSON (PBES2_HS384_A192KW params)  = algWithParamsObject params "PBES2-HS384+A192KW"+  toJSON (PBES2_HS512_A256KW params)  = algWithParamsObject params "PBES2-HS512+A256KW"+++-- | JWA §4.7.1.  Header Parameters Used for ECDH Key Agreement ---data JWEAlgHeaderParameters =-  -- JWA §4.7.1.  Header Parameters Used for ECDH Key Agreement-  ECDHParameters {-    epk :: JWK,   -- Ephemeral Public Key ; a JWK PUBLIC key-    apu :: Maybe Base64UrlString, -- Agreement PartyUInfo-    apv :: Maybe Base64UrlString  -- Agreement PartyVInfo-    }-  -- JWA §4.8.1.  Header Parameters Used for AES GCM Key Encryption-  | AESGCMParameters {-    iv :: Base64Octets, -- Initialization Vector-    tag :: Base64Octets -- Authentication Tag-    }-  -- JWA §4.9.1.  Header Parameters Used for PBES2 Key Encryption-  | PBES2Parameters {-    p2s :: Base64Octets,  -- PBKDF2 salt value-    p2c :: Int                  -- PBKDF2 iteration count ; POSITIVE integer-    }-  deriving (Show)+data ECDHParameters = ECDHParameters+  { _epk :: JWK                 -- ^ Ephemeral Public Key ; a JWK PUBLIC key+  , _apu :: Maybe Base64Octets  -- ^ Agreement PartyUInfo+  , _apv :: Maybe Base64Octets  -- ^ Agreement PartyVInfo+  } deriving (Eq, Show)++instance FromJSON ECDHParameters where+  parseJSON = withObject "ECDH Parameters" $ \o -> ECDHParameters+    <$> o .: "epk"+    <*> o .:? "apu"+    <*> o .:? "apv"++instance ToJSON ECDHParameters where+  toJSON (ECDHParameters epk apu apv) = object $ catMaybes+    [ Just ("epk" .= epk)+    , fmap ("apu" .=) apu+    , fmap ("apu" .=) apv+    ]+++-- | JWA §4.8.1.  Header Parameters Used for AES GCM Key Encryption+--+data AESGCMParameters = AESGCMParameters+  { _iv :: Base64Octets  -- ^ Initialization Vector  (must be 96 bits?)+  , _tag :: Base64Octets -- ^ Authentication Tag (must be 128 bits?)+  } deriving (Eq, Show)++instance FromJSON AESGCMParameters where+  parseJSON = withObject "AES-GCM Parameters" $ \o -> AESGCMParameters+    <$> o .: "iv"+    <*> o .: "tag"++instance ToJSON AESGCMParameters where+  toJSON (AESGCMParameters iv tag) = object ["iv" .= iv, "tag" .= tag]+++-- | JWA §4.9.1.  Header Parameters Used for PBES2 Key Encryption+--+data PBES2Parameters =  PBES2Parameters+  { _p2s :: Base64Octets   -- ^ PBKDF2 salt input+  , _p2c :: Int            -- ^ PBKDF2 iteration count ; POSITIVE integer+  } deriving (Eq, Show)++instance FromJSON PBES2Parameters where+  parseJSON = withObject "AES-GCM Parameters" $ \o -> PBES2Parameters+    <$> o .: "p2s"  -- TODO salt input value must be >= 8 octets+    <*> o .: "p2c"++instance ToJSON PBES2Parameters where+  toJSON (PBES2Parameters p2s p2c) = object ["p2s" .= p2s, "p2c" .= p2c]   -- | JWA §4.2.  "enc" (Encryption Method) Header Parameters Values for JWE

@@ -47,6 +47,6 @@   , "A192GCMKW"           -- AES in Galois/Counter Mode             Optional   , "A256GCMKW"           -- AES in Galois/Counter Mode             Optional   , "PBES2-HS256+A128KW"  -- PBES2 with HMAC SHA and AES Key Wrap   Optional-  , "PBES2-HS384+A128KW"  -- PBES2 with HMAC SHA and AES Key Wrap   Optional-  , "PBES2-HS512+A128KW"  -- PBES2 with HMAC SHA and AES Key Wrap   Optional+  , "PBES2-HS384+A192KW"  -- PBES2 with HMAC SHA and AES Key Wrap   Optional+  , "PBES2-HS512+A256KW"  -- PBES2 with HMAC SHA and AES Key Wrap   Optional   ])

@@ -1,4 +1,4 @@--- Copyright (C) 2013, 2014  Fraser Tweedale+-- Copyright (C) 2013, 2014, 2015, 2016  Fraser Tweedale -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -12,8 +12,10 @@ -- See the License for the specific language governing permissions and -- limitations under the License. +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}@@ -24,12 +26,16 @@  -} module Crypto.JOSE.JWA.JWK (+  -- * Type classes+    AsPublicKey(..)+   -- * \"kty\" (Key Type) Parameter Values-    EC(..)+  , EC(..)   , RSA(..)   , Oct(..)    -- * Parameters for Elliptic Curve Keys+  , Crv(..)   , ECKeyParameters(..)    -- * Parameters for RSA Keys@@ -41,12 +47,19 @@   , rsaKty   , rsaN   , rsaPrivateKeyParameters+  , rsaPublicKey+  , genRSA    -- * Parameters for Symmetric Keys   , OctKeyParameters(..)    , KeyMaterialGenParam(..)   , KeyMaterial(..)+  , genKeyMaterial+  , sign+  , verify++  , module Crypto.Random   ) where  import Control.Applicative@@ -55,25 +68,27 @@  import Control.Lens hiding ((.=)) import Crypto.Hash-import Crypto.PubKey.HashDescr+import Crypto.MAC.HMAC import qualified Crypto.PubKey.ECC.ECDSA as ECDSA+import qualified Crypto.PubKey.ECC.Generate as ECC import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.RSA.PKCS15 as PKCS15 import qualified Crypto.PubKey.RSA.PSS as PSS-import qualified Crypto.Types.PubKey.ECC as ECC+import qualified Crypto.PubKey.ECC.Types as ECC import Crypto.Random import Data.Aeson-import Data.Byteable+import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.HashMap.Strict as M import Data.List.NonEmpty+import Test.QuickCheck  import Crypto.JOSE.Error-import Crypto.JOSE.Classes 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 ()   -- | Elliptic Curve key type (Recommeded+)@@ -88,7 +103,10 @@ -- $(Crypto.JOSE.TH.deriveJOSEType "Crv" ["P-256", "P-384", "P-521"]) +instance Arbitrary Crv where+  arbitrary = oneof $ pure <$> [P_256, P_384, P_521] + -- | \"oth\" (Other Primes Info) Parameter -- data RSAPrivateKeyOthElem = RSAPrivateKeyOthElem {@@ -107,7 +125,10 @@ instance ToJSON RSAPrivateKeyOthElem where   toJSON (RSAPrivateKeyOthElem r d t) = object ["r" .= r, "d" .= d, "t" .= t] +instance Arbitrary RSAPrivateKeyOthElem where+  arbitrary = RSAPrivateKeyOthElem <$> arbitrary <*> arbitrary <*> arbitrary + -- | Optional parameters for RSA private keys -- data RSAPrivateKeyOptionalParameters = RSAPrivateKeyOptionalParameters {@@ -138,7 +159,16 @@     , "qi" .= rsaQi     ] ++ maybe [] ((:[]) . ("oth" .=)) rsaOth +instance Arbitrary RSAPrivateKeyOptionalParameters where+  arbitrary = RSAPrivateKeyOptionalParameters+    <$> arbitrary+    <*> arbitrary+    <*> arbitrary+    <*> arbitrary+    <*> arbitrary+    <*> arbitrary + -- | RSA private key parameters -- data RSAPrivateKeyParameters = RSAPrivateKeyParameters@@ -159,7 +189,10 @@   toJSON RSAPrivateKeyParameters {..} = object $     ("d" .= rsaD) : maybe [] (Types.objectPairs . toJSON) rsaOptionalParameters +instance Arbitrary RSAPrivateKeyParameters where+  arbitrary = RSAPrivateKeyParameters <$> arbitrary <*> arbitrary + -- | Parameters for Elliptic Curve Keys -- data ECKeyParameters = ECKeyParameters@@ -173,71 +206,69 @@   deriving (Eq, Show)  instance FromJSON ECKeyParameters where-  parseJSON = withObject "EC" $ \o -> ECKeyParameters-    <$> o .: "kty"-    <*> o .: "crv"-    <*> o .: "x"-    <*> o .: "y"-    <*> o .:? "d"+  parseJSON = withObject "EC" $ \o -> do+    crv <- o .: "crv"+    ECKeyParameters+      <$> o .: "kty"+      <*> pure crv+      <*> (o .: "x" >>= Types.checkSize (ecCoordBytes crv))+      <*> (o .: "y" >>= Types.checkSize (ecCoordBytes crv))+      <*> (o .:? "d" >>= \case+        Nothing -> return Nothing+        Just v -> Just <$> Types.checkSize (ecDBytes crv) v)  instance ToJSON ECKeyParameters where   toJSON (ECKeyParameters {..}) = object $-    [ "crv" .= ecCrv+    [ "kty" .= ecKty+    , "crv" .= ecCrv     , "x" .= ecX     , "y" .= ecY     ] ++ fmap ("d" .=) (maybeToList ecD) -instance Key ECKeyParameters where-  type KeyGenParam ECKeyParameters = Crv-  type KeyContent ECKeyParameters = ECKeyParameters-  gen = undefined  -- TODO implement-  fromKeyContent = id-  sign JWA.JWS.ES256 k@(ECKeyParameters { ecCrv = P_256 }) =-    signEC hashDescrSHA256 k-  sign JWA.JWS.ES384 k@(ECKeyParameters { ecCrv = P_384 }) =-    signEC hashDescrSHA384 k-  sign JWA.JWS.ES512 k@(ECKeyParameters { ecCrv = P_521 }) =-    signEC hashDescrSHA512 k-  sign h _ = \g _ ->-    (Left $ AlgorithmMismatch  $ show h ++ "cannot be used with EC key", g)-  verify JWA.JWS.ES256 = verifyEC hashDescrSHA256-  verify JWA.JWS.ES384 = verifyEC hashDescrSHA384-  verify JWA.JWS.ES512 = verifyEC hashDescrSHA512-  verify h = \_ _ _ ->-    Left $ AlgorithmMismatch  $ show h ++ "cannot be used with EC key"-  public k = Just k { ecD = Nothing }+instance Arbitrary ECKeyParameters where+  arbitrary = do+    crv <- arbitrary+    let w = ecCoordBytes crv+    ECKeyParameters EC crv+      <$> Types.genSizedBase64IntegerOf w+      <*> Types.genSizedBase64IntegerOf w+      <*> oneof+        [ pure Nothing+        , Just <$> Types.genSizedBase64IntegerOf (ecDBytes crv)+        ]  signEC-  :: CPRG g-  => HashDescr+  :: (BA.ByteArrayAccess msg, HashAlgorithm h, MonadRandom m)+  => h   -> ECKeyParameters-  -> g-  -> B.ByteString-  -> (Either Error B.ByteString, g)-signEC h k@(ECKeyParameters {..}) g m = case ecD of-  Just ecD' -> first (Right . sigToBS) sig where-    sig = ECDSA.sign g privateKey (hashFunction h) m+  -> msg+  -> m (Either Error B.ByteString)+signEC h (ECKeyParameters {..}) m = case ecD of+  Just ecD' -> Right . sigToBS <$> sig where+    w = ecCoordBytes ecCrv+    sig = ECDSA.sign privateKey h m     sigToBS (ECDSA.Signature r s) =-      Types.integerToBS r `B.append` Types.integerToBS s-    privateKey = ECDSA.PrivateKey (curve k) (d ecD')+      Types.sizedIntegerToBS w r `B.append` Types.sizedIntegerToBS w s+    privateKey = ECDSA.PrivateKey (curve ecCrv) (d ecD')     d (Types.SizedBase64Integer _ n) = n-  Nothing -> (Left $ KeyMismatch "not an EC private key", g)+  Nothing -> return (Left $ KeyMismatch "not an EC private key")  verifyEC-  :: HashDescr+  :: (BA.ByteArrayAccess msg, HashAlgorithm h)+  => h   -> ECKeyParameters-  -> B.ByteString+  -> msg   -> B.ByteString   -> Either Error Bool-verifyEC h k m s = Right $ ECDSA.verify (hashFunction h) pubkey sig m+verifyEC h k m s = Right $ ECDSA.verify h pubkey sig m   where-  pubkey = ECDSA.PublicKey (curve k) (point k)+  pubkey = ECDSA.PublicKey (curve $ ecCrv k) (point k)   sig = uncurry ECDSA.Signature     $ bimap Types.bsToInteger Types.bsToInteger     $ B.splitAt (B.length s `div` 2) s -curve :: ECKeyParameters -> ECC.Curve-curve ECKeyParameters {..} = ECC.getCurveByName (curveName ecCrv) where+curve :: Crv -> ECC.Curve+curve = ECC.getCurveByName . curveName where   curveName P_256 = ECC.SEC_p256r1   curveName P_384 = ECC.SEC_p384r1   curveName P_521 = ECC.SEC_p521r1@@ -246,7 +277,16 @@ point ECKeyParameters {..} = ECC.Point (integer ecX) (integer ecY) where   integer (Types.SizedBase64Integer _ n) = n +ecCoordBytes :: Integral a => Crv -> a+ecCoordBytes P_256 = 32+ecCoordBytes P_384 = 48+ecCoordBytes P_521 = 66 +ecDBytes :: Integral a => Crv -> a+ecDBytes crv = ceiling (logBase 2 (fromIntegral order) / 8 :: Double) where+  order = ECC.ecc_n $ ECC.common_curve $ curve crv++ -- | Parameters for RSA Keys -- data RSAKeyParameters = RSAKeyParameters@@ -275,85 +315,61 @@     : ("e" .= _rsaE)     : maybe [] (Types.objectPairs . toJSON) _rsaPrivateKeyParameters -instance Key RSAKeyParameters where-  type KeyGenParam RSAKeyParameters = Int-  type KeyContent RSAKeyParameters =-    ( Types.SizedBase64Integer-    , Types.Base64Integer-    , Maybe RSAPrivateKeyParameters-    )-  gen size g =-    let-      i = Types.Base64Integer-      ((RSA.PublicKey s n e, RSA.PrivateKey _ d p q dp dq qi), g') =-        RSA.generate g size 65537-    in-      ( fromKeyContent-        ( Types.SizedBase64Integer s n-        , i e-        , Just (RSAPrivateKeyParameters (i d)-          (Just (RSAPrivateKeyOptionalParameters-            (i p) (i q) (i dp) (i dq) (i qi) Nothing))))-      , g')-  fromKeyContent (n, e, p) = RSAKeyParameters RSA n e p-  public = Just . set rsaPrivateKeyParameters Nothing-  sign JWA.JWS.RS256 = signPKCS15 hashDescrSHA256-  sign JWA.JWS.RS384 = signPKCS15 hashDescrSHA384-  sign JWA.JWS.RS512 = signPKCS15 hashDescrSHA512-  sign JWA.JWS.PS256 = signPSS hashDescrSHA256-  sign JWA.JWS.PS384 = signPSS hashDescrSHA384-  sign JWA.JWS.PS512 = signPSS hashDescrSHA512-  sign h = \_ g -> const-    (Left $ AlgorithmMismatch  $ show h ++ "cannot be used with RSA key", g)-  verify JWA.JWS.RS256 = verifyPKCS15 hashDescrSHA256-  verify JWA.JWS.RS384 = verifyPKCS15 hashDescrSHA384-  verify JWA.JWS.RS512 = verifyPKCS15 hashDescrSHA512-  verify JWA.JWS.PS256 = verifyPSS hashDescrSHA256-  verify JWA.JWS.PS384 = verifyPSS hashDescrSHA384-  verify JWA.JWS.PS512 = verifyPSS hashDescrSHA512-  verify h = \_ _ _ ->-    Left $ AlgorithmMismatch  $ show h ++ "cannot be used with RSA key"+instance Arbitrary RSAKeyParameters where+  arbitrary = RSAKeyParameters RSA+    <$> arbitrary+    <*> arbitrary+    <*> arbitrary +genRSA :: MonadRandom m => Int -> m RSAKeyParameters+genRSA size = do+  (RSA.PublicKey s n e, RSA.PrivateKey _ d p q dp dq qi) <- RSA.generate size 65537+  let i = Types.Base64Integer+  return $ RSAKeyParameters RSA+    ( Types.SizedBase64Integer s n )+    ( i e )+    ( Just (RSAPrivateKeyParameters (i d)+      (Just (RSAPrivateKeyOptionalParameters+        (i p) (i q) (i dp) (i dq) (i qi) Nothing))) )+ signPKCS15-  :: CPRG g-  => HashDescr+  :: (PKCS15.HashAlgorithmASN1 h, MonadRandom m)+  => h   -> RSAKeyParameters-  -> g   -> B.ByteString-  -> (Either Error B.ByteString, g)-signPKCS15 h k g m = case rsaPrivateKey k of-  Left e -> (Left e, g)-  Right k' -> first (first RSAError) $-    PKCS15.signSafer g h k' m+  -> m (Either Error B.ByteString)+signPKCS15 h k m = case rsaPrivateKey k of+  Left e -> return (Left e)+  Right k' -> first RSAError <$> PKCS15.signSafer (Just h) k' m  verifyPKCS15-  :: HashDescr+  :: PKCS15.HashAlgorithmASN1 h+  => h   -> RSAKeyParameters   -> B.ByteString   -> B.ByteString   -> Either Error Bool-verifyPKCS15 h k m = Right . PKCS15.verify h (rsaPublicKey k) m+verifyPKCS15 h k m = Right . PKCS15.verify (Just h) (rsaPublicKey k) m  signPSS-  :: CPRG g-  => HashDescr+  :: (HashAlgorithm h, MonadRandom m)+  => h   -> RSAKeyParameters-  -> g   -> B.ByteString-  -> (Either Error B.ByteString, g)-signPSS h k g m = case rsaPrivateKey k of-  Left e -> (Left e, g)-  Right k' -> first (first RSAError) $-   PSS.signSafer g (PSS.defaultPSSParams (hashFunction h)) k' m+  -> m (Either Error B.ByteString)+signPSS h k m = case rsaPrivateKey k of+  Left e -> return (Left e)+  Right k' -> first RSAError <$> PSS.signSafer (PSS.defaultPSSParams h) k' m  verifyPSS-  :: HashDescr+  :: (HashAlgorithm h)+  => h   -> RSAKeyParameters   -> B.ByteString   -> B.ByteString   -> Either Error Bool verifyPSS h k m = Right .-  PSS.verify (PSS.defaultPSSParams (hashFunction h)) (rsaPublicKey k) m+  PSS.verify (PSS.defaultPSSParams h) (rsaPublicKey k) m  rsaPrivateKey :: RSAKeyParameters -> Either Error RSA.PrivateKey rsaPrivateKey (RSAKeyParameters _@@ -392,27 +408,19 @@ instance ToJSON OctKeyParameters where   toJSON OctKeyParameters {..} = object ["kty" .= octKty, "k" .= octK] -instance Key OctKeyParameters where-  type KeyGenParam OctKeyParameters = Int-  type KeyContent OctKeyParameters = Types.Base64Octets-  gen = undefined  -- TODO implement-  fromKeyContent = OctKeyParameters Oct-  public = const Nothing-  sign JWA.JWS.HS256 k g = first Right . (,g) . signOct SHA256 k-  sign JWA.JWS.HS384 k g = first Right . (,g) . signOct SHA384 k-  sign JWA.JWS.HS512 k g = first Right . (,g) . signOct SHA512 k-  sign h _ g = const-    (Left $ AlgorithmMismatch $ show h ++ "cannot be used with Oct key", g)-  verify h k m s = fst (sign h k (undefined :: SystemRNG) m) >>= Right . (constEqBytes s)+instance Arbitrary OctKeyParameters where+  arbitrary = OctKeyParameters Oct <$> arbitrary  signOct-  :: HashAlgorithm a-  => a+  :: forall h. HashAlgorithm h+  => h   -> OctKeyParameters   -> B.ByteString-  -> B.ByteString-signOct a (OctKeyParameters _ (Types.Base64Octets k)) m-  = toBytes $ hmacAlg a k m+  -> Either Error B.ByteString+signOct h (OctKeyParameters _ (Types.Base64Octets k)) m =+  if B.length k < hashDigestSize h+  then Left KeySizeTooSmall+  else Right $ B.pack $ BA.unpack (hmac k m :: HMAC h)   -- | Key material sum type.@@ -423,6 +431,11 @@   | OctKeyMaterial OctKeyParameters   deriving (Eq, Show) +showKeyType :: KeyMaterial -> String+showKeyType (ECKeyMaterial (ECKeyParameters { ecCrv = crv })) = "ECDSA (" ++ show crv ++ ")"+showKeyType (RSAKeyMaterial _) = "RSA"+showKeyType (OctKeyMaterial _) = "symmetric"+ instance FromJSON KeyMaterial where   parseJSON = withObject "KeyMaterial" $ \o ->     ECKeyMaterial      <$> parseJSON (Object o)@@ -441,21 +454,88 @@   | RSAGenParam Int   | OctGenParam Int -instance Key KeyMaterial where-  type KeyGenParam KeyMaterial = KeyMaterialGenParam-  type KeyContent KeyMaterial = KeyMaterial-  gen (ECGenParam a) = first ECKeyMaterial . gen a-  gen (RSAGenParam a) = first RSAKeyMaterial . gen a-  gen (OctGenParam a) = first OctKeyMaterial . gen a-  fromKeyContent = id-  public (ECKeyMaterial k) = ECKeyMaterial <$> public k-  public (RSAKeyMaterial k) = RSAKeyMaterial <$> public k-  public (OctKeyMaterial k) = OctKeyMaterial <$> public k-  sign JWA.JWS.None _ = \g _ -> (Right "", g)-  sign h (ECKeyMaterial k)  = sign h k-  sign h (RSAKeyMaterial k) = sign h k-  sign h (OctKeyMaterial k) = sign h k-  verify JWA.JWS.None _ = \_ s -> Right $ s == ""-  verify h (ECKeyMaterial k)  = verify h k-  verify h (RSAKeyMaterial k) = verify h k-  verify h (OctKeyMaterial k) = verify h k+genKeyMaterial :: MonadRandom m => KeyMaterialGenParam -> m KeyMaterial+genKeyMaterial (ECGenParam crv) = do+  let+    xyValue = Types.SizedBase64Integer (ecCoordBytes crv)+    dValue = Types.SizedBase64Integer (ecDBytes crv)+  (ECDSA.PublicKey _ p, ECDSA.PrivateKey _ d) <- ECC.generate (curve crv)+  case p of+    ECC.Point x y -> return $ ECKeyMaterial $+      ECKeyParameters EC crv (xyValue x) (xyValue y) (Just (dValue d))+    ECC.PointO -> genKeyMaterial (ECGenParam crv)  -- JWK cannot represent point at infinity; recurse+genKeyMaterial (RSAGenParam size) = RSAKeyMaterial <$> genRSA size+genKeyMaterial (OctGenParam n) =+  OctKeyMaterial . OctKeyParameters Oct . Types.Base64Octets <$> getRandomBytes n++sign+  :: MonadRandom m+  => JWA.JWS.Alg+  -> KeyMaterial+  -> B.ByteString+  -> m (Either Error B.ByteString)+sign JWA.JWS.None _ = \_ -> return $ Right ""+sign JWA.JWS.ES256 (ECKeyMaterial k@(ECKeyParameters { ecCrv = P_256 })) = signEC SHA256 k+sign JWA.JWS.ES384 (ECKeyMaterial k@(ECKeyParameters { ecCrv = P_384 })) = signEC SHA384 k+sign JWA.JWS.ES512 (ECKeyMaterial k@(ECKeyParameters { ecCrv = P_521 })) = signEC SHA512 k+sign JWA.JWS.RS256 (RSAKeyMaterial k) = signPKCS15 SHA256 k+sign JWA.JWS.RS384 (RSAKeyMaterial k) = signPKCS15 SHA384 k+sign JWA.JWS.RS512 (RSAKeyMaterial k) = signPKCS15 SHA512 k+sign JWA.JWS.PS256 (RSAKeyMaterial k) = signPSS SHA256 k+sign JWA.JWS.PS384 (RSAKeyMaterial k) = signPSS SHA384 k+sign JWA.JWS.PS512 (RSAKeyMaterial k) = signPSS SHA512 k+sign JWA.JWS.HS256 (OctKeyMaterial k) = return . signOct SHA256 k+sign JWA.JWS.HS384 (OctKeyMaterial k) = return . signOct SHA384 k+sign JWA.JWS.HS512 (OctKeyMaterial k) = return . signOct SHA512 k+sign h k = \_ -> return $ Left $ AlgorithmMismatch+  $ show h ++ "cannot be used with " ++ showKeyType k ++ " key"++verify+  :: JWA.JWS.Alg+  -> KeyMaterial+  -> B.ByteString+  -> B.ByteString+  -> Either Error Bool+verify JWA.JWS.None _ = \_ s -> Right $ s == ""+verify JWA.JWS.ES256 (ECKeyMaterial k) = verifyEC SHA256 k+verify JWA.JWS.ES384 (ECKeyMaterial k) = verifyEC SHA384 k+verify JWA.JWS.ES512 (ECKeyMaterial k) = verifyEC SHA512 k+verify JWA.JWS.RS256 (RSAKeyMaterial k) = verifyPKCS15 SHA256 k+verify JWA.JWS.RS384 (RSAKeyMaterial k) = verifyPKCS15 SHA384 k+verify JWA.JWS.RS512 (RSAKeyMaterial k) = verifyPKCS15 SHA512 k+verify JWA.JWS.PS256 (RSAKeyMaterial k) = verifyPSS SHA256 k+verify JWA.JWS.PS384 (RSAKeyMaterial k) = verifyPSS SHA384 k+verify JWA.JWS.PS512 (RSAKeyMaterial k) = verifyPSS SHA512 k+verify JWA.JWS.HS256 (OctKeyMaterial k) = \m s -> BA.constEq s <$> signOct SHA256 k m+verify JWA.JWS.HS384 (OctKeyMaterial k) = \m s -> BA.constEq s <$> signOct SHA384 k m+verify JWA.JWS.HS512 (OctKeyMaterial k) = \m s -> BA.constEq s <$> signOct SHA512 k m+verify h k = \_ -> return $ Left $ AlgorithmMismatch+  $ show h ++ "cannot be used with " ++ showKeyType k ++ " key"++instance Arbitrary KeyMaterial where+  arbitrary = oneof+    [ ECKeyMaterial <$> arbitrary+    , RSAKeyMaterial <$> arbitrary+    , OctKeyMaterial <$> arbitrary+    ]+++class AsPublicKey k where+  asPublicKey :: Prism' k k+++instance AsPublicKey OctKeyParameters where+  asPublicKey = prism' id (const Nothing)++instance AsPublicKey RSAKeyParameters where+  asPublicKey = prism' id (Just . set rsaPrivateKeyParameters Nothing)++instance AsPublicKey ECKeyParameters where+  asPublicKey = prism' id (\k -> Just k { ecD = Nothing })++instance AsPublicKey KeyMaterial where+  asPublicKey = prism' id (\x -> case x of+    OctKeyMaterial k  -> OctKeyMaterial  <$> k ^? asPublicKey+    RSAKeyMaterial k  -> RSAKeyMaterial  <$> k ^? asPublicKey+    ECKeyMaterial k   -> ECKeyMaterial   <$> k ^? asPublicKey+    )

@@ -0,0 +1,297 @@+-- Copyright (C) 2015, 2016  Fraser Tweedale+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module Crypto.JOSE.JWE+  (+    JWEHeader(..)++  , JWE(..)+  ) where++import Prelude hiding (mapM)+import Control.Applicative+import Data.Bifunctor (first, bimap)+import Data.Maybe (catMaybes)+import Data.Traversable (mapM)++import Data.Aeson+import Data.Aeson.Types+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Base64.URL as B64U+import qualified Data.ByteString.Base64.URL.Lazy as B64UL+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.List.NonEmpty (NonEmpty(..), toList)++import Crypto.Cipher.AES+import Crypto.Cipher.Types+import Crypto.Data.Padding+import Crypto.Error+import Crypto.Hash+import Crypto.MAC.HMAC+import Crypto.PubKey.MaskGenFunction+import qualified Crypto.PubKey.RSA.OAEP as OAEP++import Crypto.JOSE.AESKW+import Crypto.JOSE.Error+import Crypto.JOSE.JWA.JWE+import Crypto.JOSE.JWK+import qualified Crypto.JOSE.Types as Types+import qualified Crypto.JOSE.Types.Internal as Types+import Crypto.JOSE.Types.Armour+++critInvalidNames :: [T.Text]+critInvalidNames =+  [ "alg" , "enc" , "zip" , "jku" , "jwk" , "kid"+  , "x5u" , "x5c" , "x5t" , "x5t#S256" , "typ" , "cty" , "crit" ]++newtype CritParameters = CritParameters (NonEmpty (T.Text, Value))+  deriving (Eq, Show)++critObjectParser :: Object -> T.Text -> Parser (T.Text, Value)+critObjectParser o s+  | s `elem` critInvalidNames = fail "crit key is reserved"+  | otherwise                 = (\v -> (s, v)) <$> o .: s++parseCrit :: Object -> NonEmpty T.Text -> Parser CritParameters+parseCrit o = fmap CritParameters . mapM (critObjectParser o)+  -- TODO fail on duplicate strings++instance FromJSON CritParameters where+  parseJSON = withObject "crit" $ \o -> o .: "crit" >>= parseCrit o++instance ToJSON CritParameters where+  toJSON (CritParameters m) = object $ ("crit", toJSON $ fmap fst m) : toList m+++data JWEHeader = JWEHeader+  { _jweAlg :: Maybe AlgWithParams+  , _jweEnc :: Maybe Enc+  , _jweZip :: Maybe String  -- protected header only  "DEF" (DEFLATE) defined+  , _jweJku :: Maybe Types.URI+  , _jweJwk :: Maybe JWK+  , _jweKid :: Maybe String+  , _jweX5u :: Maybe Types.URI+  , _jweX5c :: Maybe (NonEmpty Types.Base64X509)+  , _jweX5t :: Maybe Types.Base64SHA1+  , _jweX5tS256 :: Maybe Types.Base64SHA256+  , _jweTyp :: Maybe String  -- ^ Content Type (of object)+  , _jweCty :: Maybe String  -- ^ Content Type (of payload)+  , _jweCrit :: Maybe CritParameters+  }+  deriving (Eq, Show)++newJWEHeader :: AlgWithParams -> JWEHeader+newJWEHeader alg = JWEHeader (Just alg) z z z z z z z z z z z z where z = Nothing+++instance FromJSON JWEHeader where+  parseJSON = withObject "JWE" $ \o -> JWEHeader+    <$> parseJSON (Object o)+    <*> o .: "enc"+    <*> o .:? "zip"+    <*> o .:? "jku"+    <*> o .:? "jwk"+    <*> o .:? "kid"+    <*> o .:? "x5u"+    <*> o .:? "x5c"+    <*> o .:? "x5t"+    <*> o .:? "x5t#S256"+    <*> o .:? "typ"+    <*> o .:? "cty"+    <*> (o .:? "crit" >>= mapM (parseCrit o))  -- TODO++instance ToJSON JWEHeader where+  toJSON (JWEHeader alg enc _zip jku jwk kid x5u x5c x5t x5tS256 typ cty crit) =+    object $ catMaybes+      [ fmap ("enc" .=) enc+      , fmap ("zip" .=) _zip+      , fmap ("jku" .=) jku+      , fmap ("jwk" .=) jwk+      , fmap ("kid" .=) kid+      , fmap ("x5u" .=) x5u+      , fmap ("x5c" .=) x5c+      , fmap ("x5t" .=) x5t+      , fmap ("x5t#S256" .=) x5tS256+      , fmap ("typ" .=) typ+      , fmap ("cty" .=) cty+      ]+      ++ Types.objectPairs (toJSON crit)+      ++ maybe [] (Types.objectPairs . toJSON) alg++instance FromArmour T.Text Error JWEHeader where+  parseArmour s =+        first (compactErr "header")+          (B64UL.decode (L.fromStrict $ Types.pad $ T.encodeUtf8 s))+        >>= first JSONDecodeError . eitherDecode+    where+    compactErr s' = CompactDecodeError . ((s' ++ " decode failed: ") ++)++instance ToArmour T.Text JWEHeader where+  toArmour = T.decodeUtf8 . Types.unpad . B64U.encode . L.toStrict . encode+++data JWERecipient = JWERecipient+  { _jweHeader :: Maybe JWEHeader -- ^ JWE Per-Recipient Unprotected Header+  , _jweEncryptedKey :: Maybe Types.Base64Octets  -- ^ JWE Encrypted Key+  }++instance FromJSON JWERecipient where+  parseJSON = withObject "JWE Recipient" $ \o -> JWERecipient+    <$> o .:? "header"+    <*> o .:? "encrypted_key"++data JWE = JWE+  { _jweProtected :: Maybe (Armour T.Text JWEHeader)+  , _jweUnprotected :: Maybe JWEHeader+  , _jweIv :: Maybe Types.Base64Octets  -- ^ JWE Initialization Vector+  , _jweAad :: Maybe Types.Base64Octets -- ^ JWE AAD+  , _jweCiphertext :: Types.Base64Octets  -- ^ JWE Ciphertext+  , _jweTag :: Maybe Types.Base64Octets  -- ^ JWE Authentication Tag+  , _jweRecipients :: [JWERecipient]+  }++instance FromJSON JWE where+  parseJSON =+    withObject "JWE JSON Serialization" $ \o -> JWE+      <$> o .:? "protected"+      <*> o .:? "unprotected"+      <*> o .:? "iv"+      <*> o .:? "aad"+      <*> o .: "ciphertext"+      <*> o .:? "tag"+      <*> o .: "recipients"+  -- TODO flattened serialization+++wrap+  :: MonadRandom m+  => AlgWithParams+  -> KeyMaterial+  -> B.ByteString  -- ^ message (key to wrap)+  -> m (Either Error (AlgWithParams, B.ByteString))+wrap alg@RSA_OAEP (RSAKeyMaterial k) m = bimap RSAError (alg,) <$>+  OAEP.encrypt (OAEP.OAEPParams SHA1 (mgf1 SHA1) Nothing) (rsaPublicKey k) m+wrap RSA_OAEP _ _ = return $ Left $ AlgorithmMismatch "Cannot use RSA_OAEP with non-RSA key"+wrap alg@RSA_OAEP_256 (RSAKeyMaterial k) m = bimap RSAError (alg,) <$>+  OAEP.encrypt (OAEP.OAEPParams SHA256 (mgf1 SHA256) Nothing) (rsaPublicKey k) m+wrap RSA_OAEP_256 _ _ = return $ Left $ AlgorithmMismatch "Cannot use RSA_OAEP_256 with non-RSA key"+wrap A128KW (OctKeyMaterial (OctKeyParameters _ (Types.Base64Octets k))) m+  = return $ (A128KW,) <$> wrapAESKW (cipherInit k :: CryptoFailable AES128) m+wrap A192KW (OctKeyMaterial (OctKeyParameters _ (Types.Base64Octets k))) m+  = return $ (A192KW,) <$> wrapAESKW (cipherInit k :: CryptoFailable AES192) m+wrap A256KW (OctKeyMaterial (OctKeyParameters _ (Types.Base64Octets k))) m+  = return $ (A256KW,) <$> wrapAESKW (cipherInit k :: CryptoFailable AES256) m+wrap (A128GCMKW _) k m = wrapAESGCM A128GCMKW A128GCM k m+wrap (A192GCMKW _) k m = wrapAESGCM A192GCMKW A192GCM k m+wrap (A256GCMKW _) k m = wrapAESGCM A256GCMKW A256GCM k m+wrap _ _ _ = return $ Left AlgorithmNotImplemented++wrapAESKW+  :: BlockCipher128 cipher+  => CryptoFailable cipher+  -> B.ByteString -- ^ plaintext key (to be encrypted)+  -> Either Error B.ByteString -- ^ encrypted key+wrapAESKW cipher m = case cipher of+  CryptoFailed e -> Left (CryptoError e)+  CryptoPassed cipher' -> Right (aesKeyWrap cipher' m)++wrapAESGCM+  :: MonadRandom m+  => (AESGCMParameters -> AlgWithParams)+  -> Enc+  -> KeyMaterial+  -> B.ByteString+  -> m (Either Error (AlgWithParams, B.ByteString))+wrapAESGCM f enc (OctKeyMaterial (OctKeyParameters _ (Types.Base64Octets k))) m =+  fmap (\(iv, tag, m') -> (f (AESGCMParameters (Types.Base64Octets iv) (Types.Base64Octets tag)), m'))+  <$> encrypt enc k m ""+wrapAESGCM _ _ _ _ = return $ Left $ AlgorithmMismatch "Cannot use AESGCMKW with non-Oct key"++encrypt+  :: MonadRandom m+  => Enc+  -> B.ByteString -- ^ key+  -> B.ByteString  -- ^ message+  -> B.ByteString  -- ^ AAD+  -> m (Either Error (B.ByteString, B.ByteString, B.ByteString))+encrypt A128CBC_HS256 k m a = case B.length k of+  32 -> _cbcHmacEnc (undefined :: AES128) SHA256 k m a+  _ -> return $ Left KeySizeTooSmall+encrypt A192CBC_HS384 k m a = case B.length k of+  48 -> _cbcHmacEnc (undefined :: AES192) SHA384 k m a+  _ -> return $ Left KeySizeTooSmall+encrypt A256CBC_HS512 k m a = case B.length k of+  64 -> _cbcHmacEnc (undefined :: AES256) SHA512 k m a+  _ -> return $ Left KeySizeTooSmall+encrypt A128GCM k m a = case B.length k of+  16 -> _gcmEnc (undefined :: AES128) k m a+  _ -> return $ Left KeySizeTooSmall+encrypt A192GCM k m a = case B.length k of+  24 -> _gcmEnc (undefined :: AES192) k m a+  _ -> return $ Left KeySizeTooSmall+encrypt A256GCM k m a = case B.length k of+  32 -> _gcmEnc (undefined :: AES256) k m a+  _ -> return $ Left KeySizeTooSmall++_cbcHmacEnc+  :: forall e h m. (BlockCipher e, HashAlgorithm h, MonadRandom m)+  => e+  -> h+  -> B.ByteString -- ^ key+  -> B.ByteString -- ^ message+  -> B.ByteString -- ^ additional authenticated data+  -> m (Either Error (B.ByteString, B.ByteString, B.ByteString))  -- ^ IV, cipertext and MAC+_cbcHmacEnc _ _ k m aad = do+  let+    kLen = B.length k `div` 2+    (eKey, mKey) = B.splitAt kLen k+    aadLen = B.reverse $ fst $ B.unfoldrN 8 (\x -> Just (fromIntegral x, x `div` 256)) (B.length aad)+  case cipherInit eKey of+    CryptoFailed _ -> return $ Left AlgorithmNotImplemented -- FIXME+    CryptoPassed (e :: e) -> do+      iv <- getRandomBytes 16+      let Just iv' = makeIV iv+      let m' = pad (PKCS7 $ blockSize e) m+      let c = cbcEncrypt e iv' m'+      let hmacInput = B.concat [aad, iv, c, aadLen]+      let tag = B.take kLen $ BA.pack $ BA.unpack (hmac mKey hmacInput :: HMAC h)+      return $ Right (iv, c, tag)++_gcmEnc+  :: forall e m. (BlockCipher e, MonadRandom m)+  => e+  -> B.ByteString -- ^ key+  -> B.ByteString -- ^ message+  -> B.ByteString -- ^ additional authenticated data+  -> m (Either Error (B.ByteString, B.ByteString, B.ByteString))  -- ^ IV, tag and ciphertext+_gcmEnc _ k m aad = do+  iv <- getRandomBytes 12+  case cipherInit k of+    CryptoFailed _ -> return $ Left AlgorithmNotImplemented -- FIXME+    CryptoPassed (e :: e) -> case aeadInit AEAD_GCM e iv of+      CryptoFailed _ -> return $ Left AlgorithmNotImplemented -- FIXME+      CryptoPassed aead -> do+        let m' = pad (PKCS7 $ blockSize e) m+        let (c, aeadFinal) = aeadEncrypt (aeadAppendHeader aead aad) m'+        let tag = BA.pack $ BA.unpack $ aeadFinalize aeadFinal 16+        return $ Right (iv, tag, c)

@@ -1,4 +1,4 @@--- Copyright (C) 2013, 2014, 2015  Fraser Tweedale+-- Copyright (C) 2013, 2014, 2015, 2016  Fraser Tweedale -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -37,6 +37,8 @@   , jwkX5c   , jwkX5t   , jwkX5tS256+  , fromKeyMaterial+  , genJWK    , JWKSet(..) @@ -44,14 +46,14 @@   ) where  import Control.Applicative-import Data.Bifunctor import Data.Maybe (catMaybes)  import Control.Lens hiding ((.=)) import Data.Aeson import Data.List.NonEmpty -import Crypto.JOSE.Classes+import Test.QuickCheck+ import qualified Crypto.JOSE.JWA.JWE.Alg as JWA.JWE import Crypto.JOSE.JWA.JWK import qualified Crypto.JOSE.JWA.JWS as JWA.JWS@@ -128,14 +130,27 @@     ]     ++ Types.objectPairs (toJSON _jwkMaterial) -instance Key JWK where-  type KeyGenParam JWK = Crypto.JOSE.JWA.JWK.KeyMaterialGenParam-  type KeyContent JWK = Crypto.JOSE.JWA.JWK.KeyMaterial-  gen p = first fromKeyContent . gen p-  fromKeyContent k = JWK k z z z z z z z z where z = Nothing-  public = jwkMaterial public-  sign h k = sign h $ k ^. jwkMaterial-  verify h k = verify h $ k ^. jwkMaterial+genJWK :: MonadRandom m => KeyMaterialGenParam -> m JWK+genJWK p = fromKeyMaterial <$> genKeyMaterial p++instance Arbitrary JWK where+  arbitrary = JWK+    <$> arbitrary+    <*> pure Nothing+    <*> pure Nothing+    <*> pure Nothing+    <*> arbitrary+    <*> pure Nothing+    <*> pure Nothing+    <*> arbitrary+    <*> arbitrary++fromKeyMaterial :: KeyMaterial -> JWK+fromKeyMaterial k = JWK k z z z z z z z z where z = Nothing+++instance AsPublicKey JWK where+  asPublicKey = prism' id (jwkMaterial (preview asPublicKey))   -- | JWK §4.  JSON Web Key Set (JWK Set) Format

@@ -24,8 +24,10 @@     Alg(..)    , JWSHeader(..)+  , newJWSHeader    , JWS(..)+  , newJWS   , jwsPayload   , signJWS 

@@ -1,4 +1,4 @@--- Copyright (C) 2013, 2014  Fraser Tweedale+-- Copyright (C) 2013, 2014, 2015  Fraser Tweedale -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -23,7 +23,6 @@ import Control.Applicative import Control.Monad ((>=>), when, unless) import Data.Bifunctor-import Data.Char import Data.Maybe  import Control.Lens ((^.))@@ -43,7 +42,6 @@ import qualified Data.Text.Encoding as T import Data.Traversable (mapM) -import Crypto.JOSE.Classes import Crypto.JOSE.Compact import Crypto.JOSE.Error import qualified Crypto.JOSE.JWA.JWS as JWA.JWS@@ -106,12 +104,10 @@ instance FromArmour T.Text Error JWSHeader where   parseArmour s =         first (compactErr "header")-          (B64UL.decode (pad $ BSL.fromStrict $ T.encodeUtf8 s))+          (B64UL.decode (BSL.fromStrict $ Types.pad $ T.encodeUtf8 s))         >>= first JSONDecodeError . eitherDecode     where     compactErr s' = CompactDecodeError . ((s' ++ " decode failed: ") ++)-    pad t = t `BSL.append` BSL.replicate ((4 - BSL.length t `mod` 4) `mod` 4) c-    c = fromIntegral $ ord '='  instance ToArmour T.Text JWSHeader where   toArmour = T.decodeUtf8 . Types.unpad . B64U.encode . BSL.toStrict . encode@@ -123,9 +119,9 @@     <*> o .:? "jwk"     <*> o .:? "kid"     <*> o .:? "x5u"+    <*> o .:? "x5c"     <*> o .:? "x5t"     <*> o .:? "x5t#S256"-    <*> o .:? "x5c"     <*> o .:? "typ"     <*> o .:? "cty"     <*> (o .:? "crit" >>= mapM (parseCrit o))@@ -148,9 +144,10 @@ instance Default JWSHeader where   def = JWSHeader z z z z z z z z z z z where z = Nothing --- construct a minimal header with the given alg-algHeader :: JWA.JWS.Alg -> JWSHeader-algHeader alg = def { headerAlg = Just alg }+-- | Construct a minimal header with the given algorithm+--+newJWSHeader :: JWA.JWS.Alg -> JWSHeader+newJWSHeader alg = def { headerAlg = Just alg }   data Signature = Signature@@ -209,10 +206,14 @@       then fail "\"signatures\" member MUST NOT be present"       else (\p s -> JWS p [s]) <$> o .: "payload" <*> parseJSON v) v - instance ToJSON JWS where   toJSON (JWS p ss) = object ["payload" .= p, "signatures" .= ss] +-- | Construct a new (unsigned) JWS+--+newJWS :: BS.ByteString -> JWS+newJWS msg = JWS (Types.Base64Octets msg) []+ -- | Payload of a JWS, as a lazy bytestring. -- jwsPayload :: JWS -> BSL.ByteString@@ -257,15 +258,14 @@ -- | Create a new signature on a JWS. -- signJWS-  :: CPRG g-  => g        -- ^ Random number generator-  -> JWS      -- ^ JWS to sign+  :: MonadRandom m+  => JWS      -- ^ JWS to sign   -> JWSHeader  -- ^ Header for signature   -> JWK      -- ^ Key with which to sign-  -> (Either Error JWS, g) -- ^ JWS with new signature appended-signJWS g (JWS p sigs) h k = first (second appendSig) $ case headerAlg h of-    Nothing   -> (Left JWSMissingAlg, g)-    Just alg  -> sign alg k g (signingInput h' p)+  -> m (Either Error JWS) -- ^ JWS with new signature appended+signJWS (JWS p sigs) h k = case headerAlg h of+    Nothing   -> return $ Left JWSMissingAlg+    Just alg  -> fmap appendSig <$> sign alg (k ^. jwkMaterial) (signingInput h' p)   where     appendSig sig = JWS p (Signature h' Nothing (Types.Base64Octets sig):sigs)     h' = Just $ Unarmoured h@@ -324,5 +324,5 @@ verifySig :: JWK -> Types.Base64Octets -> Signature -> Either Error Bool verifySig k m sig@(Signature h _ (Types.Base64Octets s)) = maybe   (Left $ AlgorithmMismatch "No 'alg' header")  -- shouldn't happen-  (\alg -> verify alg k (signingInput h m) s)+  (\alg -> verify alg (k ^. jwkMaterial) (signingInput h m) s)   (algorithm sig)

@@ -1,4 +1,4 @@--- Copyright (C) 2013, 2014  Fraser Tweedale+-- Copyright (C) 2013, 2014, 2015, 2016  Fraser Tweedale -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -26,23 +26,20 @@ module Crypto.JOSE.Legacy   (     JWK'(..)+  , genJWK'   , toJWK   , RSKeyParameters()-  , rsaKeyParameters   ) where  import Control.Applicative-import Data.Bifunctor-import GHC.Types (Int(I#))-import GHC.Integer.Logarithms (integerLog2#)  import Control.Lens hiding ((.=))+import Crypto.Number.Basic (log2) import Data.Aeson import Data.Aeson.Types import qualified Data.Text as T import Safe (readMay) -import Crypto.JOSE.Classes import Crypto.JOSE.JWA.JWK import Crypto.JOSE.JWK import qualified Crypto.JOSE.Types.Internal as Types@@ -50,8 +47,8 @@ import Crypto.JOSE.TH  -newtype StringifiedInteger = StringifiedInteger { _unString :: Integer }-makeLenses ''StringifiedInteger+newtype StringifiedInteger = StringifiedInteger Integer+makePrisms ''StringifiedInteger  instance FromJSON StringifiedInteger where   parseJSON = withText "StringifiedInteger" $@@ -63,26 +60,24 @@   toJSON (StringifiedInteger n) = toJSON $ show n  b64Iso :: Iso' StringifiedInteger Base64Integer-b64Iso = iso-  (Base64Integer . view unString)-  (\(Base64Integer n) -> StringifiedInteger n)+b64Iso = _StringifiedInteger . from _Base64Integer  sizedB64Iso :: Iso' StringifiedInteger SizedBase64Integer sizedB64Iso = iso-  ((\n -> SizedBase64Integer (size n) n) . view unString)+  ((\n -> SizedBase64Integer (size n) n) . view _StringifiedInteger)   (\(SizedBase64Integer _ n) -> StringifiedInteger n)   where   size n =-    let (bytes, bits) = (I# (integerLog2# n) + 1) `divMod` 8+    let (bytes, bits) = (log2 n + 1) `divMod` 8     in bytes + signum bits   $(Crypto.JOSE.TH.deriveJOSEType "RS" ["RS"])  -newtype RSKeyParameters = RSKeyParameters { _rsaKeyParameters :: RSAKeyParameters }+newtype RSKeyParameters = RSKeyParameters RSAKeyParameters   deriving (Eq, Show)-makeLenses ''RSKeyParameters+makePrisms ''RSKeyParameters  instance FromJSON RSKeyParameters where   parseJSON = withObject "RS" $ \o -> fmap RSKeyParameters $ RSAKeyParameters@@ -101,21 +96,12 @@       ++ maybe [] (\p -> ["d" .= (rsaD p ^. from b64Iso)])         (k ^. rsaPrivateKeyParameters) -instance Key RSKeyParameters where-  type KeyGenParam RSKeyParameters = Int-  type KeyContent RSKeyParameters = RSAKeyParameters-  gen p = first fromKeyContent . gen p-  fromKeyContent = RSKeyParameters-  public = rsaKeyParameters public-  sign h (RSKeyParameters k) = sign h k-  verify h (RSKeyParameters k) = verify h k - -- | Legacy JSON Web Key data type. ---newtype JWK' = JWK' { _rsKeyParameters :: RSKeyParameters }+newtype JWK' = JWK' RSKeyParameters   deriving (Eq, Show)-makeLenses ''JWK'+makePrisms ''JWK'  instance FromJSON JWK' where   parseJSON = withObject "JWK'" $ \o -> JWK' <$> parseJSON (Object o)@@ -123,14 +109,11 @@ instance ToJSON JWK' where   toJSON (JWK' k) = object $ Types.objectPairs (toJSON k) -instance Key JWK' where-  type KeyGenParam JWK' = Int-  type KeyContent JWK' = RSKeyParameters-  gen p g = first JWK' $ gen p g-  fromKeyContent = JWK'-  public = rsKeyParameters public-  sign h (JWK' k) = sign h k-  verify h (JWK' k) = verify h k+instance AsPublicKey JWK' where+  asPublicKey = prism' id (_JWK' (_RSKeyParameters (preview asPublicKey))) +genJWK' :: MonadRandom m => Int -> m JWK'+genJWK' size = JWK' . RSKeyParameters <$> genRSA size+ toJWK :: JWK' -> JWK-toJWK (JWK' (RSKeyParameters k)) = fromKeyContent $ RSAKeyMaterial k+toJWK (JWK' (RSKeyParameters k)) = fromKeyMaterial $ RSAKeyMaterial k

@@ -1,4 +1,4 @@--- Copyright (C) 2013, 2014, 2015  Fraser Tweedale+-- Copyright (C) 2013, 2014, 2015, 2016  Fraser Tweedale -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -13,6 +13,7 @@ -- limitations under the License.  {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}  {-| @@ -22,8 +23,10 @@ module Crypto.JOSE.Types   (     Base64Integer(..)+  , _Base64Integer   , SizedBase64Integer(..)-  , Base64UrlString(..)+  , genSizedBase64IntegerOf+  , checkSize   , Base64Octets(..)   , Base64SHA1(..)   , Base64SHA256(..)@@ -33,12 +36,16 @@  import Control.Applicative +import Control.Lens import Data.Aeson+import Data.Aeson.Types (Parser) import Data.Byteable import qualified Data.ByteString as B import qualified Data.ByteString.Base64.URL as B64U import Data.X509 import Network.URI (URI)+import Test.QuickCheck+import Test.QuickCheck.Instances ()  import Crypto.JOSE.Types.Internal import Crypto.JOSE.Types.Orphans ()@@ -48,6 +55,7 @@ -- newtype Base64Integer = Base64Integer Integer   deriving (Eq, Show)+makePrisms ''Base64Integer  instance FromJSON Base64Integer where   parseJSON = withText "base64url integer" $ parseB64Url $@@ -56,31 +64,50 @@ instance ToJSON Base64Integer where   toJSON (Base64Integer x) = encodeB64Url $ integerToBS x +instance Arbitrary Base64Integer where+  arbitrary = Base64Integer <$> arbitrarySizedNatural + -- | A base64url encoded octet sequence interpreted as an integer -- and where the number of octets carries explicit bit-length -- information. -- data SizedBase64Integer = SizedBase64Integer Int Integer-  deriving (Eq, Show)+  deriving (Show) +instance Eq SizedBase64Integer where+  SizedBase64Integer _ n == SizedBase64Integer _ m = n == m++instance Arbitrary SizedBase64Integer where+  arbitrary = do+    x <- arbitrarySizedNatural+    l <- arbitrarySizedNatural  -- arbitrary number of leading zero-bytes+    return $ SizedBase64Integer+      ((+ l) $ ceiling $ logBase 2 (fromInteger x :: Double))+      x++genByteStringOf :: Int -> Gen B.ByteString+genByteStringOf n = B.pack <$> vectorOf n arbitrary++-- | Generate a 'SizedBase64Integer' of the given number of bytes+--+genSizedBase64IntegerOf :: Int -> Gen SizedBase64Integer+genSizedBase64IntegerOf n =+  SizedBase64Integer n . bsToInteger <$> genByteStringOf n+ instance FromJSON SizedBase64Integer where   parseJSON = withText "full size base64url integer" $ parseB64Url (\bytes ->     pure $ SizedBase64Integer (B.length bytes) (bsToInteger bytes))  instance ToJSON SizedBase64Integer where-  toJSON (SizedBase64Integer s x) = encodeB64Url $ zeroPad $ integerToBS x-    where zeroPad xs = B.replicate (s - B.length xs) 0 `B.append` xs-+  toJSON (SizedBase64Integer w n) = encodeB64Url $ sizedIntegerToBS w n --- | A base64url encoded string.  This is used for the JWE--- /Agreement PartyUInfo/ and /Agreement PartyVInfo/ fields.+-- | Parsed a 'SizedBase64Integer' with an expected number of /bytes/. ---newtype Base64UrlString = Base64UrlString B.ByteString-  deriving (Eq, Show)--instance FromJSON Base64UrlString where-  parseJSON = withText "base64url string" $ parseB64Url $ pure . Base64UrlString+checkSize :: Int -> SizedBase64Integer -> Parser SizedBase64Integer+checkSize n a@(SizedBase64Integer m _) = if n == m+  then return a+  else fail $ "expected " ++ show n ++ " octets, found " ++ show m   -- | A base64url encoded octet sequence.  Used for payloads,@@ -98,7 +125,10 @@ instance ToJSON Base64Octets where   toJSON (Base64Octets bytes) = encodeB64Url bytes +instance Arbitrary Base64Octets where+  arbitrary = Base64Octets <$> arbitrary + -- | A base64url encoded SHA-1 digest.  Used for X.509 certificate -- thumbprints. --@@ -114,7 +144,10 @@ instance ToJSON Base64SHA1 where   toJSON (Base64SHA1 bytes) = encodeB64Url bytes +instance Arbitrary Base64SHA1 where+  arbitrary = Base64SHA1 <$> genByteStringOf 20 + -- | A base64url encoded SHA-256 digest.  Used for X.509 certificate -- thumbprints. --@@ -129,6 +162,9 @@  instance ToJSON Base64SHA256 where   toJSON (Base64SHA256 bytes) = encodeB64Url bytes++instance Arbitrary Base64SHA256 where+  arbitrary = Base64SHA256 <$> genByteStringOf 32   -- | A base64 encoded X.509 certificate.

@@ -84,3 +84,7 @@   where     f x = if x == 0 then Nothing else Just (toWord8 $ quotRem x 256)     toWord8 (seed, x) = (seed, fromIntegral x)++sizedIntegerToBS :: Int -> Integer -> B.ByteString+sizedIntegerToBS w = zeroPad . integerToBS+  where zeroPad xs = B.replicate (w - B.length xs) 0 `B.append` xs

@@ -18,12 +18,14 @@  import Prelude hiding (mapM) +import Control.Applicative import Data.Traversable  import Data.List.NonEmpty (NonEmpty(..), toList) import qualified Data.Text as T import qualified Data.Vector as V import Network.URI (URI, parseURI)+import Test.QuickCheck  import Data.Aeson @@ -43,3 +45,7 @@  instance ToJSON URI where   toJSON = String . T.pack . show+++instance Arbitrary a => Arbitrary (NonEmpty a) where+  arbitrary = (:|) <$> arbitrary <*> arbitrary

@@ -1,4 +1,4 @@--- Copyright (C) 2013, 2014  Fraser Tweedale+-- Copyright (C) 2013, 2014, 2015  Fraser Tweedale -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -55,7 +55,7 @@ import Data.Bifunctor import Data.Maybe -import Control.Lens hiding ((.=))+import Control.Lens (makeLenses, over) import Data.Aeson import qualified Data.ByteString.Lazy as BSL import qualified Data.HashMap.Strict as M@@ -267,13 +267,12 @@ -- | Create a JWT that is a JWS. -- createJWSJWT-  :: CPRG g-  => g-  -> JWK+  :: MonadRandom m+  => JWK   -> JWSHeader   -> ClaimsSet-  -> (Either Error JWT, g)-createJWSJWT g k h c = first (fmap $ \jws -> JWT (JWTJWS jws) c) $-  signJWS g (JWS payload []) h k+  -> m (Either Error JWT)+createJWSJWT k h c = fmap (\jws -> JWT (JWTJWS jws) c) <$>+  signJWS (JWS payload []) h k   where     payload = Base64Octets $ BSL.toStrict $ encode c

@@ -0,0 +1,54 @@+-- Copyright (C) 2016  Fraser Tweedale+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++module AESKW where++import Control.Applicative ((<$>), pure)++import qualified Data.ByteString as B+import Crypto.Cipher.AES+import Crypto.Cipher.Types+import Crypto.Error++import Test.QuickCheck.Monadic+import Test.Tasty+import Test.Tasty.QuickCheck++import Crypto.JOSE.AESKW+++aeskwProperties = testGroup "AESKW"+  [ testProperty "AESKW round-trip" prop_roundTrip+  ]++prop_roundTrip :: Property+prop_roundTrip = monadicIO $ do+  cekLen <- (* 8) . (+ 2) <$> pick arbitrarySizedNatural+  cek <- pick $ B.pack <$> vectorOf cekLen arbitrary+  kekLen <- pick $ oneof $ pure <$> [16, 24, 32]+  kek <- pick $ B.pack <$> vectorOf kekLen arbitrary+  let+    check :: BlockCipher128 cipher => CryptoFailable cipher -> Bool+    check cipher' = case cipher' of+      CryptoFailed _ -> False+      CryptoPassed cipher ->+        let+          c = aesKeyWrap cipher cek :: B.ByteString+          cek' = aesKeyUnwrap cipher c+        in+          B.length c == cekLen + 8 && cek' == Just cek+  case kekLen of+    16 -> assert $ check (cipherInit kek :: CryptoFailable AES128)+    24 -> assert $ check (cipherInit kek :: CryptoFailable AES192)+    32 -> assert $ check (cipherInit kek :: CryptoFailable AES256)

@@ -1,4 +1,4 @@--- Copyright (C) 2013, 2014  Fraser Tweedale+-- Copyright (C) 2013, 2014, 2015  Fraser Tweedale -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -18,6 +18,7 @@  import Data.Maybe +import Control.Lens import Data.Aeson import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L@@ -25,7 +26,6 @@ import Data.Default.Class import Test.Hspec -import Crypto.JOSE.Classes import Crypto.JOSE.Compact import Crypto.JOSE.JWA.JWK import Crypto.JOSE.JWK@@ -36,8 +36,8 @@ import Crypto.JOSE.Types.Armour  -rng :: SystemRNG-rng = cprgCreate $ createTestEntropyPool "dummy CPRG for testing"+drg :: ChaChaDRG+drg = drgNewTest (1,2,3,4,5)  spec :: Spec spec = do@@ -72,7 +72,7 @@ critSpec' :: Spec critSpec' = describe "JWS §4.1.10. \"crit\" Header Parameter; full example" $   it "parses from JSON correctly" $-    decode s `shouldBe` Just ((algHeader JWA.JWS.ES256) { headerCrit = Just critValue })+    decode s `shouldBe` Just ((newJWSHeader JWA.JWS.ES256) { headerCrit = Just critValue })     where       s = "{\"alg\":\"ES256\",\"crit\":[\"exp\"],\"exp\":1363284000}"       critValue = CritParameters $ return ("exp", Number 1363284000)@@ -86,7 +86,7 @@       typValue = Just "JWT"     in       eitherDecode headerJSON-        `shouldBe` Right ((algHeader JWA.JWS.HS256) { headerTyp = typValue })+        `shouldBe` Right ((newJWSHeader JWA.JWS.HS256) { headerTyp = typValue })    it "parses signature correctly" $     let@@ -121,7 +121,7 @@     (encodeCompact jws >>= decodeCompact) `shouldBe` Right jws    it "computes the HMAC correctly" $-    fst (sign alg jwk rng (L.toStrict signingInput'))+    fst (withDRG drg $ sign alg (jwk ^. jwkMaterial) (L.toStrict signingInput'))       `shouldBe` Right (BS.pack macOctets)    it "validates the JWS correctly" $@@ -157,10 +157,11 @@ appendixA2Spec :: Spec appendixA2Spec = describe "JWS A.2. Example JWS using RSASSA-PKCS-v1_5 SHA-256" $ do   it "computes the signature correctly" $-    fst (sign JWA.JWS.RS256 jwk rng signingInput') `shouldBe` Right sig+    fst (withDRG drg $ sign JWA.JWS.RS256 (jwk ^. jwkMaterial) signingInput')+      `shouldBe` Right sig    it "validates the signature correctly" $-    verify JWA.JWS.RS256 jwk signingInput' sig `shouldBe` Right True+    verify JWA.JWS.RS256 (jwk ^. jwkMaterial) signingInput' sig `shouldBe` Right True    where     signingInput' = "\@@ -209,7 +210,7 @@ appendixA3Spec :: Spec appendixA3Spec = describe "JWS A.3.  Example JWS using ECDSA P-256 SHA-256" $   it "validates the signature correctly" $-    verify JWA.JWS.ES256 jwk signingInput' sig `shouldBe` Right True+    verify JWA.JWS.ES256 (jwk ^. jwkMaterial) signingInput' sig `shouldBe` Right True   where     signingInput' = "\       \eyJhbGciOiJFUzI1NiJ9\@@ -240,8 +241,8 @@     decodeCompact exampleJWS `shouldBe` jws    where-    jws = fst $-      signJWS rng (JWS examplePayload []) (algHeader JWA.JWS.None) undefined+    jws = fst $ withDRG drg $+      signJWS (JWS examplePayload []) (newJWSHeader JWA.JWS.None) undefined     exampleJWS = "eyJhbGciOiJub25lIn0\       \.\       \eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFt\

@@ -0,0 +1,85 @@+-- Copyright (C) 2015  Fraser Tweedale+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++{-# LANGUAGE ScopedTypeVariables #-}++module Properties where++import Control.Applicative++import Data.Aeson+import qualified Data.ByteString as B+import Data.Default.Class++import Test.Tasty+import Test.Tasty.QuickCheck+import Test.QuickCheck.Monadic+import Test.QuickCheck.Instances ()++import Crypto.JOSE.Types+import Crypto.JOSE.JWK+import Crypto.JOSE.JWS++properties = testGroup "Properties"+  [ testProperty "SizedBase64Integer round-trip"+    (prop_roundTrip :: SizedBase64Integer -> Bool)+  , testProperty "JWK round-trip" (prop_roundTrip :: JWK -> Bool)+  , testProperty "ECDSA gen, sign and verify" prop_ecSignAndVerify+  , testProperty "HMAC gen, sign and verify" prop_hmacSignAndVerify+  , testProperty "RSA gen, sign and verify" prop_rsaSignAndVerify+  ]++prop_roundTrip :: (Eq a, ToJSON a, FromJSON a) => a -> Bool+prop_roundTrip a = decode (encode [a]) == Just [a]++debugRoundTrip+  :: (Show a, Arbitrary a, ToJSON a, FromJSON a)+  => (a -> Bool)+  -> Property+debugRoundTrip f = monadicIO $ do+  a :: a <- pick arbitrary+  let encoded = encode [a]+  monitor $ counterexample $+    "JSON: \n" ++ show encoded ++ "\n\nDecoded: \n" ++ show (decode encoded :: Maybe [a])+  assert $ f a++prop_ecSignAndVerify :: Crv -> B.ByteString -> Property+prop_ecSignAndVerify crv msg = monadicIO $ do+  k :: JWK <- run $ genJWK (ECGenParam crv)+  let alg = case crv of P_256 -> ES256 ; P_384 -> ES384 ; P_521 -> ES512+  wp (signJWS (newJWS msg) (newJWSHeader alg) k) (checkSignJWS k)++prop_hmacSignAndVerify :: B.ByteString -> Property+prop_hmacSignAndVerify msg = monadicIO $ do+  (alg, minLen) <-+    pick $ oneof $ pure <$> [(HS256, 32), (HS384, 48), (HS512, 64)]+  keylen <- (+ minLen) <$> pick arbitrarySizedNatural+  k :: JWK <- run $ genJWK (OctGenParam keylen)+  wp (signJWS (newJWS msg) (newJWSHeader alg) k) (checkSignJWS k)++prop_rsaSignAndVerify :: B.ByteString -> Property+prop_rsaSignAndVerify msg = monadicIO $ do+  keylen <- pick $ oneof $ pure . (`div` 8) <$> [2048, 3072, 4096]+  k :: JWK <- run $ genJWK (RSAGenParam keylen)+  alg <- pick $ oneof $ pure <$> [RS256, RS384, RS512, PS256, PS384, PS512]+  wp (signJWS (newJWS msg) (newJWSHeader alg) k) (checkSignJWS k)++checkSignJWS :: (Monad m, Show e) => JWK -> Either e JWS -> PropertyM m ()+checkSignJWS k signResult = case signResult of+  Left e -> do+    monitor (counterexample $ "Failed to sign: " ++ show e)+    assert False+  Right jws -> do+    monitor (counterexample "Failed to verify")+    assert (verifyJWS def def k jws)

@@ -1,4 +1,4 @@--- Copyright (C) 2013, 2014  Fraser Tweedale+-- Copyright (C) 2013, 2014, 2015  Fraser Tweedale -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -12,17 +12,27 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -import Test.Hspec+import Test.Tasty+import Test.Tasty.Hspec+import Test.Tasty.QuickCheck +import AESKW import JWK import JWS import JWT import Types+import Properties   main :: IO ()-main = hspec $ do-  Types.spec-  JWK.spec-  JWS.spec-  JWT.spec+main = do+  unitTests <- unitTestsIO+  defaultMain $ testGroup "Tests" [unitTests, properties, aeskwProperties]++unitTestsIO :: IO TestTree+unitTestsIO = do+  types <- testSpec "Types" Types.spec+  jwk <- testSpec "JWK" JWK.spec+  jws <- testSpec "JWS" JWS.spec+  jwt <- testSpec "JWT" JWT.spec+  return $ testGroup "Unit tests" [types, jwk, jws, jwt]

@@ -26,18 +26,11 @@  spec :: Spec spec = do-  base64UrlSpec   base64OctetsSpec   uriSpec   base64IntegerSpec   sizedBase64IntegerSpec   base64X509Spec--base64UrlSpec :: Spec-base64UrlSpec = describe "Base64UrlString" $-  it "can be read from JSON" $ do-    decode "[\"QWxpY2U\"]" `shouldBe` Just [Base64UrlString "Alice"]-    decode "[\"Qm9i\"]"`shouldBe` Just [Base64UrlString "Bob"]  base64OctetsSpec :: Spec base64OctetsSpec = describe "Base64Octets" $