oauthenticated 0.2.0.0 → 0.2.1.0
raw patch · 8 files changed
+100/−111 lines, 8 filesdep +cryptonitedep +memorydep −crypto-randomdep −cryptohashdep ~base
Dependencies added: cryptonite, memory
Dependencies removed: crypto-random, cryptohash
Dependency ranges changed: base
Files
- oauthenticated.cabal +8/−8
- src/Network/OAuth.hs +8/−12
- src/Network/OAuth/Signing.hs +10/−8
- src/Network/OAuth/Simple.hs +9/−19
- src/Network/OAuth/ThreeLegged.hs +40/−43
- src/Network/OAuth/Types/Params.hs +10/−10
- test/Config.hs +1/−4
- test/SigningSpec.hs +14/−7
oauthenticated.cabal view
@@ -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
src/Network/OAuth.hs view
@@ -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
src/Network/OAuth/Signing.hs view
@@ -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
src/Network/OAuth/Simple.hs view
@@ -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
src/Network/OAuth/ThreeLegged.hs view
@@ -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
src/Network/OAuth/Types/Params.hs view
@@ -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
test/Config.hs view
@@ -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 {..}
test/SigningSpec.hs view
@@ -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