jose 0.2.33.0 → 0.2.38.0

raw patch · 11 files changed

+333/−163 lines, 11 filesdep +bifunctorsdep +data-default-classdep +lensdep −networkPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bifunctors, data-default-class, lens, network-uri, semigroups

Dependencies removed: network

API changes (from Hackage documentation)

Files

• jose.cabal +13/−3
• src/Crypto/JOSE/Error.hs +5/−0
• src/Crypto/JOSE/JWA/JWK.hs +16/−9
• src/Crypto/JOSE/JWK.hs +1/−1
• src/Crypto/JOSE/JWS.hs +4/−1
• src/Crypto/JOSE/JWS/Internal.hs +156/−134
• src/Crypto/JOSE/Legacy.hs +1/−1
• src/Crypto/JOSE/Types.hs +1/−0
• src/Crypto/JOSE/Types/Armour.hs +85/−0
• src/Crypto/JOSE/Types/Orphans.hs +32/−0
• src/Crypto/JWT.hs +19/−14

@@ -1,5 +1,5 @@ name:                jose-version:             0.2.33.0+version:             0.2.38.0 synopsis:   Javascript Object Signing and Encryption and JSON Web Token library description:@@ -50,24 +50,30 @@     Crypto.JOSE.JWA.JWE.Alg     Crypto.JOSE.JWS.Internal     Crypto.JOSE.TH+    Crypto.JOSE.Types.Armour     Crypto.JOSE.Types.Internal+    Crypto.JOSE.Types.Orphans    build-depends:     base == 4.*     , 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.*+    , data-default-class+    , lens >= 4.3     , template-haskell >= 2.4+    , semigroups >= 0.15     , aeson >= 0.7 && < 0.9     , unordered-containers == 0.2.*     , bytestring == 0.10.*     , text == 1.1.*     , time == 1.4.*-    , network >= 2.4+    , network-uri >= 2.6     , certificate == 1.3.*     , vector @@ -87,19 +93,23 @@     base     , attoparsec     , base64-bytestring+    , bifunctors     , byteable     , crypto-pubkey     , crypto-pubkey-types     , crypto-random     , cryptohash+    , data-default-class+    , lens     , old-locale     , template-haskell+    , semigroups     , aeson     , unordered-containers     , bytestring     , text     , time-    , network+    , network-uri     , certificate     , vector     , hspec

@@ -34,8 +34,13 @@   | AlgorithmMismatch String  -- ^ A requested algorithm cannot be used   | KeyMismatch String        -- ^ Wrong type of key was given   | KeySizeTooSmall           -- ^ Key size is too small+  | OtherPrimesNotSupported   -- ^ RSA private key with >2 primes not supported   | RSAError RSA.Error        -- ^ RSA encryption, decryption or signing error   | CompactEncodeError String -- ^ Cannot produce compact representation of data   | CompactDecodeError String -- ^ Cannot decode compact representation   | JSONDecodeError String    -- ^ Cannot decode JSON data+  | JWSMissingHeader+  | JWSMissingAlg+  | JWSCritUnprotected+  | JWSDuplicateHeaderParameter   deriving (Eq, Show)

@@ -46,7 +46,7 @@   ) where  import Control.Applicative-import Control.Arrow+import Data.Bifunctor import Data.Maybe  import Crypto.Hash@@ -61,6 +61,7 @@ import Data.Byteable import qualified Data.ByteString as B import qualified Data.HashMap.Strict as M+import Data.List.NonEmpty  import Crypto.JOSE.Error import Crypto.JOSE.Classes@@ -110,7 +111,7 @@   , rsaDp :: Types.Base64Integer   , rsaDq :: Types.Base64Integer   , rsaQi :: Types.Base64Integer-  , rsaOth :: Maybe [RSAPrivateKeyOthElem] -- TODO oth must not be empty array+  , rsaOth :: Maybe (NonEmpty RSAPrivateKeyOthElem)   }   deriving (Eq, Show) @@ -226,7 +227,7 @@   where   pubkey = ECDSA.PublicKey (curve k) (point k)   sig = uncurry ECDSA.Signature-    $ Types.bsToInteger *** Types.bsToInteger+    $ bimap Types.bsToInteger Types.bsToInteger     $ B.splitAt (B.length s `div` 2) s  curve :: ECKeyParameters -> ECC.Curve@@ -314,7 +315,7 @@   -> (Either Error B.ByteString, g) signPKCS15 h k g m = case rsaPrivateKey k of   Left e -> (Left e, g)-  Right k' -> first (either (Left . RSAError) Right) $+  Right k' -> first (first RSAError) $     PKCS15.signSafer g h k' m  verifyPKCS15@@ -334,7 +335,7 @@   -> (Either Error B.ByteString, g) signPSS h k g m = case rsaPrivateKey k of   Left e -> (Left e, g)-  Right k' -> first (either (Left . RSAError) Right) $+  Right k' -> first (first RSAError) $    PSS.signSafer g (PSS.defaultPSSParams (hashFunction h)) k' m  verifyPSS@@ -350,10 +351,16 @@ rsaPrivateKey (RSAKeyParameters _   (Types.SizedBase64Integer size n)   (Types.Base64Integer e)-  (Just (RSAPrivateKeyParameters (Types.Base64Integer d) _)))-  | size >= 2048 `div` 8 = Right $-    RSA.PrivateKey (RSA.PublicKey size n e) d 0 0 0 0 0-  | otherwise = Left KeySizeTooSmall+  (Just (RSAPrivateKeyParameters (Types.Base64Integer d) opt)))+  | isJust (opt >>= rsaOth) = Left OtherPrimesNotSupported+  | size < 2048 `div` 8 = Left KeySizeTooSmall+  | otherwise = Right $+    RSA.PrivateKey (RSA.PublicKey size n e) d+      (opt' rsaP) (opt' rsaQ) (opt' rsaDp) (opt' rsaDq) (opt' rsaQi)+    where+      opt' f = fromMaybe 0 (unB64I . f <$> opt)+      unB64I (Types.Base64Integer x) = x+ rsaPrivateKey _ = Left $ KeyMismatch "not an RSA private key"  rsaPublicKey :: RSAKeyParameters -> RSA.PublicKey

@@ -35,7 +35,7 @@   ) where  import Control.Applicative-import Control.Arrow+import Data.Bifunctor import Data.Maybe (catMaybes)  import Data.Aeson

@@ -1,4 +1,4 @@--- Copyright (C) 2013  Fraser Tweedale+-- 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.@@ -26,6 +26,9 @@   , JWS(..)   , jwsPayload   , signJWS++  , ValidationAlgorithms(..)+  , ValidationPolicy(..)   , verifyJWS   ) where 

@@ -12,19 +12,23 @@ -- See the License for the specific language governing permissions and -- limitations under the License. +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-} {-# OPTIONS_HADDOCK hide #-}  module Crypto.JOSE.JWS.Internal where +import Prelude hiding (mapM)+ import Control.Applicative-import Control.Arrow+import Control.Monad ((>=>), when, unless)+import Data.Bifunctor import Data.Char import Data.Maybe +import Control.Lens ((^.)) import Data.Aeson-import Data.Aeson.Parser+import qualified Data.Aeson.Parser as P import Data.Aeson.Types import qualified Data.Attoparsec.ByteString.Lazy as A import Data.Byteable@@ -32,11 +36,12 @@ import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Base64.URL as B64U import qualified Data.ByteString.Base64.URL.Lazy as B64UL-import qualified Data.HashMap.Strict as M+import Data.Default.Class+import Data.HashMap.Strict (member)+import Data.List.NonEmpty (NonEmpty(..), toList) import qualified Data.Text as T-import qualified Data.Text.Encoding as E-import Data.Traversable (sequenceA)-import qualified Data.Vector as V+import qualified Data.Text.Encoding as T+import Data.Traversable (mapM)  import Crypto.JOSE.Classes import Crypto.JOSE.Compact@@ -45,6 +50,7 @@ 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]@@ -62,86 +68,70 @@   , "crit"   ] -data CritParameters = CritParameters (M.HashMap T.Text Value)+newtype CritParameters = CritParameters (NonEmpty (T.Text, Value))   deriving (Eq, Show) -critObjectParser :: M.HashMap T.Text Value -> Value -> Parser (T.Text, Value)-critObjectParser o (String s)+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-critObjectParser _ _          = fail "crit key is not text" --- TODO implement array length >= 1 restriction+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 ->-    case M.lookup "crit" o of-      Just (Array paramNames)-        | V.null paramNames -> fail "crit cannot be empty"-        | otherwise -> fmap (CritParameters . M.fromList)-          $ sequenceA-          $ map (critObjectParser o)-          $ V.toList paramNames-      _ -> fail "crit is not an array")+  parseJSON = withObject "crit" $ \o -> o .: "crit" >>= parseCrit o  instance ToJSON CritParameters where-  toJSON (CritParameters m) = Object $ M.insert "crit" (toJSON $ M.keys m) m+  toJSON (CritParameters m) = object $ ("crit", toJSON $ fmap fst m) : toList m   -- | JWS Header data type. data JWSHeader = JWSHeader-  { headerAlg :: JWA.JWS.Alg+  { headerAlg :: Maybe JWA.JWS.Alg   , headerJku :: Maybe Types.URI  -- ^ JWK Set URL   , headerJwk :: Maybe JWK   , headerKid :: Maybe String  -- ^ interpretation unspecified   , headerX5u :: Maybe Types.URI-  , headerX5c :: Maybe [Types.Base64X509] -- ^ TODO implement min len of 1+  , headerX5c :: Maybe (NonEmpty Types.Base64X509)   , headerX5t :: Maybe Types.Base64SHA1   , headerX5tS256 :: Maybe Types.Base64SHA256   , headerTyp :: Maybe String  -- ^ Content Type (of object)   , headerCty :: Maybe String  -- ^ Content Type (of payload)   , headerCrit :: Maybe CritParameters-  , headerRaw :: Maybe BS.ByteString  -- ^ protected header, if known   }-  deriving (Show)--instance Eq JWSHeader where-  a == b =-    let-      ignoreRaw (JWSHeader alg jku jwk kid x5u x5c x5t x5tS256 typ cty crit _)-        = (alg, jku, jwk, kid, x5u, x5c, x5t, x5tS256, typ, cty, crit)-    in-      ignoreRaw a == ignoreRaw b+  deriving (Eq, Show) -parseHeaderWith-  :: (forall a. FromJSON a => T.Text -> Parser a)-  -> (forall a. FromJSON a => T.Text -> Parser (Maybe a))-  -> Parser (Maybe CritParameters)-  -> Parser JWSHeader-parseHeaderWith req opt crit = JWSHeader-    <$> req "alg"-    <*> opt "jku"-    <*> opt "jwk"-    <*> opt "kid"-    <*> opt "x5u"-    <*> opt "x5t"-    <*> opt "x5t#S256"-    <*> opt "x5c"-    <*> opt "typ"-    <*> opt "cty"-    <*> crit-    <*> pure Nothing+instance FromArmour T.Text Error JWSHeader where+  parseArmour s =+        first (compactErr "header")+          (B64UL.decode (pad $ BSL.fromStrict $ 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 '=' -parseCrit :: Object -> Parser (Maybe CritParameters)-parseCrit o = if M.member "crit" o-  then Just <$> parseJSON (Object o)-  else pure Nothing+instance ToArmour T.Text JWSHeader where+  toArmour = T.decodeUtf8 . Types.unpad . B64U.encode . BSL.toStrict . encode  instance FromJSON JWSHeader where-  parseJSON = withObject "JWS Header" (\o ->-    parseHeaderWith (o .:) (o .:?) (parseCrit o))+  parseJSON = withObject "JWS Header" $ \o -> JWSHeader+    <$> o .:? "alg"+    <*> o .:? "jku"+    <*> o .:? "jwk"+    <*> o .:? "kid"+    <*> o .:? "x5u"+    <*> o .:? "x5t"+    <*> o .:? "x5t#S256"+    <*> o .:? "x5c"+    <*> o .:? "typ"+    <*> o .:? "cty"+    <*> (o .:? "crit" >>= mapM (parseCrit o))  instance ToJSON JWSHeader where-  toJSON (JWSHeader alg jku jwk kid x5u x5c x5t x5tS256 typ cty crit _) =+  toJSON (JWSHeader alg jku jwk kid x5u x5c x5t x5tS256 typ cty crit) =     object $ catMaybes       [ Just ("alg" .= alg)       , fmap ("jku" .=) jku@@ -155,63 +145,52 @@       , fmap ("cty" .=) cty       ] ++ Types.objectPairs (toJSON crit) +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 = JWSHeader alg n n n n n n n n n n n where n = Nothing---(.::) :: (FromJSON a) => Object -> Object -> T.Text -> Parser a-(.::) o1 o2 k = case (M.lookup k o1, M.lookup k o2) of-  (Just _, Just _)  -> fail $ "key " ++ show k ++ " cannot appear twice"-  (Just v, _)       -> parseJSON v-  (_, Just v)       -> parseJSON v-  _                 -> fail $ "key " ++ show k ++ " now present"--(.::?) :: (FromJSON a) => Object -> Object -> T.Text -> Parser (Maybe a)-(.::?) o1 o2 k = case (M.lookup k o1, M.lookup k o2) of-  (Just _, Just _)  -> fail $ "key " ++ show k ++ " cannot appear twice"-  (Just v, _)       -> parseJSON v-  (_, Just v)       -> parseJSON v-  _                 -> pure Nothing+algHeader alg = def { headerAlg = Just alg }  -data Signature = Signature JWSHeader Types.Base64Octets+data Signature = Signature+  (Maybe (Armour T.Text JWSHeader))+  (Maybe JWSHeader)+  Types.Base64Octets   deriving (Eq, Show) -parseHeader :: Maybe Object -> Maybe Object -> Parser JWSHeader-parseHeader (Just p) (Just u) = parseHeaderWith ((.::) p u) ((.::?) p u) (parseCrit p)-parseHeader (Just p) _ = parseHeaderWith (p .:) (p .:?) (parseCrit p)-parseHeader _ (Just u) = parseHeaderWith (u .:) (u .:?) (if M.member "crit" u-  then fail "crit MUST occur only with the JWS Protected Header"-  else pure Nothing)-parseHeader _ _ = fail "no protected or unprotected header given"---newtype JSONByteString = JSONByteString { bs :: BS.ByteString }+algorithm :: Signature -> Maybe JWA.JWS.Alg+algorithm (Signature h h' _) = (h >>= headerAlg . (^. value)) <|> (h' >>= headerAlg) -instance FromJSON JSONByteString where-  parseJSON = withText "JSON bytestring" (return . JSONByteString . E.encodeUtf8)+checkHeaders :: Signature -> Either Error Signature+checkHeaders sig@(Signature h h' _) = do+  unless (isJust h || isJust h') (Left JWSMissingHeader)+  unless (isJust $ algorithm sig) (Left JWSMissingAlg)+  when (isJust $ h' >>= headerCrit) (Left JWSCritUnprotected)+  when hasDup (Left JWSDuplicateHeaderParameter)+  return sig+  where+    isDup f = isJust (h >>= f . (^. value)) && isJust (h' >>= f)+    hasDup = or+      [ isDup headerAlg, isDup headerJku, isDup headerJwk+      , isDup headerKid, isDup headerX5u, isDup headerX5c+      , isDup headerX5t, isDup headerX5tS256, isDup headerTyp+      , isDup headerCty+      ]  instance FromJSON Signature where-  parseJSON = withObject "signature" (\o -> Signature-    <$> do-      protectedEncoded <- o .:? "protected"-      protectedJSON <- maybe-        (pure Nothing)-        (withText "base64 encoded header"-          (Types.parseB64Url (return . Just . JSONByteString)))-        protectedEncoded-      protected <- maybe-        (pure Nothing)-        (return . decode . BSL.fromStrict)-        (fmap bs protectedJSON)-      unprotected <- o .:? "header"-      parseHeader protected unprotected-    <*> o .: "signature")+  parseJSON =+    withObject "signature" (\o -> Signature+      <$> o .:? "protected"+      <*> o .:? "header"+      <*> o .: "signature"+    ) >=> either (fail . show) pure . checkHeaders  instance ToJSON Signature where-  toJSON (Signature h s) = object $ ("signature" .= s) : Types.objectPairs (toJSON h)+  toJSON (Signature h h' s) =+    object $ ("signature" .= s) :+      maybe [] (Types.objectPairs . toJSON . (^. value)) h+      ++ maybe [] (Types.objectPairs . toJSON) h'   -- | JSON Web Signature data type.  Consists of a payload and a@@ -221,10 +200,16 @@   deriving (Eq, Show)  instance FromJSON JWS where-  parseJSON = withObject "JWS JSON serialization" (\o -> JWS-    <$> o .: "payload"-    <*> o .: "signatures")+  parseJSON v =+    withObject "JWS JSON serialization" (\o -> JWS+      <$> o .: "payload"+      <*> o .: "signatures") v+    <|> withObject "Flattened JWS JSON serialization" (\o ->+      if member "signatures" o+      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] @@ -233,12 +218,9 @@ jwsPayload :: JWS -> BSL.ByteString jwsPayload (JWS (Types.Base64Octets s) _) = BSL.fromStrict s --signingInput :: JWSHeader -> Types.Base64Octets -> BS.ByteString+signingInput :: Maybe (Armour T.Text JWSHeader) -> Types.Base64Octets -> BS.ByteString signingInput h p = BS.intercalate "."-  [ fromMaybe-    (Types.unpad $ B64U.encode $ BSL.toStrict $ encode h)-    (headerRaw h)+  [ maybe "" (T.encodeUtf8 . (^. armour)) h   , toBytes p   ] @@ -248,7 +230,7 @@ -- signature and returns Nothing otherwise -- instance ToCompact JWS where-  toCompact (JWS p [Signature h s]) =+  toCompact (JWS p [Signature h _ s]) =     Right [BSL.fromStrict $ signingInput h p, BSL.fromStrict $ toBytes s]   toCompact (JWS _ xs) = Left $ CompactEncodeError $     "cannot compact serialize JWS with " ++ show (length xs) ++ " sigs"@@ -256,25 +238,18 @@ instance FromCompact JWS where   fromCompact xs = case xs of     [h, p, s] -> do-      h' <- (\h' -> h' { headerRaw = Just $ BSL.toStrict h })-        <$> decodeO "header" h+      h' <- decodeArmour $ T.decodeUtf8 $ BSL.toStrict h       p' <- decodeS "payload" p       s' <- decodeS "signature" s-      return $ JWS p' [Signature h' s']-    xs' -> compactErr "compact representation"+      return $ JWS p' [Signature (Just h') Nothing s']+    xs' -> Left $ compactErr "compact representation"       $ "expected 3 parts, got " ++ show (length xs')     where-      compactErr s = Left . CompactDecodeError . ((s ++ " decode failed: ") ++)-      jsonErr = Left . JSONDecodeError-      decodeO desc s =-        either (compactErr desc) Right (B64UL.decode (pad s))-        >>= either jsonErr Right . eitherDecode+      compactErr s = CompactDecodeError . ((s ++ " decode failed: ") ++)       decodeS desc s =-        either (compactErr desc) Right-          (A.eitherResult $ A.parse value $ BSL.intercalate s ["\"", "\""])-        >>= either jsonErr Right . parseEither parseJSON-      pad t = t `BSL.append` BSL.replicate ((4 - BSL.length t `mod` 4) `mod` 4) c-      c = fromIntegral $ ord '='+        first (compactErr desc)+          (A.eitherResult $ A.parse P.value $ BSL.intercalate s ["\"", "\""])+        >>= first JSONDecodeError . parseEither parseJSON   -- §5.1. Message Signing or MACing@@ -288,19 +263,66 @@   -> 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 (either Left (Right . appendSig)) $-  sign (headerAlg h) k g (signingInput h p)+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)   where-    appendSig sig = JWS p (Signature h (Types.Base64Octets sig):sigs)+    appendSig sig = JWS p (Signature h' Nothing (Types.Base64Octets sig):sigs)+    h' = Just $ Unarmoured h ++-- | Algorithms for which validation will be attempted.  The default+-- value includes all algorithms except 'None'.+--+newtype ValidationAlgorithms = ValidationAlgorithms [JWA.JWS.Alg]++instance Default ValidationAlgorithms where+  def = ValidationAlgorithms+    [ JWA.JWS.HS256, JWA.JWS.HS384, JWA.JWS.HS512+    , JWA.JWS.RS256, JWA.JWS.RS384, JWA.JWS.RS512+    , JWA.JWS.ES256, JWA.JWS.ES384, JWA.JWS.ES512+    , JWA.JWS.PS256, JWA.JWS.PS384, JWA.JWS.PS512+    ]++-- | Validation policy.  The default policy is 'AllValidated'.+--+data ValidationPolicy+  = AnyValidated+  -- ^ One successfully validated signature is sufficient+  | AllValidated+  -- ^ All signatures for which validation is attempted must be validated++instance Default ValidationPolicy where+  def = AllValidated++ -- | Verify a JWS. -- -- Verification succeeds if any signature on the JWS is successfully -- validated with the given 'Key'. ---verifyJWS :: JWK -> JWS -> Bool-verifyJWS k (JWS p sigs) = any ((== Right True) . verifySig k p) sigs+-- If only specific signatures need to be validated, and the+-- 'ValidationPolicy' argument is not enough to express this,+-- the caller is responsible for removing irrelevant signatures+-- prior to calling 'verifyJWS'.+--+verifyJWS+  :: ValidationAlgorithms+  -> ValidationPolicy+  -> JWK+  -> JWS+  -> Bool+verifyJWS (ValidationAlgorithms algs) policy k (JWS p sigs) =+  applyPolicy policy $ map validate $ filter shouldValidateSig sigs+  where+  shouldValidateSig = maybe False (`elem` algs) . algorithm+  applyPolicy AnyValidated xs = or xs+  applyPolicy AllValidated [] = False+  applyPolicy AllValidated xs = and xs+  validate = (== Right True) . verifySig k p  verifySig :: JWK -> Types.Base64Octets -> Signature -> Either Error Bool-verifySig k m (Signature h (Types.Base64Octets s))-  = verify (headerAlg h) k (signingInput h m) s+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)+  (algorithm sig)

@@ -28,7 +28,7 @@   ) where  import Control.Applicative-import Control.Arrow+import Data.Bifunctor  import Data.Aeson import Data.Aeson.Types

@@ -33,6 +33,7 @@ import qualified Network.URI  import Crypto.JOSE.Types.Internal+import Crypto.JOSE.Types.Orphans ()   -- | A base64url encoded octet sequence interpreted as an integer.

@@ -0,0 +1,85 @@+-- Copyright (C) 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 MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE UndecidableInstances #-}++{-|++Implementation of "armoured values" with partial decoding.++For cases where a value is parsed from some representation, but the+precise representation that was used is also needed.  The original+representation of a parsed value can be accessed using the 'armour'+function, but it cannot be changed.++-}+module Crypto.JOSE.Types.Armour+  (+    Armour(Unarmoured)+  , FromArmour(..)+  , ToArmour(..)+  , decodeArmour+  , armour+  , value+  ) where++import Control.Applicative+import Control.Monad ((>=>))++import Control.Lens+import Data.Aeson+++-- | A value that can be "armoured", where the armour representation+-- is preserved when the value is parsed.+--+data Armour a b+  = Armoured a b+  | Unarmoured b+  deriving (Show)++instance Eq b => Eq (Armour a b) where+  a == b = a ^. value == b ^. value++-- | Lens for the unarmoured value.+--+value :: Lens' (Armour a b) b+value = lens (\case Armoured _ b -> b ; Unarmoured b -> b) (const Unarmoured)++-- | 'Getter' for the armour encoding.  If the armour was+-- remembered, it is returned unchanged.+--+armour :: ToArmour a b => Getter (Armour a b) a+armour = to (\case Armoured a _ -> a ; Unarmoured b -> toArmour b)+++class FromArmour a e b | a b -> e where+  parseArmour :: a -> Either e b+++class ToArmour a b where+  toArmour :: b -> a+++-- | Decode an armoured value, remembering the armour.+--+decodeArmour :: FromArmour a e b => a -> Either e (Armour a b)+decodeArmour a = Armoured a <$> parseArmour a+++instance (FromJSON a, Show e, FromArmour a e b) => FromJSON (Armour a b) where+  parseJSON = parseJSON >=> either (fail . show) pure . decodeArmour

@@ -0,0 +1,32 @@+-- Copyright (C) 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.++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Crypto.JOSE.Types.Orphans where++import qualified Data.Traversable as T+import Data.List.NonEmpty (NonEmpty(..), toList)++import Data.Aeson++import qualified Data.Vector as V++instance FromJSON a => FromJSON (NonEmpty a) where+  parseJSON = withArray "NonEmpty [a]" $ \v -> case V.toList v of+    [] -> fail "Non-empty list required"+    (x:xs) -> T.mapM parseJSON (x :| xs)++instance ToJSON a => ToJSON (NonEmpty a) where+  toJSON = Array . V.fromList . map toJSON . toList

@@ -31,12 +31,12 @@   , Audience(..)    , StringOrURI(..)-  , IntDate(..)+  , NumericDate(..)   ) where  import Control.Applicative-import Control.Arrow import Control.Monad+import Data.Bifunctor import Data.Maybe  import Data.Aeson@@ -72,14 +72,14 @@ -- | A JSON numeric value representing the number of seconds from --   1970-01-01T0:0:0Z UTC until the specified UTC date\/time. ---newtype IntDate = IntDate UTCTime deriving (Eq, Show)+newtype NumericDate = NumericDate UTCTime deriving (Eq, Show) -instance FromJSON IntDate where-  parseJSON = withScientific "IntDate" $-    pure . IntDate . posixSecondsToUTCTime . fromRational . toRational+instance FromJSON NumericDate where+  parseJSON = withScientific "NumericDate" $+    pure . NumericDate . posixSecondsToUTCTime . fromRational . toRational -instance ToJSON IntDate where-  toJSON (IntDate t)+instance ToJSON NumericDate where+  toJSON (NumericDate t)     = Number $ fromRational $ toRational $ utcTimeToPOSIXSeconds t  @@ -121,21 +121,21 @@   -- principal processing the claim does not identify itself with a   -- value in the /aud/ claim when this claim is present, then the   -- JWT MUST be rejected.-  , claimExp :: Maybe IntDate+  , claimExp :: Maybe NumericDate   -- ^ The expiration time claim identifies the expiration time on   -- or after which the JWT MUST NOT be accepted for processing.   -- The processing of /exp/ claim requires that the current   -- date\/time MUST be before expiration date\/time listed in the   -- /exp/ claim.  Implementers MAY provide for some small leeway,   -- usually no more than a few minutes, to account for clock skew.-  , claimNbf :: Maybe IntDate+  , claimNbf :: Maybe NumericDate   -- ^ The not before claim identifies the time before which the JWT   -- MUST NOT be accepted for processing.  The processing of the   -- /nbf/ claim requires that the current date\/time MUST be after   -- or equal to the not-before date\/time listed in the /nbf/   -- claim.  Implementers MAY provide for some small leeway, usually   -- no more than a few minutes, to account for clock skew.-  , claimIat :: Maybe IntDate+  , claimIat :: Maybe NumericDate   -- ^ The issued at claim identifies the time at which the JWT was   -- issued.  This claim can be used to determine the age of the   -- JWT.@@ -204,7 +204,7 @@ instance FromCompact JWT where   fromCompact = fromCompact >=> toJWT where     toJWT (JWTJWS jws) =-      either (Left . CompactDecodeError) (Right . JWT (JWTJWS jws))+      bimap CompactDecodeError (JWT (JWTJWS jws))         $ eitherDecode $ jwsPayload jws  instance ToCompact JWT where@@ -213,8 +213,13 @@  -- | Validate a JWT as a JWS (JSON Web Signature). ---validateJWSJWT :: JWK -> JWT -> Bool-validateJWSJWT k (JWT (JWTJWS jws) _) = verifyJWS k jws+validateJWSJWT+  :: ValidationAlgorithms+  -> ValidationPolicy+  -> JWK+  -> JWT+  -> Bool+validateJWSJWT algs policy k (JWT (JWTJWS jws) _) = verifyJWS algs policy k jws  -- | Create a JWT that is a JWS. --