diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +# 2018-01-04 0.9.0 + +* Switch from RSA and HsOpenSSL to x509-store +* Add Semigroup instances for GHC 8.6 compatibility + # 2018-03-21 0.8.0 * Support RS256 algorithm diff --git a/jwt.cabal b/jwt.cabal --- a/jwt.cabal +++ b/jwt.cabal @@ -2,12 +2,12 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: jwt -version: 0.8.0 +version: 0.9.0 synopsis: JSON Web Token (JWT) decoding and encoding license: MIT license-file: LICENSE -author: Stefan Saasen -maintainer: stefan@saasen.me +author: Brian McKenna +maintainer: brian@brianmckenna.org homepage: https://bitbucket.org/ssaasen/haskell-jwt bug-reports: https://bitbucket.org/ssaasen/haskell-jwt/issues category: Web @@ -46,8 +46,8 @@ , vector >= 0.7.1 , semigroups >= 0.15.4 , network-uri - , RSA - , HsOpenSSL + , x509 + , x509-store hs-source-dirs: src default-language: Haskell2010 @@ -68,6 +68,7 @@ , Web.JWTTestsCompat , Data.Text.Extended , Data.Text.ExtendedTests + , Data.ByteString.Extended , Data.ByteString.ExtendedTests hs-source-dirs: tests/src, src build-depends: base < 5 && >= 4.4 @@ -92,8 +93,8 @@ , vector >= 0.7.1 , semigroups >= 0.15.4 , network-uri - , RSA - , HsOpenSSL + , x509 + , x509-store cpp-options: -DTEST diff --git a/src/Web/JWT.hs b/src/Web/JWT.hs --- a/src/Web/JWT.hs +++ b/src/Web/JWT.hs @@ -40,7 +40,7 @@ -- ** Common , tokenIssuer , hmacSecret - , rsaKeySecret + , readRsaSecret -- ** JWT structure , claims , header @@ -72,18 +72,23 @@ , StringOrURI , JWTHeader , JOSEHeader + + -- * Deprecated + , rsaKeySecret ) where +import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy.Char8 as BL (fromStrict, toStrict) import qualified Data.ByteString.Extended as BS import qualified Data.Text.Extended as T import qualified Data.Text.Encoding as TE -import Codec.Crypto.RSA (PrivateKey(..), PublicKey(..), sign) import Control.Applicative import Control.Monad import Crypto.Hash.Algorithms import Crypto.MAC.HMAC +import Crypto.PubKey.RSA (PrivateKey) +import Crypto.PubKey.RSA.PKCS15 (sign) import Data.ByteArray.Encoding import Data.Aeson hiding (decode, encode) import qualified Data.Aeson as JSON @@ -91,24 +96,11 @@ import qualified Data.Map as Map import Data.Maybe import Data.Scientific +import qualified Data.Semigroup as Semigroup import Data.Time.Clock (NominalDiffTime) +import Data.X509 (PrivKey (PrivKeyRSA)) +import Data.X509.Memory (readKeyFileFromMemory) import qualified Network.URI as URI -import OpenSSL.EVP.PKey (toKeyPair) -import OpenSSL.PEM (PemPasswordSupply(..), readPrivateKey) -import OpenSSL.RSA - ( RSAKeyPair - , RSAPubKey - , rsaCopyPublic - , rsaD - , rsaDMP1 - , rsaDMQ1 - , rsaE - , rsaIQMP - , rsaN - , rsaP - , rsaQ - , rsaSize - ) import Prelude hiding (exp) -- $setup @@ -209,9 +201,12 @@ instance Monoid JOSEHeader where mempty = JOSEHeader Nothing Nothing Nothing - mappend (JOSEHeader a b c) (JOSEHeader a' b' c') = - JOSEHeader (a <|> a') (b <|> b') (c <|> c') + mappend = (Semigroup.<>) +instance Semigroup.Semigroup JOSEHeader where + JOSEHeader a b c <> JOSEHeader a' b' c' = + JOSEHeader (a <|> a') (b <|> b') (c <|> c') + -- | The JWT Claims Set represents a JSON object whose members are the claims conveyed by the JWT. data JWTClaimsSet = JWTClaimsSet { -- Registered Claim Names @@ -245,9 +240,12 @@ instance Monoid JWTClaimsSet where mempty = JWTClaimsSet Nothing Nothing Nothing Nothing Nothing Nothing Nothing $ ClaimsMap Map.empty - mappend (JWTClaimsSet a b c d e f g h) (JWTClaimsSet a' b' c' d' e' f' g' h') = - JWTClaimsSet (a <|> a') (b <|> b') (c <|> c') (d <|> d') (e <|> e') (f <|> f') (g <|> g') (mappend h h') + mappend = (Semigroup.<>) +instance Semigroup.Semigroup JWTClaimsSet where + JWTClaimsSet a b c d e f g h <> JWTClaimsSet a' b' c' d' e' f' g' h' = + JWTClaimsSet (a <|> a') (b <|> b') (c <|> c') (d <|> d') (e <|> e') (f <|> f') (g <|> g') (h Semigroup.<> h') + -- | Encode a claims set using the given secret -- -- @ @@ -378,11 +376,17 @@ -- | Create an RSAPrivateKey from PEM contents -- --- > rsaKeySecret =<< readFile "foo.pem" +-- Please, consider using 'readRsaSecret' instead. +rsaKeySecret :: String -> IO (Maybe Signer) +rsaKeySecret = pure . fmap RSAPrivateKey . readRsaSecret . C8.pack + +-- | Create an RSA 'PrivateKey' from PEM contents -- +-- > readRsaSecret <$> BS.readFile "foo.pem" +-- -- >>> :{ -- -- A random example key created with `ssh-keygen -t rsa` --- fmap (\(Just (RSAPrivateKey pk)) -> pk) $ rsaKeySecret $ unlines +-- fromJust . readRsaSecret . C8.pack $ unlines -- [ "-----BEGIN RSA PRIVATE KEY-----" -- , "MIIEowIBAAKCAQEAkkmgbLluo5HommstpHr1h53uWfuN3CwYYYR6I6a2MzAHIMIv" -- , "8Ak2ha+N2UDeYsfVhZ/DOnE+PMm2RpYSaiYT0l2a7ZkmRSbcyvVFt3XLePJbmUgo" @@ -414,27 +418,11 @@ -- :} -- PrivateKey {private_pub = PublicKey {public_size = 256, public_n = 1846..., public_e = 65537}, private_d = 8823..., private_p = 135..., private_q = 1358..., private_dP = 1373..., private_dQ = 9100..., private_qinv = 8859...} -- -rsaKeySecret :: String -> IO (Maybe Signer) -rsaKeySecret k = do - mKeyPair <- toKeyPair <$> readPrivateKey k PwNone - mPublicKey <- mapM rsaCopyPublic mKeyPair - return $ RSAPrivateKey <$> - (fromRSAKey <$> mKeyPair <*> mPublicKey) - where - fromRSAKey :: RSAKeyPair -> RSAPubKey -> PrivateKey - fromRSAKey kp pk = PrivateKey - { private_pub = PublicKey - { public_size = rsaSize pk - , public_n = rsaN pk - , public_e = rsaE pk - } - , private_d = rsaD kp - , private_p = rsaP kp - , private_q = rsaQ kp - , private_dP = fromMaybe 0 $ rsaDMP1 kp - , private_dQ = fromMaybe 0 $ rsaDMQ1 kp - , private_qinv = fromMaybe 0 $ rsaIQMP kp - } +readRsaSecret :: BS.ByteString -> (Maybe PrivateKey) +readRsaSecret bs = + case readKeyFileFromMemory bs of + [(PrivKeyRSA k)] -> Just k + _ -> Nothing -- | Convert the `NominalDiffTime` into an IntDate. Returns a Nothing if the -- argument is invalid (e.g. the NominalDiffTime must be convertible into a @@ -494,10 +482,14 @@ calculateDigest (RSAPrivateKey key) msg = TE.decodeUtf8 $ convertToBase Base64URLUnpadded - $ BL.toStrict - $ sign key - $ BL.fromStrict + $ sign' $ TE.encodeUtf8 msg + where + sign' :: BS.ByteString -> BS.ByteString + sign' bs = case sign Nothing (Just SHA256) key bs of + Right sig -> sig + Left _ -> error "impossible" -- This function can only fail with @SignatureTooLong@, + -- which is impossible because we use a hash. -- ================================================================================= @@ -507,8 +499,11 @@ instance Monoid ClaimsMap where mempty = ClaimsMap mempty - mappend (ClaimsMap a) (ClaimsMap b) = - ClaimsMap $ mappend a b + mappend = (Semigroup.<>) + +instance Semigroup.Semigroup ClaimsMap where + ClaimsMap a <> ClaimsMap b = + ClaimsMap $ a Semigroup.<> b fromHashMap :: Object -> ClaimsMap fromHashMap = ClaimsMap . Map.fromList . StrictMap.toList