diff --git a/oauthenticated.cabal b/oauthenticated.cabal --- a/oauthenticated.cabal +++ b/oauthenticated.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 17b79e47a3f7b1729531b411a7a3e56766102b8aeb5e6ba09cdabd55c17d5d88 +-- hash: 2a4dc5dd7cbbdbc66a72d8662fa7be03bfd91b8f0bce05bf7c27a6f53b17d113 name: oauthenticated -version: 0.2.0.0 +version: 0.2.1.0 synopsis: Simple OAuth for http-client description: /Warning/: This software is pre 1.0 and thus its API may change very dynamically while updating only minor versions. This package will follow the @@ -55,16 +55,16 @@ ghc-options: -Wall -fwarn-tabs build-depends: aeson - , base >=4.10 && <5 + , base >=4.8 && <5 , base64-bytestring , blaze-builder , bytestring , case-insensitive - , crypto-random - , cryptohash + , cryptonite , exceptions , http-client , http-types + , memory , mtl , network , network-uri @@ -91,19 +91,19 @@ ghc-options: -Wall -fwarn-tabs build-depends: aeson - , base >=4.10 && <5 + , base >=4.8 && <5 , base64-bytestring , blaze-builder , bytestring , case-insensitive - , crypto-random - , cryptohash + , cryptonite , exceptions , hspec , hspec-expectations , http-client , http-client-tls , http-types + , memory , mtl , network , network-uri diff --git a/src/Network/OAuth.hs b/src/Network/OAuth.hs --- a/src/Network/OAuth.hs +++ b/src/Network/OAuth.hs @@ -38,14 +38,14 @@ -- a fresh set of 'O.Oa' parameters from a relevant or deterministic -- 'O.OaPin' and then using 'S.sign' to sign the 'C.Request'. S.sign, - + -- ** Generating OAuth parameters - O.emptyOa, O.freshOa, O.emptyPin, O.freshPin, + O.emptyOa, O.freshOa, O.emptyPin, O.freshPin, -- * OAuth Credentials O.Token (..), O.Cred, O.Client, O.Temporary, O.Permanent, - -- ** Creating Credentials + -- ** Creating Credentials O.clientCred, O.temporaryCred, O.permanentCred, O.fromUrlEncoded, @@ -55,18 +55,14 @@ ) where -import qualified Crypto.Random as R import qualified Network.HTTP.Client as C import qualified Network.OAuth.Signing as S import qualified Network.OAuth.Types.Credentials as O import qualified Network.OAuth.Types.Params as O --- | Sign a request with a fresh set of parameters. Creates a fresh --- 'R.SystemRNG' using new entropy for each signing and thus is potentially --- /dangerous/ if used too frequently. In almost all cases, 'S.oauth' --- should be used instead. +-- | Sign a request with a fresh set of parameters. Uses @MonadRandom IO@, getting +-- new entropy for each signing and thus is potentially /dangerous/ if used too +-- frequently. In almost all cases, 'S.oauth' should be used instead with a suitably +-- seeded PRNG. oauthSimple :: O.Cred ty -> O.Server -> C.Request -> IO C.Request -oauthSimple cr srv req = do - entropy <- R.createEntropyPool - (req', _) <- S.oauth cr srv req (R.cprgCreate entropy :: R.SystemRNG) - return req' +oauthSimple = S.oauth diff --git a/src/Network/OAuth/Signing.hs b/src/Network/OAuth/Signing.hs --- a/src/Network/OAuth/Signing.hs +++ b/src/Network/OAuth/Signing.hs @@ -36,9 +36,11 @@ ) where import qualified Blaze.ByteString.Builder as Blz -import Crypto.Hash.SHA1 (hash) -import Crypto.MAC.HMAC (hmac) -import Crypto.Random +import Control.Monad.IO.Class (MonadIO) +import Crypto.Hash (SHA1) +import Crypto.Random (MonadRandom) +import Crypto.MAC.HMAC (HMAC, hmac) +import Data.ByteArray (convert) import qualified Data.ByteString as S import qualified Data.ByteString.Base64 as S64 import qualified Data.ByteString.Char8 as S8 @@ -57,10 +59,10 @@ import Network.URI -- | Sign a request with a fresh set of parameters. -oauth :: CPRG gen => Cred ty -> Server -> C.Request -> gen -> IO (C.Request, gen) -oauth creds sv req gen = do - (oax, gen') <- freshOa creds gen - return (sign oax sv req, gen') +oauth :: (MonadIO m, MonadRandom m) => Cred ty -> Server -> C.Request -> m C.Request +oauth creds sv req = do + oax <- freshOa creds + return $ sign oax sv req -- | Sign a request given generated parameters sign :: Oa ty -> Server -> C.Request -> C.Request @@ -72,7 +74,7 @@ in augmentRequest (parameterMethod server) params req makeSignature :: SignatureMethod -> S.ByteString -> S.ByteString -> S.ByteString -makeSignature HmacSha1 sigKey payload = S64.encode (hmac hash 64 sigKey payload) +makeSignature HmacSha1 sigKey payload = S64.encode $ convert (hmac sigKey payload :: HMAC SHA1) makeSignature Plaintext sigKey _ = sigKey -- | Augments whatever component of the 'C.Request' is specified by diff --git a/src/Network/OAuth/Simple.hs b/src/Network/OAuth/Simple.hs --- a/src/Network/OAuth/Simple.hs +++ b/src/Network/OAuth/Simple.hs @@ -61,9 +61,7 @@ import qualified Control.Monad.Catch as E import Control.Monad.Reader -import Control.Monad.State import Control.Monad.Trans.Except -import qualified Crypto.Random as R import qualified Data.ByteString.Lazy as SL import qualified Network.HTTP.Client as C import qualified Network.OAuth as O @@ -80,15 +78,14 @@ -- | Perform authenticated requests using a shared 'C.Manager' and -- a particular set of 'O.Cred's. newtype OAuthT ty m a = - OAuthT { unOAuthT :: ReaderT (OaConfig ty) (StateT R.SystemRNG m) a } + OAuthT { unOAuthT :: ReaderT (OaConfig ty) m a } deriving ( Functor, Applicative, Monad , MonadReader (OaConfig ty) - , MonadState R.SystemRNG , E.MonadCatch , E.MonadThrow , MonadIO ) -instance MonadTrans (OAuthT ty) where lift = OAuthT . lift . lift +instance MonadTrans (OAuthT ty) where lift = OAuthT . lift -- | 'OAuthT' wrapped over 'IO'. type OAuth ty = OAuthT ty IO @@ -99,8 +96,7 @@ OAuthT ty m a -> O.Cred ty -> O.Server -> O.ThreeLegged -> m a runOAuthT oat cr srv tl = do - entropy <- liftIO R.createEntropyPool - evalStateT (runReaderT (unOAuthT oat) (OaConfig cr srv tl)) (R.cprgCreate entropy) + runReaderT (unOAuthT oat) (OaConfig cr srv tl) runOAuth :: OAuth ty a -> O.Cred ty -> O.Server -> O.ThreeLegged -> IO a runOAuth = runOAuthT @@ -122,22 +118,18 @@ -- with the same configuration but new credentials. upgrade :: (Cred.ResourceToken ty', Monad m) => O.Token ty' -> OAuthT ty' m a -> OAuthT ty m a upgrade tok oat = do - gen <- state R.cprgFork conf <- ask let conf' = conf { cred = Cred.upgradeCred tok (cred conf) } - lift $ evalStateT (runReaderT (unOAuthT oat) conf') gen + lift $ runReaderT (unOAuthT oat) conf' -liftBasic :: MonadIO m => (R.SystemRNG -> OaConfig ty -> IO (a, R.SystemRNG)) -> OAuthT ty m a +liftBasic :: MonadIO m => (OaConfig ty -> IO a) -> OAuthT ty m a liftBasic f = do - gen <- get conf <- ask - (a, gen') <- liftIO (f gen conf) - put gen' - return a + liftIO $ f conf -- | Sign a request using fresh credentials. oauth :: MonadIO m => C.Request -> OAuthT ty m C.Request -oauth req = liftBasic $ \gen conf -> O.oauth (cred conf) (server conf) req gen +oauth req = liftBasic $ \conf -> O.oauth (cred conf) (server conf) req -- Three-Legged Authorization -------------------------------------------------------------------------------- @@ -146,12 +138,11 @@ :: MonadIO m => C.Manager -> OAuthT O.Client m (C.Response (Either SL.ByteString (O.Token O.Temporary))) requestTemporaryToken man = - liftBasic $ \gen conf -> + liftBasic $ \conf -> O.requestTemporaryToken (cred conf) (server conf) (threeLegged conf) man - gen buildAuthorizationUrl :: Monad m => OAuthT O.Temporary m URI buildAuthorizationUrl = do @@ -162,13 +153,12 @@ :: MonadIO m => C.Manager -> O.Verifier -> OAuthT O.Temporary m (C.Response (Either SL.ByteString (O.Token O.Permanent))) requestPermanentToken man ver = - liftBasic $ \gen conf -> + liftBasic $ \conf -> O.requestPermanentToken (cred conf) (server conf) ver (threeLegged conf) man - gen data TokenRequestFailure = OnTemporaryRequest C.HttpException diff --git a/src/Network/OAuth/ThreeLegged.hs b/src/Network/OAuth/ThreeLegged.hs --- a/src/Network/OAuth/ThreeLegged.hs +++ b/src/Network/OAuth/ThreeLegged.hs @@ -30,7 +30,8 @@ requestTokenProtocol, requestTokenProtocol' ) where -import qualified Crypto.Random as R +import Control.Monad.IO.Class (MonadIO, liftIO) +import Crypto.Random (MonadRandom) import qualified Data.ByteString.Lazy as SL import Data.Data import qualified Network.HTTP.Client as C @@ -87,14 +88,13 @@ -- -- Throws 'C.HttpException's. requestTemporaryTokenRaw - :: R.CPRG gen => O.Cred O.Client -> O.Server - -> ThreeLegged -> C.Manager -> gen - -> IO (C.Response SL.ByteString, gen) -requestTemporaryTokenRaw cr srv (ThreeLegged {..}) man gen = do - (oax, gen') <- O.freshOa cr gen + :: (MonadIO m, MonadRandom m) => O.Cred O.Client -> O.Server + -> ThreeLegged -> C.Manager + -> m(C.Response SL.ByteString) +requestTemporaryTokenRaw cr srv (ThreeLegged {..}) man = do + oax <- O.freshOa cr let req = O.sign (oax { P.workflow = P.TemporaryTokenRequest callback }) srv temporaryTokenRequest - lbs <- C.httpLbs req man - return (lbs, gen') + liftIO $ C.httpLbs req man -- | Returns the raw result if the 'C.Response' could not be parsed as -- a valid 'O.Token'. Importantly, in RFC 5849 compliant modes this @@ -103,12 +103,12 @@ -- -- Throws 'C.HttpException's. requestTemporaryToken - :: R.CPRG gen => O.Cred O.Client -> O.Server - -> ThreeLegged -> C.Manager -> gen - -> IO (C.Response (Either SL.ByteString (O.Token O.Temporary)), gen) -requestTemporaryToken cr srv tl man gen = do - (raw, gen') <- requestTemporaryTokenRaw cr srv tl man gen - return (tryParseToken <$> raw, gen') + :: (MonadIO m, MonadRandom m) => O.Cred O.Client -> O.Server + -> ThreeLegged -> C.Manager + -> m (C.Response (Either SL.ByteString (O.Token O.Temporary))) +requestTemporaryToken cr srv tl man = do + raw <- requestTemporaryTokenRaw cr srv tl man + return $ tryParseToken <$> raw where tryParseToken lbs = case maybeParseToken lbs of Nothing -> Left lbs @@ -133,28 +133,27 @@ -- -- Throws 'C.HttpException's. requestPermanentTokenRaw - :: R.CPRG gen => O.Cred O.Temporary -> O.Server - -> P.Verifier - -> ThreeLegged -> C.Manager -> gen - -> IO (C.Response SL.ByteString, gen) -requestPermanentTokenRaw cr srv verifier (ThreeLegged {..}) man gen = do - (oax, gen') <- O.freshOa cr gen + :: (MonadIO m, MonadRandom m) => O.Cred O.Temporary -> O.Server + -> P.Verifier + -> ThreeLegged -> C.Manager + -> m (C.Response SL.ByteString) +requestPermanentTokenRaw cr srv verifier (ThreeLegged {..}) man = do + oax <- O.freshOa cr let req = O.sign (oax { P.workflow = P.PermanentTokenRequest verifier }) srv permanentTokenRequest - lbs <- C.httpLbs req man - return (lbs, gen') + liftIO $ C.httpLbs req man -- | Returns 'Nothing' if the response could not be decoded as a 'Token'. -- See also 'requestPermanentTokenRaw'. -- -- Throws 'C.HttpException's. -requestPermanentToken - :: R.CPRG gen => O.Cred O.Temporary -> O.Server - -> P.Verifier - -> ThreeLegged -> C.Manager -> gen - -> IO (C.Response (Either SL.ByteString (O.Token O.Permanent)), gen) -requestPermanentToken cr srv verifier tl man gen = do - (raw, gen') <- requestPermanentTokenRaw cr srv verifier tl man gen - return (tryParseToken <$> raw, gen') +requestPermanentToken + :: (MonadIO m, MonadRandom m) => O.Cred O.Temporary -> O.Server + -> P.Verifier + -> ThreeLegged -> C.Manager + -> m (C.Response (Either SL.ByteString (O.Token O.Permanent))) +requestPermanentToken cr srv verifier tl man = do + raw <- requestPermanentTokenRaw cr srv verifier tl man + return $ tryParseToken <$> raw where tryParseToken lbs = case maybeParseToken lbs of Nothing -> Left lbs @@ -163,21 +162,19 @@ -- | Like 'requestTokenProtocol' but allows for specification of the -- 'C.ManagerSettings'. -requestTokenProtocol' - :: C.ManagerSettings -> O.Cred O.Client -> O.Server -> ThreeLegged - -> (URI -> IO P.Verifier) - -> IO (Maybe (O.Cred O.Permanent)) +requestTokenProtocol' + :: (MonadIO m, MonadRandom m) => C.ManagerSettings -> O.Cred O.Client -> O.Server -> ThreeLegged + -> (URI -> m P.Verifier) + -> m (Maybe (O.Cred O.Permanent)) requestTokenProtocol' mset cr srv tl getVerifier = do - entropy <- R.createEntropyPool - man <- C.newManager mset - let gen = (R.cprgCreate entropy :: R.SystemRNG) - (respTempToken, gen') <- requestTemporaryToken cr srv tl man gen + man <- liftIO $ C.newManager mset + respTempToken <- requestTemporaryToken cr srv tl man case C.responseBody respTempToken of Left _ -> return Nothing Right tok -> do let tempCr = O.temporaryCred tok cr verifier <- getVerifier $ buildAuthorizationUrl tempCr tl - (respPermToken, _) <- requestPermanentToken tempCr srv verifier tl man gen' + respPermToken <- requestPermanentToken tempCr srv verifier tl man case C.responseBody respPermToken of Left _ -> return Nothing Right tok' -> return (Just $ O.permanentCred tok' cr) @@ -188,10 +185,10 @@ -- will throw a 'C.TlsNotSupported' exception if TLS is required. -- -- Throws 'C.HttpException's. -requestTokenProtocol - :: O.Cred O.Client -> O.Server -> ThreeLegged - -> (URI -> IO P.Verifier) - -> IO (Maybe (O.Cred O.Permanent)) +requestTokenProtocol + :: (MonadIO m, MonadRandom m) => O.Cred O.Client -> O.Server -> ThreeLegged + -> (URI -> m P.Verifier) + -> m (Maybe (O.Cred O.Permanent)) requestTokenProtocol = requestTokenProtocol' C.defaultManagerSettings diff --git a/src/Network/OAuth/Types/Params.hs b/src/Network/OAuth/Types/Params.hs --- a/src/Network/OAuth/Types/Params.hs +++ b/src/Network/OAuth/Types/Params.hs @@ -19,6 +19,7 @@ module Network.OAuth.Types.Params where +import Control.Monad.IO.Class (MonadIO, liftIO) import Crypto.Random import qualified Data.ByteString as S import qualified Data.ByteString.Base64 as S64 @@ -177,12 +178,11 @@ -- | Creates a new, unique, unpredictable 'OaPin'. This should be used quickly -- as dependent on the OAuth server settings it may expire. -freshPin :: CPRG gen => gen -> IO (OaPin, gen) -freshPin gen = do - t <- Timestamp <$> getCurrentTime - return (OaPin { timestamp = t, nonce = n }, gen') - where - (n, gen') = withRandomBytes gen 8 S64.encode +freshPin :: (MonadRandom m, MonadIO m) => m OaPin +freshPin = do + t <- Timestamp <$> liftIO getCurrentTime + n <- S64.encode <$> getRandomBytes 8 + return OaPin { timestamp = t, nonce = n } -- | Uses 'emptyPin' to create an empty set of params 'Oa'. emptyOa :: Cred ty -> Oa ty @@ -190,10 +190,10 @@ Oa { credentials = creds, workflow = Standard, pin = emptyPin } -- | Uses 'freshPin' to create a fresh, default set of params 'Oa'. -freshOa :: CPRG gen => Cred ty -> gen -> IO (Oa ty, gen) -freshOa creds gen = do - (pinx, gen') <- freshPin gen - return (Oa { credentials = creds, workflow = Standard, pin = pinx }, gen') +freshOa :: (MonadRandom m, MonadIO m) => Cred ty -> m (Oa ty) +freshOa creds = do + pinx <- freshPin + return Oa { credentials = creds, workflow = Standard, pin = pinx } -- | The 'Oa' parameters include all the OAuth information specific to a single -- request. They are not sufficient information by themselves to generate the diff --git a/test/Config.hs b/test/Config.hs --- a/test/Config.hs +++ b/test/Config.hs @@ -3,14 +3,12 @@ module Config where -import Crypto.Random (SystemRNG, cprgCreate, createEntropyPool) import Network.HTTP.Client (Manager, newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.OAuth (Client, Cred, Server, Token (Token), clientCred, defaultServer) data Config = Config - { rng :: SystemRNG - , man :: Manager + { man :: Manager , ser :: Server , cred :: Cred Client , url :: String @@ -22,6 +20,5 @@ let cred = clientCred $ Token "RKCGzna7bv9YD57c" "D+EdQ-gs$-%@2Nu7" url = "https://postman-echo.com/oauth1" ser = defaultServer - rng <- cprgCreate <$> createEntropyPool man <- newManager tlsManagerSettings pure $ Config {..} diff --git a/test/SigningSpec.hs b/test/SigningSpec.hs --- a/test/SigningSpec.hs +++ b/test/SigningSpec.hs @@ -3,28 +3,35 @@ module SigningSpec where import Control.Monad -import Network.HTTP.Client (httpLbs, parseRequest, responseStatus) +import Data.List (nub) +import Network.HTTP.Client (httpLbs, parseRequest, requestHeaders, responseStatus) import Network.HTTP.Types (status200) import Network.OAuth (oauth) import Test.Hspec (Spec, describe, example, it) import Test.Hspec.Expectations (shouldBe) -import Config (Config (Config, cred, man, rng, ser, url)) +import Config (Config (Config, cred, man, ser, url)) spec :: Config -> Spec spec Config {..} = describe "signing" $ do it "authorizes a request" $ do req <- parseRequest url - (signedReq, _) <- oauth cred ser req rng + signedReq <- oauth cred ser req resp <- httpLbs signedReq man responseStatus resp `shouldBe` status200 it "authorizes many requests" $ do req <- parseRequest url - (_, resps) <- foldM (\ (gen, acc) next -> do - (signedReq, newGen) <- oauth cred ser next gen + resps <- foldM (\ acc next -> do + signedReq <- oauth cred ser next resp <- httpLbs signedReq man - pure (newGen, resp:acc) - ) (rng, []) (replicate 100 req) + pure $ resp:acc + ) [] (replicate 100 req) forM_ resps $ \ resp -> example $ responseStatus resp `shouldBe` status200 + + it "generates a unique nonce for each repeated request" $ do + req <- parseRequest url + headers <- replicateM 100 (requestHeaders <$> oauth cred ser req) + let uniqueHeaders = nub headers + length headers `shouldBe` length uniqueHeaders