diff --git a/jose.cabal b/jose.cabal --- a/jose.cabal +++ b/jose.cabal @@ -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 diff --git a/src/Crypto/JOSE/Error.hs b/src/Crypto/JOSE/Error.hs --- a/src/Crypto/JOSE/Error.hs +++ b/src/Crypto/JOSE/Error.hs @@ -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) diff --git a/src/Crypto/JOSE/JWA/JWK.hs b/src/Crypto/JOSE/JWA/JWK.hs --- a/src/Crypto/JOSE/JWA/JWK.hs +++ b/src/Crypto/JOSE/JWA/JWK.hs @@ -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 diff --git a/src/Crypto/JOSE/JWK.hs b/src/Crypto/JOSE/JWK.hs --- a/src/Crypto/JOSE/JWK.hs +++ b/src/Crypto/JOSE/JWK.hs @@ -35,7 +35,7 @@ ) where import Control.Applicative -import Control.Arrow +import Data.Bifunctor import Data.Maybe (catMaybes) import Data.Aeson diff --git a/src/Crypto/JOSE/JWS.hs b/src/Crypto/JOSE/JWS.hs --- a/src/Crypto/JOSE/JWS.hs +++ b/src/Crypto/JOSE/JWS.hs @@ -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 diff --git a/src/Crypto/JOSE/JWS/Internal.hs b/src/Crypto/JOSE/JWS/Internal.hs --- a/src/Crypto/JOSE/JWS/Internal.hs +++ b/src/Crypto/JOSE/JWS/Internal.hs @@ -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) diff --git a/src/Crypto/JOSE/Legacy.hs b/src/Crypto/JOSE/Legacy.hs --- a/src/Crypto/JOSE/Legacy.hs +++ b/src/Crypto/JOSE/Legacy.hs @@ -28,7 +28,7 @@ ) where import Control.Applicative -import Control.Arrow +import Data.Bifunctor import Data.Aeson import Data.Aeson.Types diff --git a/src/Crypto/JOSE/Types.hs b/src/Crypto/JOSE/Types.hs --- a/src/Crypto/JOSE/Types.hs +++ b/src/Crypto/JOSE/Types.hs @@ -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. diff --git a/src/Crypto/JOSE/Types/Armour.hs b/src/Crypto/JOSE/Types/Armour.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/JOSE/Types/Armour.hs @@ -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 diff --git a/src/Crypto/JOSE/Types/Orphans.hs b/src/Crypto/JOSE/Types/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/JOSE/Types/Orphans.hs @@ -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 diff --git a/src/Crypto/JWT.hs b/src/Crypto/JWT.hs --- a/src/Crypto/JWT.hs +++ b/src/Crypto/JWT.hs @@ -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. --