jose 0.1.27.0 → 0.2.31.0
raw patch · 16 files changed
+781/−297 lines, 16 filesdep +crypto-pubkey-typesdep +old-localedep +timedep ~crypto-pubkey
Dependencies added: crypto-pubkey-types, old-locale, time
Dependency ranges changed: crypto-pubkey
Files
- README.md +9/−3
- jose.cabal +23/−10
- src/Crypto/JOSE.hs +35/−0
- src/Crypto/JOSE/Classes.hs +30/−4
- src/Crypto/JOSE/Compact.hs +7/−5
- src/Crypto/JOSE/Error.hs +41/−0
- src/Crypto/JOSE/JWA/JWK.hs +256/−126
- src/Crypto/JOSE/JWK.hs +9/−14
- src/Crypto/JOSE/JWS.hs +1/−1
- src/Crypto/JOSE/JWS/Internal.hs +72/−64
- src/Crypto/JOSE/Legacy.hs +25/−45
- src/Crypto/JOSE/TH.hs +9/−5
- src/Crypto/JOSE/Types.hs +17/−12
- src/Crypto/JOSE/Types/Internal.hs +12/−7
- src/Crypto/JWT.hs +231/−0
- test/Test.hs +4/−1
README.md view
@@ -1,6 +1,12 @@-# jose - Javascript Object Signing and Encryption+# jose - Javascript Object Signing and Encryption & JWT (JSON Web Token) jose is a Haskell implementation of [Javascript Object Signing and-Encryption](https://datatracker.ietf.org/wg/jose/).+Encryption](https://datatracker.ietf.org/wg/jose/) and [JSON Web+Token]+(https://datatracker.ietf.org/doc/draft-ietf-oauth-json-web-token/). -The library is in its infancy. Contributions are welcome.+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.++Contributions are welcome.
jose.cabal view
@@ -1,17 +1,22 @@ name: jose-version: 0.1.27.0-synopsis: Javascript Object Signing and Encryption+version: 0.2.31.0+synopsis:+ Javascript Object Signing and Encryption and JSON Web Token library description: . An implementation of the Javascript Object Signing and Encryption- (jose) formats.+ (JOSE) and JSON Web Token (JWT) formats. .- Currently, only JSON Web Key (JWK) and JSON Web Signature (JWS)- are implemented, and only the RSA algorithms.+ Web Encryption (JWE) is not yet implemented. .+ All JWS algorithms (HMAC, ECDSA, RSASSA-PKCS-v1_5 and RSASSA-PSS)+ are implemented, however, the ECDSA implementation is is+ vulnerable to timing attacks and should therefore only be used for+ JWS verification.+ . The version number tracks the IETF jose working group draft revisions. For now, expect breaking API changes on any version- change except for the final part being incremented.+ change except for the final (fourth) part being incremented. homepage: https://github.com/frasertweedale/hs-jose bug-reports: https://github.com/frasertweedale/hs-jose/issues@@ -28,16 +33,19 @@ library exposed-modules:+ Crypto.JOSE Crypto.JOSE.Classes Crypto.JOSE.Compact- Crypto.JOSE.Types- Crypto.JOSE.JWA.JWK- Crypto.JOSE.JWA.JWS+ Crypto.JOSE.Error Crypto.JOSE.JWK Crypto.JOSE.JWS Crypto.JOSE.Legacy+ Crypto.JOSE.Types+ Crypto.JWT other-modules:+ Crypto.JOSE.JWA.JWK+ Crypto.JOSE.JWA.JWS Crypto.JOSE.JWA.JWE Crypto.JOSE.JWA.JWE.Alg Crypto.JOSE.JWS.Internal@@ -49,7 +57,8 @@ , attoparsec , base64-bytestring == 1.0.* , byteable == 0.1.*- , crypto-pubkey == 0.2.*+ , crypto-pubkey >= 0.2.3+ , crypto-pubkey-types >= 0.3.2 , crypto-random == 0.0.7.* , cryptohash == 0.11.* , template-haskell >= 2.4@@ -57,6 +66,7 @@ , unordered-containers == 0.2.* , bytestring == 0.10.* , text == 1.1.*+ , time == 1.4.* , network >= 2.4 , certificate == 1.3.* , vector@@ -79,13 +89,16 @@ , base64-bytestring , byteable , crypto-pubkey+ , crypto-pubkey-types , crypto-random , cryptohash+ , old-locale , template-haskell , aeson , unordered-containers , bytestring , text+ , time , network , certificate , vector
+ src/Crypto/JOSE.hs view
@@ -0,0 +1,35 @@+-- 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.++{-|++Prelude for the library.++-}+module Crypto.JOSE+ (+ module Crypto.JOSE.Classes+ , 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+import Crypto.JOSE.JWS++{-# ANN module ("HLint: ignore Use import/export shortcut" :: String) #-}
src/Crypto/JOSE/Classes.hs view
@@ -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.@@ -12,20 +12,46 @@ -- 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 where+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- sign :: JWA.JWS.Alg -> k -> B.ByteString -> B.ByteString- verify :: JWA.JWS.Alg -> k -> B.ByteString -> B.ByteString -> Bool+ 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
src/Crypto/JOSE/Compact.hs view
@@ -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.@@ -25,24 +25,26 @@ import qualified Data.ByteString.Lazy as L +import Crypto.JOSE.Error + -- | Data that can be parsed from a compact representation. -- class FromCompact a where- fromCompact :: [L.ByteString] -> Either String a+ fromCompact :: [L.ByteString] -> Either Error a -- | Decode a compact representation. ---decodeCompact :: FromCompact a => L.ByteString -> Either String a+decodeCompact :: FromCompact a => L.ByteString -> Either Error a decodeCompact = fromCompact . L.split 46 -- | Data that can be converted to a compact representation. -- class ToCompact a where- toCompact :: a -> Either String [L.ByteString]+ toCompact :: a -> Either Error [L.ByteString] -- | Encode data to a compact representation. ---encodeCompact :: ToCompact a => a -> Either String L.ByteString+encodeCompact :: ToCompact a => a -> Either Error L.ByteString encodeCompact = fmap (L.intercalate ".") . toCompact
+ src/Crypto/JOSE/Error.hs view
@@ -0,0 +1,41 @@+-- 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.++{-|++JOSE error types.++-}+module Crypto.JOSE.Error+ (+ Error(..)+ ) where++import qualified Crypto.PubKey.RSA as RSA++-- | All the errors that can occur, with the notable exception of+-- 'Data.Aeson' decoding functions. Aeson decoding errors that+-- occur in 'decodeCompact' are, however, lifted into this type+-- via the 'JSONDecodeError' constructor.+--+data Error+ = AlgorithmNotImplemented -- ^ A requested algorithm is not implemented+ | AlgorithmMismatch String -- ^ A requested algorithm cannot be used+ | KeyMismatch String -- ^ Wrong type of key was given+ | KeySizeTooSmall -- ^ Key size is too small+ | 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+ deriving (Eq, Show)
src/Crypto/JOSE/JWA/JWK.hs view
@@ -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.@@ -15,6 +15,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-} {-| @@ -33,29 +35,34 @@ -- * Parameters for RSA Keys , RSAPrivateKeyOthElem(..) , RSAPrivateKeyOptionalParameters(..)+ , RSAPrivateKeyParameters(..) , RSAKeyParameters(..)- , genRSAParams- , genRSA -- * Parameters for Symmetric Keys , OctKeyParameters(..) + , KeyMaterialGenParam(..) , KeyMaterial(..) ) where import Control.Applicative import Control.Arrow+import Data.Maybe import Crypto.Hash import Crypto.PubKey.HashDescr-import Crypto.PubKey.RSA-import qualified Crypto.PubKey.RSA.PKCS15+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA+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 Crypto.Random import Data.Aeson import Data.Byteable import qualified Data.ByteString as B import qualified Data.HashMap.Strict as M +import Crypto.JOSE.Error import Crypto.JOSE.Classes import qualified Crypto.JOSE.JWA.JWS as JWA.JWS import qualified Crypto.JOSE.TH@@ -122,154 +129,265 @@ , "q" .= rsaQ , "dp" .= rsaDp , "dq" .= rsaDq- , "dq" .= rsaQi+ , "qi" .= rsaQi ] ++ maybe [] ((:[]) . ("oth" .=)) rsaOth +-- | RSA private key parameters+--+data RSAPrivateKeyParameters = RSAPrivateKeyParameters+ { rsaD :: Types.Base64Integer+ , rsaOptionalParameters :: Maybe RSAPrivateKeyOptionalParameters+ }+ deriving (Eq, Show)++instance FromJSON RSAPrivateKeyParameters where+ parseJSON = withObject "RSA private key parameters" $ \o ->+ RSAPrivateKeyParameters+ <$> o .: "d"+ <*> (if any (`M.member` o) ["p", "q", "dp", "dq", "qi", "oth"]+ then Just <$> parseJSON (Object o)+ else pure Nothing)++instance ToJSON RSAPrivateKeyParameters where+ toJSON RSAPrivateKeyParameters {..} = object $+ ("d" .= rsaD) : maybe [] (Types.objectPairs . toJSON) rsaOptionalParameters++ -- | Parameters for Elliptic Curve Keys ---data ECKeyParameters =- ECPrivateKeyParameters {- ecD :: Types.SizedBase64Integer- }- | ECPublicKeyParameters {- ecCrv :: Crv,- ecX :: Types.SizedBase64Integer,- ecY :: Types.SizedBase64Integer- }+data ECKeyParameters = ECKeyParameters+ {+ ecKty :: EC+ , ecCrv :: Crv+ , ecX :: Types.SizedBase64Integer+ , ecY :: Types.SizedBase64Integer+ , ecD :: Maybe Types.SizedBase64Integer+ } deriving (Eq, Show) instance FromJSON ECKeyParameters where- parseJSON = withObject "EC" (\o ->- ECPrivateKeyParameters <$> o .: "d"- <|> ECPublicKeyParameters <$> o .: "crv" <*> o .: "x" <*> o .: "y")+ parseJSON = withObject "EC" $ \o -> ECKeyParameters+ <$> o .: "kty"+ <*> o .: "crv"+ <*> o .: "x"+ <*> o .: "y"+ <*> o .:? "d" instance ToJSON ECKeyParameters where- toJSON (ECPrivateKeyParameters d) = object ["d" .= d]- toJSON (ECPublicKeyParameters {..}) = object [- "crv" .= ecCrv+ toJSON (ECKeyParameters {..}) = object $+ [ "crv" .= ecCrv , "x" .= ecX , "y" .= ecY- ]+ ] ++ fmap ("d" .=) (maybeToList ecD) instance Key ECKeyParameters where- sign = error "elliptic curve algorithms not implemented"- verify = error "elliptic curve algorithms not implemented"+ 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" +signEC+ :: CPRG g+ => HashDescr+ -> 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+ sigToBS (ECDSA.Signature r s) =+ Types.integerToBS r `B.append` Types.integerToBS s+ privateKey = ECDSA.PrivateKey (curve k) (d ecD')+ d (Types.SizedBase64Integer _ n) = n+ Nothing -> (Left $ KeyMismatch "not an EC private key", g) +verifyEC+ :: HashDescr+ -> ECKeyParameters+ -> B.ByteString+ -> B.ByteString+ -> Either Error Bool+verifyEC h k m s = Right $ ECDSA.verify (hashFunction h) pubkey sig m+ where+ pubkey = ECDSA.PublicKey (curve k) (point k)+ sig = uncurry ECDSA.Signature+ $ Types.bsToInteger *** Types.bsToInteger+ $ B.splitAt (B.length s `div` 2) s++curve :: ECKeyParameters -> ECC.Curve+curve ECKeyParameters {..} = ECC.getCurveByName (curveName ecCrv) where+ curveName P_256 = ECC.SEC_p256r1+ curveName P_384 = ECC.SEC_p384r1+ curveName P_521 = ECC.SEC_p521r1++point :: ECKeyParameters -> ECC.Point+point ECKeyParameters {..} = ECC.Point (integer ecX) (integer ecY) where+ integer (Types.SizedBase64Integer _ n) = n++ -- | Parameters for RSA Keys ---data RSAKeyParameters =- RSAPrivateKeyParameters {- rsaN :: Types.SizedBase64Integer- , rsaE :: Types.Base64Integer- , rsaD :: Types.Base64Integer- , rsaOptionalParameters :: Maybe RSAPrivateKeyOptionalParameters- }- | RSAPublicKeyParameters {- rsaN' :: Types.SizedBase64Integer- , rsaE' :: Types.Base64Integer- }+data RSAKeyParameters = RSAKeyParameters+ { rsaKty :: RSA+ , rsaN :: Types.SizedBase64Integer+ , rsaE :: Types.Base64Integer+ , rsaPrivateKeyParameters :: Maybe RSAPrivateKeyParameters+ } deriving (Eq, Show) instance FromJSON RSAKeyParameters where- parseJSON = withObject "RSA" (\o ->- RSAPrivateKeyParameters- <$> o .: "n"+ parseJSON = withObject "RSA" $ \o ->+ RSAKeyParameters+ <$> o .: "kty"+ <*> o .: "n" <*> o .: "e"- <*> o .: "d"- <*> (if any (`M.member` o) ["p", "q", "dp", "dq", "qi", "oth"]+ <*> if M.member "d" o then Just <$> parseJSON (Object o)- else pure Nothing)- <|> RSAPublicKeyParameters <$> o .: "n" <*> o .: "e")+ else pure Nothing instance ToJSON RSAKeyParameters where- toJSON (RSAPrivateKeyParameters {..}) = object $- ("n" .= rsaN)+ toJSON RSAKeyParameters {..} = object $+ ("kty" .= rsaKty)+ : ("n" .= rsaN) : ("e" .= rsaE)- : ("d" .= rsaD)- : maybe [] (Types.objectPairs . toJSON) rsaOptionalParameters- toJSON (RSAPublicKeyParameters n e) = object ["n" .= n, "e" .= e]+ : maybe [] (Types.objectPairs . toJSON) rsaPrivateKeyParameters instance Key RSAKeyParameters where- sign JWA.JWS.RS256 = signRSA hashDescrSHA256- sign JWA.JWS.RS384 = signRSA hashDescrSHA384- sign JWA.JWS.RS512 = signRSA hashDescrSHA512- sign h = error $ "alg/key mismatch: " ++ show h ++ "/RSA"- verify JWA.JWS.RS256 = verifyRSA hashDescrSHA256- verify JWA.JWS.RS384 = verifyRSA hashDescrSHA384- verify JWA.JWS.RS512 = verifyRSA hashDescrSHA512- verify h = error $ "alg/key mismatch: " ++ show h ++ "/RSA"+ 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+ 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" -signRSA :: HashDescr -> RSAKeyParameters -> B.ByteString -> B.ByteString-signRSA h k m = either (error . show) id $- Crypto.PubKey.RSA.PKCS15.sign Nothing h (privateKey k) m where- privateKey (RSAPrivateKeyParameters- (Types.SizedBase64Integer size n)- (Types.Base64Integer e)- (Types.Base64Integer d)- _) = PrivateKey (PublicKey size n e) d 0 0 0 0 0- privateKey _ = error "not an RSA private key"+signPKCS15+ :: CPRG g+ => HashDescr+ -> 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 (either (Left . RSAError) Right) $+ PKCS15.signSafer g h k' m -verifyRSA+verifyPKCS15 :: HashDescr -> RSAKeyParameters -> B.ByteString -> B.ByteString- -> Bool-verifyRSA h k = Crypto.PubKey.RSA.PKCS15.verify h (publicKey k) where- publicKey (RSAPrivateKeyParameters- (Types.SizedBase64Integer size n)- (Types.Base64Integer e)- _- _- ) = PublicKey size n e- publicKey (RSAPublicKeyParameters- (Types.SizedBase64Integer size n)- (Types.Base64Integer e)- ) = PublicKey size n e+ -> Either Error Bool+verifyPKCS15 h k m = Right . PKCS15.verify h (rsaPublicKey k) m --- | Generate RSA public and private key parameters.----genRSAParams :: Int -> IO (RSAKeyParameters, RSAKeyParameters)-genRSAParams size =- let- i = Types.Base64Integer- si = Types.SizedBase64Integer- in do- ent <- createEntropyPool- ((PublicKey s n e, PrivateKey _ d p q dp dq qi), _) <-- return $ generate (cprgCreate ent :: SystemRNG) size 65537- return- ( RSAPublicKeyParameters (si s n) (i e)- , RSAPrivateKeyParameters (si s n) (i e) (i d)- (Just (RSAPrivateKeyOptionalParameters- (i p) (i q) (i dp) (i dq) (i qi) Nothing))- )+signPSS+ :: CPRG g+ => HashDescr+ -> 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 (either (Left . RSAError) Right) $+ PSS.signSafer g (PSS.defaultPSSParams (hashFunction h)) k' m --- | Generate RSA public and private key material.----genRSA :: Int -> IO (KeyMaterial, KeyMaterial)-genRSA = fmap (RSAKeyMaterial RSA *** RSAKeyMaterial RSA) . genRSAParams+verifyPSS+ :: HashDescr+ -> RSAKeyParameters+ -> B.ByteString+ -> B.ByteString+ -> Either Error Bool+verifyPSS h k m = Right .+ PSS.verify (PSS.defaultPSSParams (hashFunction h)) (rsaPublicKey k) m +rsaPrivateKey :: RSAKeyParameters -> Either Error RSA.PrivateKey+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+rsaPrivateKey _ = Left $ KeyMismatch "not an RSA private key" +rsaPublicKey :: RSAKeyParameters -> RSA.PublicKey+rsaPublicKey (RSAKeyParameters _+ (Types.SizedBase64Integer size n) (Types.Base64Integer e) _)+ = RSA.PublicKey size n e++ -- | Symmetric key parameters data. ---newtype OctKeyParameters = OctKeyParameters Types.Base64Octets+data OctKeyParameters = OctKeyParameters+ { octKty :: Oct+ , octK :: Types.Base64Octets+ } deriving (Eq, Show) instance FromJSON OctKeyParameters where- parseJSON = (OctKeyParameters <$>) . parseJSON+ parseJSON = withObject "symmetric key" $ \o ->+ OctKeyParameters <$> o .: "kty" <*> o .: "k" instance ToJSON OctKeyParameters where- toJSON (OctKeyParameters k) = toJSON k+ toJSON OctKeyParameters {..} = object ["kty" .= octKty, "k" .= octK] instance Key OctKeyParameters where- sign JWA.JWS.HS256 = signOct SHA256- sign JWA.JWS.HS384 = signOct SHA384- sign JWA.JWS.HS512 = signOct SHA512- sign h = error $ "alg/key mismatch: " ++ show h ++ "/Oct"- verify h k m s = sign h k m == s+ type KeyGenParam OctKeyParameters = Int+ type KeyContent OctKeyParameters = Types.Base64Octets+ gen = undefined -- TODO implement+ fromKeyContent = OctKeyParameters Oct+ 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 . (== s) signOct :: HashAlgorithm a@@ -277,34 +395,46 @@ -> OctKeyParameters -> B.ByteString -> B.ByteString-signOct a (OctKeyParameters (Types.Base64Octets k)) m = toBytes $ hmacAlg a k m+signOct a (OctKeyParameters _ (Types.Base64Octets k)) m+ = toBytes $ hmacAlg a k m -- | Key material sum type. ---data KeyMaterial =- ECKeyMaterial EC ECKeyParameters- | RSAKeyMaterial RSA RSAKeyParameters- | OctKeyMaterial Oct OctKeyParameters+data KeyMaterial+ = ECKeyMaterial ECKeyParameters+ | RSAKeyMaterial RSAKeyParameters+ | OctKeyMaterial OctKeyParameters deriving (Eq, Show) instance FromJSON KeyMaterial where- parseJSON = withObject "KeyMaterial" (\o ->- ECKeyMaterial <$> o .: "kty" <*> parseJSON (Object o)- <|> RSAKeyMaterial <$> o .: "kty" <*> parseJSON (Object o)- <|> OctKeyMaterial <$> o .: "kty" <*> o .: "k")+ parseJSON = withObject "KeyMaterial" $ \o ->+ ECKeyMaterial <$> parseJSON (Object o)+ <|> RSAKeyMaterial <$> parseJSON (Object o)+ <|> OctKeyMaterial <$> parseJSON (Object o) instance ToJSON KeyMaterial where- toJSON (ECKeyMaterial k p) = object $ ("kty" .= k) : Types.objectPairs (toJSON p)- toJSON (RSAKeyMaterial k p) = object $ ("kty" .= k) : Types.objectPairs (toJSON p)- toJSON (OctKeyMaterial k i) = object ["kty" .= k, "k" .= i]+ toJSON (ECKeyMaterial p) = object $ Types.objectPairs (toJSON p)+ toJSON (RSAKeyMaterial p) = object $ Types.objectPairs (toJSON p)+ toJSON (OctKeyMaterial p) = object $ Types.objectPairs (toJSON p) +data KeyMaterialGenParam+ = ECGenParam Crv+ | RSAGenParam Int+ | OctGenParam Int+ instance Key KeyMaterial where- sign JWA.JWS.None _ = const ""- 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 -> s == ""- verify h (ECKeyMaterial _ k) = verify h k- verify h (RSAKeyMaterial _ k) = verify h k- verify h (OctKeyMaterial _ k) = verify h k+ 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+ 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
src/Crypto/JOSE/JWK.hs view
@@ -15,6 +15,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} {-| @@ -27,10 +28,10 @@ module Crypto.JOSE.JWK ( JWK(..)- , materialJWK- , genRSA , JWKSet(..)++ , module JWA.JWK ) where import Control.Applicative@@ -41,7 +42,7 @@ import Crypto.JOSE.Classes import qualified Crypto.JOSE.JWA.JWE.Alg as JWA.JWE-import qualified Crypto.JOSE.JWA.JWK as JWA.JWK+import Crypto.JOSE.JWA.JWK as JWA.JWK import qualified Crypto.JOSE.JWA.JWS as JWA.JWS import qualified Crypto.JOSE.TH import qualified Crypto.JOSE.Types as Types@@ -116,23 +117,17 @@ ++ Types.objectPairs (toJSON jwkMaterial) instance Key JWK where+ type KeyGenParam JWK = JWA.JWK.KeyMaterialGenParam+ type KeyContent JWK = JWA.JWK.KeyMaterial+ gen p = first fromKeyContent . gen p+ fromKeyContent k = JWK k z z z z z z z z where z = Nothing sign h k = sign h $ jwkMaterial k verify h k = verify h $ jwkMaterial k --- | Construct a minimal JWK from key material.----materialJWK :: JWA.JWK.KeyMaterial -> JWK-materialJWK m = JWK m n n n n n n n n where n = Nothing --- | Generate a /(public, private)/ RSA keypair.----genRSA :: Int -> IO (JWK, JWK)-genRSA = fmap (materialJWK *** materialJWK) . JWA.JWK.genRSA-- -- | JWK §4. JSON Web Key Set (JWK Set) Format ---data JWKSet = JWKSet [JWK]+newtype JWKSet = JWKSet [JWK] deriving (Eq, Show) instance FromJSON JWKSet where parseJSON = withObject "JWKSet" (\o -> JWKSet <$> o .: "keys")
src/Crypto/JOSE/JWS.hs view
@@ -21,7 +21,7 @@ -} module Crypto.JOSE.JWS (- Header(..)+ JWSHeader(..) , JWS(..) , jwsPayload
src/Crypto/JOSE/JWS/Internal.hs view
@@ -19,6 +19,7 @@ module Crypto.JOSE.JWS.Internal where import Control.Applicative+import Control.Arrow import Data.Char import Data.Maybe @@ -26,8 +27,10 @@ import Data.Aeson.Parser import Data.Aeson.Types import qualified Data.Attoparsec.ByteString.Lazy as A+import Data.Byteable import qualified Data.ByteString as BS 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 qualified Data.Text as T@@ -37,6 +40,7 @@ import Crypto.JOSE.Classes import Crypto.JOSE.Compact+import Crypto.JOSE.Error import qualified Crypto.JOSE.JWA.JWS as JWA.JWS import Crypto.JOSE.JWK import qualified Crypto.JOSE.Types as Types@@ -84,7 +88,7 @@ -- | JWS Header data type.-data Header = Header+data JWSHeader = JWSHeader { headerAlg :: JWA.JWS.Alg , headerJku :: Maybe Types.URI -- ^ JWK Set URL , headerJwk :: Maybe JWK@@ -100,10 +104,10 @@ } deriving (Show) -instance Eq Header where+instance Eq JWSHeader where a == b = let- ignoreRaw (Header alg jku jwk kid x5u x5c x5t x5tS256 typ cty crit _)+ 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@@ -112,8 +116,8 @@ :: (forall a. FromJSON a => T.Text -> Parser a) -> (forall a. FromJSON a => T.Text -> Parser (Maybe a)) -> Parser (Maybe CritParameters)- -> Parser Header-parseHeaderWith req opt crit = Header+ -> Parser JWSHeader+parseHeaderWith req opt crit = JWSHeader <$> req "alg" <*> opt "jku" <*> opt "jwk"@@ -132,29 +136,29 @@ then Just <$> parseJSON (Object o) else pure Nothing -instance FromJSON Header where+instance FromJSON JWSHeader where parseJSON = withObject "JWS Header" (\o -> parseHeaderWith (o .:) (o .:?) (parseCrit o)) -instance ToJSON Header where- toJSON (Header alg jku jwk kid x5u x5c x5t x5tS256 typ cty crit _) = object $ catMaybes [- Just ("alg" .= alg)- , 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)+instance ToJSON JWSHeader where+ toJSON (JWSHeader alg jku jwk kid x5u x5c x5t x5tS256 typ cty crit _) =+ object $ catMaybes+ [ Just ("alg" .= alg)+ , 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) -- construct a minimal header with the given alg-algHeader :: JWA.JWS.Alg -> Header-algHeader alg = Header alg n n n n n n n n n n n where n = Nothing+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@@ -172,10 +176,10 @@ _ -> pure Nothing -data Signature = Signature Header Types.Base64Octets+data Signature = Signature JWSHeader Types.Base64Octets deriving (Eq, Show) -parseHeader :: Maybe Object -> Maybe Object -> Parser Header+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@@ -230,28 +234,13 @@ jwsPayload (JWS (Types.Base64Octets s) _) = BSL.fromStrict s -encodeO :: ToJSON a => a -> BSL.ByteString-encodeO = BSL.reverse . BSL.dropWhile (== c) . BSL.reverse- . B64UL.encode . encode- where c = fromIntegral $ ord '='--decodeO :: FromJSON a => BSL.ByteString -> Either String a-decodeO s = B64UL.decode (pad s) >>= eitherDecode- where- pad t = t `BSL.append` BSL.replicate ((4 - BSL.length t `mod` 4) `mod` 4) c- c = fromIntegral $ ord '='--encodeS :: ToJSON a => a -> BSL.ByteString-encodeS = BSL.init . BSL.tail . encode--decodeS :: FromJSON a => BSL.ByteString -> Maybe a-decodeS s = do- v <- A.maybeResult $ A.parse value $ BSL.intercalate s ["\"", "\""]- parseMaybe parseJSON v--signingInput :: Header -> Types.Base64Octets -> BSL.ByteString-signingInput h p = BSL.intercalate "."- [maybe (encodeO h) BSL.fromStrict (headerRaw h), encodeS p]+signingInput :: JWSHeader -> Types.Base64Octets -> BS.ByteString+signingInput h p = BS.intercalate "."+ [ fromMaybe+ (Types.unpad $ B64U.encode $ BSL.toStrict $ encode h)+ (headerRaw h)+ , toBytes p+ ] -- Convert JWS to compact serialization. --@@ -259,17 +248,33 @@ -- signature and returns Nothing otherwise -- instance ToCompact JWS where- toCompact (JWS p [Signature h s]) = Right [signingInput h p, encodeS s]- toCompact (JWS _ xs) =- Left $ "cannot compact serialize JWS with " ++ show (length xs) ++ " sigs"+ 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" instance FromCompact JWS where- fromCompact [h, p, s] = do- h' <- (\h' -> h' { headerRaw = Just $ BSL.toStrict h }) <$> decodeO h- p' <- maybe (Left "payload decode failed") Right $ decodeS p- s' <- maybe (Left "sig decode failed") Right $ decodeS s- return $ JWS p' [Signature h' s']- fromCompact xs = Left $ "expected 3 parts, got " ++ show (length xs)+ fromCompact xs = case xs of+ [h, p, s] -> do+ h' <- (\h' -> h' { headerRaw = Just $ BSL.toStrict h })+ <$> decodeO "header" h+ p' <- decodeS "payload" p+ s' <- decodeS "signature" s+ return $ JWS p' [Signature h' s']+ xs' -> 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+ 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 '=' -- §5.1. Message Signing or MACing@@ -277,13 +282,16 @@ -- | Create a new signature on a JWS. -- signJWS- :: JWS -- ^ JWS to sign- -> Header -- ^ Header for signature+ :: CPRG g+ => g -- ^ Random number generator+ -> JWS -- ^ JWS to sign+ -> JWSHeader -- ^ Header for signature -> JWK -- ^ Key with which to sign- -> JWS -- ^ JWS with new signature appended-signJWS (JWS p sigs) h k = JWS p (sig:sigs) where- sig = Signature h $ Types.Base64Octets $- sign (headerAlg h) k (BSL.toStrict $ signingInput h p)+ -> (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)+ where+ appendSig sig = JWS p (Signature h (Types.Base64Octets sig):sigs) -- | Verify a JWS. --@@ -291,8 +299,8 @@ -- validated with the given 'Key'. -- verifyJWS :: JWK -> JWS -> Bool-verifyJWS k (JWS p sigs) = any (verifySig k p) sigs+verifyJWS k (JWS p sigs) = any ((== Right True) . verifySig k p) sigs -verifySig :: JWK -> Types.Base64Octets -> Signature -> Bool+verifySig :: JWK -> Types.Base64Octets -> Signature -> Either Error Bool verifySig k m (Signature h (Types.Base64Octets s))- = verify (headerAlg h) k (BSL.toStrict $ signingInput h m) s+ = verify (headerAlg h) k (signingInput h m) s
src/Crypto/JOSE/Legacy.hs view
@@ -14,6 +14,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} {-| @@ -24,13 +25,13 @@ module Crypto.JOSE.Legacy ( JWK'- , genRSA' ) where import Control.Applicative import Control.Arrow import Data.Aeson+import Data.Aeson.Types import Crypto.JOSE.Classes import Crypto.JOSE.JWA.JWK@@ -41,50 +42,33 @@ $(Crypto.JOSE.TH.deriveJOSEType "RS" ["RS"]) -newtype RSAKeyParameters' = RSAKeyParameters' RSAKeyParameters+newtype RSKeyParameters = RSKeyParameters RSAKeyParameters deriving (Eq, Show) -instance FromJSON RSAKeyParameters' where- parseJSON = withObject "RSA" (\o ->- RSAKeyParameters' <$> (RSAPrivateKeyParameters- <$> o .: "modulus"- <*> o .: "exponent"- <*> o .: "secretExponent"- <*> pure Nothing)- <|> RSAKeyParameters' <$> (RSAPublicKeyParameters- <$> o .: "modulus"- <*> o .: "exponent")- )--instance ToJSON RSAKeyParameters' where- toJSON (RSAKeyParameters' (RSAPrivateKeyParameters n e d _)) = object- ["modulus" .= n ,"exponent" .= e ,"secretExponent" .= d]- toJSON (RSAKeyParameters' (RSAPublicKeyParameters n e))- = object ["modulus" .= n, "exponent" .= e]--instance Key RSAKeyParameters' where- sign h (RSAKeyParameters' k) = sign h k- verify h (RSAKeyParameters' k) = verify h k---data KeyMaterial' = RSAKeyMaterial' RS RSAKeyParameters' deriving (Eq, Show)--instance FromJSON KeyMaterial' where- parseJSON = withObject "KeyMaterial'" (\o ->- RSAKeyMaterial' <$> o .: "algorithm" <*> parseJSON (Object o))+instance FromJSON RSKeyParameters where+ parseJSON = withObject "RS" $ \o -> fmap RSKeyParameters $ RSAKeyParameters+ <$> ((o .: "algorithm" :: Parser RS) *> pure RSA)+ <*> o .: "modulus"+ <*> o .: "exponent"+ <*> (fmap (`RSAPrivateKeyParameters` Nothing) <$> (o .:? "secretExponent")) -instance ToJSON KeyMaterial' where- toJSON (RSAKeyMaterial' a k)- = object $ ("algorithm" .= a) : Types.objectPairs (toJSON k)+instance ToJSON RSKeyParameters where+ toJSON (RSKeyParameters (RSAKeyParameters _ n e priv))+ = object $ ["algorithm" .= RS, "modulus" .= n ,"exponent" .= e]+ ++ maybe [] (\p -> ["secretExponent" .= rsaD p]) priv -instance Key KeyMaterial' where- sign h (RSAKeyMaterial' _ k) = sign h k- verify h (RSAKeyMaterial' _ k) = verify h k+instance Key RSKeyParameters where+ type KeyGenParam RSKeyParameters = Int+ type KeyContent RSKeyParameters = RSAKeyParameters+ gen p = first fromKeyContent . gen p+ fromKeyContent = RSKeyParameters+ sign h (RSKeyParameters k) = sign h k+ verify h (RSKeyParameters k) = verify h k -- | Legacy JSON Web Key data type. ---newtype JWK' = JWK' KeyMaterial' deriving (Eq, Show)+newtype JWK' = JWK' RSKeyParameters deriving (Eq, Show) instance FromJSON JWK' where parseJSON = withObject "JWK'" $ \o -> JWK' <$> parseJSON (Object o)@@ -94,13 +78,9 @@ "version" .= ("2012.08.15" :: String) : 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' sign h (JWK' k) = sign h k verify h (JWK' k) = verify h k----- | Generate a legacy RSA keypair.----genRSA' :: Int -> IO (JWK', JWK')-genRSA' =- let f = JWK' . RSAKeyMaterial' RS . RSAKeyParameters'- in fmap (f *** f) . genRSAParams
src/Crypto/JOSE/TH.hs view
@@ -55,14 +55,18 @@ endGuardPred :: ExpQ endGuardPred = [e| otherwise |] -endGuardExp :: ExpQ-endGuardExp = [e| fail "unrecognised value" |]+-- | Expression for an end guard. Arg describes type it was expecting.+--+endGuardExp :: String -> ExpQ+endGuardExp s = [e| fail ("unrecognised value; expected: " ++ s) |] -endGuard :: Q (Guard, Exp)-endGuard = normalGE endGuardPred endGuardExp+-- | Build a catch-all guard that fails. String describes what is expected.+--+endGuard :: String -> Q (Guard, Exp)+endGuard s = normalGE endGuardPred (endGuardExp s) guardedBody :: [String] -> BodyQ-guardedBody vs = guardedB (map guard vs ++ [endGuard])+guardedBody vs = guardedB (map guard vs ++ [endGuard (show vs)]) parseJSONClauseQ :: [String] -> ClauseQ parseJSONClauseQ vs = clause [varP $ mkName "s"] (guardedBody vs) []
src/Crypto/JOSE/Types.hs view
@@ -24,8 +24,10 @@ import Control.Applicative import Data.Aeson-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL+import Data.Byteable+import qualified Data.ByteString as B+import qualified Data.ByteString.Base64.URL as B64U+import qualified Data.ByteString.Lazy as L import Data.Certificate.X509 import qualified Data.Text as T import qualified Network.URI@@ -55,17 +57,17 @@ instance FromJSON SizedBase64Integer where parseJSON = withText "full size base64url integer" $ parseB64Url (\bytes ->- pure $ SizedBase64Integer (BS.length bytes) (bsToInteger bytes))+ pure $ SizedBase64Integer (B.length bytes) (bsToInteger bytes)) instance ToJSON SizedBase64Integer where toJSON (SizedBase64Integer s x) = encodeB64Url $ zeroPad $ integerToBS x- where zeroPad xs = BS.replicate (s - BS.length xs) 0 `BS.append` xs+ where zeroPad xs = B.replicate (s - B.length xs) 0 `B.append` xs -- | A base64url encoded string. This is used for the JWE -- /Agreement PartyUInfo/ and /Agreement PartyVInfo/ fields. ---newtype Base64UrlString = Base64UrlString BS.ByteString+newtype Base64UrlString = Base64UrlString B.ByteString deriving (Eq, Show) instance FromJSON Base64UrlString where@@ -75,9 +77,12 @@ -- | A base64url encoded octet sequence. Used for payloads, -- signatures, symmetric keys, salts, initialisation vectors, etc. ---newtype Base64Octets = Base64Octets BS.ByteString+newtype Base64Octets = Base64Octets B.ByteString deriving (Eq, Show) +instance Byteable Base64Octets where+ toBytes (Base64Octets s) = unpad $ B64U.encode s+ instance FromJSON Base64Octets where parseJSON = withText "Base64Octets" $ parseB64Url (pure . Base64Octets) @@ -88,12 +93,12 @@ -- | A base64url encoded SHA-1 digest. Used for X.509 certificate -- thumbprints. ---newtype Base64SHA1 = Base64SHA1 BS.ByteString+newtype Base64SHA1 = Base64SHA1 B.ByteString deriving (Eq, Show) instance FromJSON Base64SHA1 where parseJSON = withText "base64url SHA-1" $ parseB64Url (\bytes ->- case BS.length bytes of+ case B.length bytes of 20 -> pure $ Base64SHA1 bytes _ -> fail "incorrect number of bytes") @@ -104,12 +109,12 @@ -- | A base64url encoded SHA-256 digest. Used for X.509 certificate -- thumbprints. ---newtype Base64SHA256 = Base64SHA256 BS.ByteString+newtype Base64SHA256 = Base64SHA256 B.ByteString deriving (Eq, Show) instance FromJSON Base64SHA256 where parseJSON = withText "base64url SHA-256" $ parseB64Url (\bytes ->- case BS.length bytes of+ case B.length bytes of 32 -> pure $ Base64SHA256 bytes _ -> fail "incorrect number of bytes") @@ -124,10 +129,10 @@ instance FromJSON Base64X509 where parseJSON = withText "base64url X.509 certificate" $ parseB64 $- either fail (pure . Base64X509) . decodeCertificate . BSL.fromStrict+ either fail (pure . Base64X509) . decodeCertificate . L.fromStrict instance ToJSON Base64X509 where- toJSON (Base64X509 x509) = encodeB64 $ BSL.toStrict $ encodeCertificate x509+ toJSON (Base64X509 x509) = encodeB64 $ L.toStrict $ encodeCertificate x509 -- | A URI. Used for X.509 certificate and JWK Set URLs.
src/Crypto/JOSE/Types/Internal.hs view
@@ -50,20 +50,25 @@ encodeB64 :: B.ByteString -> Value encodeB64 = String . E.decodeUtf8 . B64.encode +-- | Add appropriate base64 '=' padding.+--+pad :: B.ByteString -> B.ByteString+pad s = s `B.append` B.replicate ((4 - B.length s `mod` 4) `mod` 4) 61++-- | Strip base64 '=' padding.+--+unpad :: B.ByteString -> B.ByteString+unpad = B.reverse . B.dropWhile (== 61) . B.reverse+ -- | Produce a parser of base64url encoded text from a bytestring parser. -- parseB64Url :: FromJSON a => (B.ByteString -> Parser a) -> T.Text -> Parser a-parseB64Url f = either fail f . decodeB64Url- where- decodeB64Url = B64U.decode . E.encodeUtf8 . pad- pad s = s `T.append` T.replicate ((4 - T.length s `mod` 4) `mod` 4) "="+parseB64Url f = either fail f . B64U.decode . pad . E.encodeUtf8 -- | Convert a bytestring to a base64url encoded JSON 'String' -- encodeB64Url :: B.ByteString -> Value-encodeB64Url = String . unpad . E.decodeUtf8 . B64U.encode- where- unpad = T.dropWhileEnd (== '=')+encodeB64Url = String . E.decodeUtf8 . unpad . B64U.encode -- | Convert an unsigned big endian octet sequence to the integer -- it represents.
+ src/Crypto/JWT.hs view
@@ -0,0 +1,231 @@+-- 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 OverloadedStrings #-}++{-|++JSON Web Token implementation.++-}+module Crypto.JWT+ (+ JWT(..)+ , createJWSJWT+ , validateJWSJWT++ , ClaimsSet(..)+ , emptyClaimsSet++ , Audience(..)++ , StringOrURI(..)+ , IntDate(..)+ ) where++import Control.Applicative+import Control.Arrow+import Control.Monad+import Data.Maybe++import Data.Aeson+import qualified Data.ByteString.Lazy as BSL+import qualified Data.HashMap.Strict as M+import qualified Data.Text as T+import Data.Time+import Data.Time.Clock.POSIX++import Crypto.JOSE+import Crypto.JOSE.Types+++-- §2. Terminology++-- | A JSON string value, with the additional requirement that while+-- arbitrary string values MAY be used, any value containing a /:/+-- character MUST be a URI.+--+data StringOrURI = Arbitrary T.Text | OrURI URI deriving (Eq, Show)++instance FromJSON StringOrURI where+ parseJSON = withText "StringOrURI" (\s ->+ if T.any (== ':') s+ then OrURI <$> parseJSON (String s)+ else pure $ Arbitrary s)++instance ToJSON StringOrURI where+ toJSON (Arbitrary s) = toJSON s+ toJSON (OrURI uri) = toJSON $ show uri+++-- | 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)++instance FromJSON IntDate where+ parseJSON = withScientific "IntDate" $+ pure . IntDate . posixSecondsToUTCTime . fromRational . toRational++instance ToJSON IntDate where+ toJSON (IntDate t)+ = Number $ fromRational $ toRational $ utcTimeToPOSIXSeconds t+++-- | Audience data. In the general case, the /aud/ value is an+-- array of case-sensitive strings, each containing a 'StringOrURI'+-- value. In the special case when the JWT has one audience, the+-- /aud/ value MAY be a single case-sensitive string containing a+-- 'StringOrURI' value.+--+data Audience = General [StringOrURI] | Special StringOrURI deriving (Eq, Show)++instance FromJSON Audience where+ parseJSON v = fmap General (parseJSON v) <|> fmap Special (parseJSON v)++instance ToJSON Audience where+ toJSON (General auds) = toJSON auds+ toJSON (Special aud) = toJSON aud+++-- | The JWT Claims Set represents a JSON object whose members are+-- the claims conveyed by the JWT.+--+data ClaimsSet = ClaimsSet+ { claimIss :: Maybe StringOrURI+ -- ^ The issuer claim identifies the principal that issued the+ -- JWT. The processing of this claim is generally application+ -- specific.+ , claimSub :: Maybe StringOrURI+ -- ^ The subject claim identifies the principal that is the+ -- subject of the JWT. The Claims in a JWT are normally+ -- statements about the subject. The subject value MAY be scoped+ -- to be locally unique in the context of the issuer or MAY be+ -- globally unique. The processing of this claim is generally+ -- application specific.+ , claimAud :: Maybe Audience+ -- ^ The audience claim identifies the recipients that the JWT is+ -- intended for. Each principal intended to process the JWT MUST+ -- identify itself with a value in the audience claim. If the+ -- 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+ -- ^ 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+ -- ^ 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+ -- ^ 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.+ , claimJti :: Maybe T.Text+ -- ^ The JWT ID claim provides a unique identifier for the JWT.+ -- The identifier value MUST be assigned in a manner that ensures+ -- that there is a negligible probability that the same value will+ -- be accidentally assigned to a different data object. The /jti/+ -- claim can be used to prevent the JWT from being replayed. The+ -- /jti/ value is a case-sensitive string.+ , unregisteredClaims :: M.HashMap T.Text Value+ -- ^ Claim Names can be defined at will by those using JWTs.+ }+ deriving (Eq, Show)++-- | Return an empty claims set.+--+emptyClaimsSet :: ClaimsSet+emptyClaimsSet = ClaimsSet n n n n n n n M.empty where n = Nothing++filterUnregistered :: M.HashMap T.Text Value -> M.HashMap T.Text Value+filterUnregistered = M.filterWithKey (\k _ -> k `notElem` registered) where+ registered = ["iss", "sub", "aud", "exp", "nbf", "iat", "jti"]++instance FromJSON ClaimsSet where+ parseJSON = withObject "JWT Claims Set" (\o -> ClaimsSet+ <$> o .:? "iss"+ <*> o .:? "sub"+ <*> o .:? "aud"+ <*> o .:? "exp"+ <*> o .:? "nbf"+ <*> o .:? "iat"+ <*> o .:? "jti"+ <*> pure (filterUnregistered o))++instance ToJSON ClaimsSet where+ toJSON (ClaimsSet iss sub aud exp' nbf iat jti o) = object $ catMaybes [+ fmap ("iss" .=) iss+ , fmap ("sub" .=) sub+ , fmap ("aud" .=) aud+ , fmap ("exp" .=) exp'+ , fmap ("nbf" .=) nbf+ , fmap ("iat" .=) iat+ , fmap ("jti" .=) jti+ ] ++ M.toList (filterUnregistered o)+++-- | Data representing the JOSE aspects of a JWT.+--+data JWTCrypto = JWTJWS JWS deriving (Eq, Show)++instance FromCompact JWTCrypto where+ fromCompact = fmap JWTJWS . fromCompact++instance ToCompact JWTCrypto where+ toCompact (JWTJWS jws) = toCompact jws+++-- | JSON Web Token data.+--+data JWT = JWT+ { jwtCrypto :: JWTCrypto -- ^ JOSE aspect of the JWT.+ , jwtClaimsSet :: ClaimsSet -- ^ Claims of the JWT.+ } deriving (Eq, Show)++instance FromCompact JWT where+ fromCompact = fromCompact >=> toJWT where+ toJWT (JWTJWS jws) =+ either (Left . CompactDecodeError) (Right . JWT (JWTJWS jws))+ $ eitherDecode $ jwsPayload jws++instance ToCompact JWT where+ toCompact = toCompact . jwtCrypto+++-- | Validate a JWT as a JWS (JSON Web Signature).+--+validateJWSJWT :: JWK -> JWT -> Bool+validateJWSJWT k (JWT (JWTJWS jws) _) = verifyJWS k jws++-- | Create a JWT that is a JWS.+--+createJWSJWT+ :: CPRG g+ => g+ -> 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+ where+ payload = Base64Octets $ BSL.toStrict $ encode c
test/Test.hs view
@@ -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.@@ -16,10 +16,13 @@ import JWK import JWS+import JWT import Types +main :: IO () main = hspec $ do Types.spec JWK.spec JWS.spec+ JWT.spec