diff --git a/oauthenticated.cabal b/oauthenticated.cabal --- a/oauthenticated.cabal +++ b/oauthenticated.cabal @@ -1,87 +1,118 @@ -name: oauthenticated -version: 0.1.3.4 -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 - PVP once it reaches version 1.0. - . - OAuth is a popular protocol allowing servers to offer resources owned by some - user to a series of authorized clients securely. For instance, OAuth lets - Twitter provide access to a user's private tweets to the Twitter client - registered on their phone. - . - @oauthenticated@ is a Haskell library implementing OAuth protocols atop the - minimalistic @http-client@ HTTP client library extracted from @http-conduit@. - "Network.OAuth" offers simple functions for signing - 'Network.HTTP.Client.Request's along with tools for 'Network.OAuth.Cred'ential - management and 'Network.OAuth.Server' configuration. "Network.OAuth.Simple" - provides a slightly more heavy-weight interface which manages the necessary state - and configuration using a monad transformer stack. - . - There's also an implementation of OAuth's three-legged credential acquisition - protocol built atop the "Network.OAuth" API. This can be handled in both - conformant and old-style modes: conformant will reject server responses which - are not conformant with RFC 5849 (which builds atop community version OAuth - 1.0a) while old-style better allows for less-than-compliant servers. See - 'Network.OAuth.Types.Params.Version' for more details. - . - Currently @oauthenticated@ only supports OAuth 1.0 and is in alpha. OAuth 2.0 - support is a potential goal, but it's unclear if it can be transparently - supported at a similar level of abstraction. +-- This file has been generated from package.yaml by hpack version 0.20.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 17b79e47a3f7b1729531b411a7a3e56766102b8aeb5e6ba09cdabd55c17d5d88 -license: MIT -license-file: LICENSE -author: Joseph Abrahamson -maintainer: me@jspha.com -copyright: 2013 (c) Joseph Abrahamson -category: Network, Web -build-type: Simple -cabal-version: >=1.10 +name: oauthenticated +version: 0.2.0.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 + PVP once it reaches version 1.0. + . + OAuth is a popular protocol allowing servers to offer resources owned by some + user to a series of authorized clients securely. For instance, OAuth lets + Twitter provide access to a user's private tweets to the Twitter client + registered on their phone. + . + @oauthenticated@ is a Haskell library implementing OAuth protocols atop the + minimalistic @http-client@ HTTP client library extracted from @http-conduit@. + "Network.OAuth" offers simple functions for signing + 'Network.HTTP.Client.Request's along with tools for 'Network.OAuth.Cred'ential + management and 'Network.OAuth.Server' configuration. "Network.OAuth.Simple" + provides a slightly more heavy-weight interface which manages the necessary state + and configuration using a monad transformer stack. + . + There's also an implementation of OAuth's three-legged credential acquisition + protocol built atop the "Network.OAuth" API. This can be handled in both + conformant and old-style modes: conformant will reject server responses which + are not conformant with RFC 5849 (which builds atop community version OAuth + 1.0a) while old-style better allows for less-than-compliant servers. See + 'Network.OAuth.Types.Params.Version' for more details. + . + Currently @oauthenticated@ only supports OAuth 1.0 and is in alpha. OAuth 2.0 + support is a potential goal, but it's unclear if it can be transparently + supported at a similar level of abstraction. +category: Network, Web +homepage: https://github.com/tel/oauthenticated.git#readme +bug-reports: https://github.com/tel/oauthenticated.git/issues +author: Joseph Abrahamson +maintainer: me@jspha.com +copyright: 2013 (c) Joseph Abrahamson +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 -flag network-uri - description: Get Network.URI from the network-uri package - default: True +source-repository head + type: git + location: https://github.com/tel/oauthenticated.git library + hs-source-dirs: + src + ghc-options: -Wall -fwarn-tabs + build-depends: + aeson + , base >=4.10 && <5 + , base64-bytestring + , blaze-builder + , bytestring + , case-insensitive + , crypto-random + , cryptohash + , exceptions + , http-client + , http-types + , mtl + , network + , network-uri + , text + , time + , transformers exposed-modules: - Network.OAuth - Network.OAuth.Simple - Network.OAuth.Signing - Network.OAuth.ThreeLegged - Network.OAuth.Types.Credentials - Network.OAuth.Types.Params + Network.OAuth + Network.OAuth.Signing + Network.OAuth.Simple + Network.OAuth.ThreeLegged + Network.OAuth.Types.Credentials + Network.OAuth.Types.Params other-modules: - Network.OAuth.MuLens - Network.OAuth.Util - build-depends: base >= 4.6 && < 4.8 - , aeson >= 0.6.2 && < 0.9 - , base64-bytestring >= 1.0 && < 1.1 - , blaze-builder >= 0.3 - , bytestring >= 0.9 - , case-insensitive >= 1.0 && < 1.3 - , crypto-random >= 0.0.7 - , cryptohash >= 0.11 && < 0.12 - , either >= 4.0 && < 5.0 - , exceptions >= 0.4 - , http-client >= 0.2.0 - , http-types >= 0.8 - , mtl >= 2.0 - , time >= 1.2 - , text >= 0.11 && < 1.3 - , transformers - - if flag(network-uri) - build-depends: network-uri >= 2.6, network >= 2.6 - else - build-depends: network-uri < 2.6 , network < 2.6 - - - hs-source-dirs: src - ghc-options: -Wall - default-language: Haskell2010 + Network.OAuth.MuLens + Network.OAuth.Util + default-language: Haskell2010 -source-repository head - type: git - location: git://github.com/tel/oauthenticated.git +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + ghc-options: -Wall -fwarn-tabs + build-depends: + aeson + , base >=4.10 && <5 + , base64-bytestring + , blaze-builder + , bytestring + , case-insensitive + , crypto-random + , cryptohash + , exceptions + , hspec + , hspec-expectations + , http-client + , http-client-tls + , http-types + , mtl + , network + , network-uri + , oauthenticated + , text + , time + , transformers + other-modules: + Config + SigningSpec + Paths_oauthenticated + default-language: Haskell2010 diff --git a/src/Network/OAuth/MuLens.hs b/src/Network/OAuth/MuLens.hs --- a/src/Network/OAuth/MuLens.hs +++ b/src/Network/OAuth/MuLens.hs @@ -21,7 +21,6 @@ (<&>), (&), (^.), (.~), (%~), ) where -import Control.Applicative import Data.Functor.Identity import Data.Functor.Constant 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,7 +36,6 @@ ) where import qualified Blaze.ByteString.Builder as Blz -import Control.Applicative import Crypto.Hash.SHA1 (hash) import Crypto.MAC.HMAC (hmac) import Crypto.Random @@ -143,18 +142,29 @@ infix 8 -: s -: v = (s, H.toQueryValue v) + -- **NOTE** dfithian: It worked for my use case to move oauth_token into these params. From the + -- PR: + -- + -- I presume one very controversial thing I did was to move `oauth_token` into `workflowParams`. + -- I came to this conclusion by skimming through the [RFC](https://tools.ietf.org/html/rfc5849) + -- and deciding that since I only ever saw `oauth_token` in conjunction with either + -- `oauth_callback` or `oauth_verifier` that they should go together. I'd be perfectly happy to + -- instead pass in some function of the settings telling it whether or not to include + -- `oauth_token` for a given request. Whatever the conclusion, the service I'm integrating to + -- specifically does NOT want the `oauth_token` so that was the motivation. workflowParams Standard = [] workflowParams (TemporaryTokenRequest callback) = - [ "oauth_callback" -: callback ] + [ "oauth_callback" -: callback + , "oauth_token" -: (getResourceTokenDef credentials ^. key) ] workflowParams (PermanentTokenRequest verifier) = - [ "oauth_verifier" -: verifier ] + [ "oauth_verifier" -: verifier + , "oauth_token" -: (getResourceTokenDef credentials ^. key) ] in [ "oauth_version" -: oAuthVersion , "oauth_consumer_key" -: (credentials ^. clientToken . key) , "oauth_signature_method" -: signatureMethod - , "oauth_token" -: (getResourceTokenDef credentials ^. key) , "oauth_timestamp" -: timestamp , "oauth_nonce" -: nonce ] ++ workflowParams workflow @@ -174,8 +184,8 @@ -- | Queries a 'C.Request' body and tries to interpret it as a set of OAuth -- valid parameters. It makes the assumption that if the body type is a --- streaming variety then it is /not/ a set of OAuth parameters---dropping this --- assumption would prevent this from being pure. +-- streaming variety or impure then it is /not/ a set of OAuth parameters--- +-- dropping this assumption would prevent this from being pure. bodyParams :: C.Request -> H.Query bodyParams = digestBody . C.requestBody where digestBody :: C.RequestBody -> H.Query @@ -184,6 +194,7 @@ digestBody (C.RequestBodyBuilder _ b) = H.parseQuery (Blz.toByteString b) digestBody (C.RequestBodyStream _ _) = [] digestBody (C.RequestBodyStreamChunked _) = [] + digestBody (C.RequestBodyIO _) = [] -- digestBody (Left (_, builder)) = H.parseQuery (Blz.toByteString builder) -- digestBody (Right _) = [] 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 @@ -59,11 +59,10 @@ ) where -import Control.Applicative import qualified Control.Monad.Catch as E import Control.Monad.Reader import Control.Monad.State -import Control.Monad.Trans.Either +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 @@ -186,29 +185,20 @@ :: (Functor m, MonadIO m, E.MonadCatch m) => C.Manager -> (URI -> m O.Verifier) -> OAuthT O.Client m (Either TokenRequestFailure (O.Cred O.Permanent)) -requestTokenProtocol man getVerifier = runEitherT $ do +requestTokenProtocol man getVerifier = runExceptT $ do -- Most of the code here is very simple, except that it does a LOT of -- exception lifting. Try to ignore the EitherT noise on the left side -- of each line. - tempResp <- liftE OnTemporaryRequest $ E.try (requestTemporaryToken man) - ttok <- upE BadTemporaryToken $ C.responseBody tempResp + tempResp <- withExceptT OnTemporaryRequest $ ExceptT $ E.try (requestTemporaryToken man) + ttok <- withExceptT BadTemporaryToken $ ExceptT $ pure $ C.responseBody tempResp upgradeE ttok $ do verifier <- lift $ buildAuthorizationUrl >>= lift . getVerifier - permResp <- liftE OnPermanentRequest $ E.try (requestPermanentToken man verifier) - ptok <- upE BadPermanentToken $ C.responseBody permResp + permResp <- withExceptT OnPermanentRequest $ ExceptT $ E.try (requestPermanentToken man verifier) + ptok <- withExceptT BadPermanentToken $ ExceptT $ pure $ C.responseBody permResp lift $ upgradeCred ptok where - -- These functions explain most of the EitherT noise. They're largely - -- useful for lifting default EitherT responses up into the error type - -- we want. - mapE :: Functor m => (e -> f) -> EitherT e m b -> EitherT f m b - mapE f = bimapEitherT f id - liftE :: Functor m => (e -> f) -> m (Either e b) -> EitherT f m b - liftE f = mapE f . EitherT - upE :: (Monad m, Functor m) => (e -> f) -> Either e b -> EitherT f m b - upE f = liftE f . return -- This is just 'upgrade' played out in the EitherT monad. upgradeE :: (Monad m, Cred.ResourceToken ty') => Cred.Token ty' - -> EitherT e (OAuthT ty' m) a -> EitherT e (OAuthT ty m) a - upgradeE tok = EitherT . upgrade tok . runEitherT + -> ExceptT e (OAuthT ty' m) a -> ExceptT e (OAuthT ty m) a + upgradeE tok = ExceptT . upgrade tok . runExceptT 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,8 +30,6 @@ requestTokenProtocol, requestTokenProtocol' ) where -import Control.Applicative -import Control.Exception as E import qualified Crypto.Random as R import qualified Data.ByteString.Lazy as SL import Data.Data @@ -78,9 +76,9 @@ -- callback URLs could not be parsed correctly. parseThreeLegged :: String -> String -> String -> P.Callback -> Maybe ThreeLegged parseThreeLegged a b c d = - ThreeLegged <$> C.parseUrl a - <*> C.parseUrl b - <*> C.parseUrl c + ThreeLegged <$> C.parseRequest a + <*> C.parseRequest b + <*> C.parseRequest c <*> pure d -- | Request a 'Temporary' 'Token' based on the parameters of @@ -171,18 +169,18 @@ -> IO (Maybe (O.Cred O.Permanent)) requestTokenProtocol' mset cr srv tl getVerifier = do entropy <- R.createEntropyPool - E.bracket (C.newManager mset) C.closeManager $ \man -> do - let gen = (R.cprgCreate entropy :: R.SystemRNG) - (respTempToken, gen') <- requestTemporaryToken cr srv tl man gen - 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' - case C.responseBody respPermToken of - Left _ -> return Nothing - Right tok' -> return (Just $ O.permanentCred tok' cr) + man <- C.newManager mset + let gen = (R.cprgCreate entropy :: R.SystemRNG) + (respTempToken, gen') <- requestTemporaryToken cr srv tl man gen + 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' + case C.responseBody respPermToken of + Left _ -> return Nothing + Right tok' -> return (Just $ O.permanentCred tok' cr) -- | Performs an interactive token request provided credentials, -- configuration, and a way to convert a user authorization 'URI' into 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,7 +19,6 @@ module Network.OAuth.Types.Params where -import Control.Applicative import Crypto.Random import qualified Data.ByteString as S import qualified Data.ByteString.Base64 as S64 diff --git a/test/Config.hs b/test/Config.hs new file mode 100644 --- /dev/null +++ b/test/Config.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +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 + , ser :: Server + , cred :: Cred Client + , url :: String + } + +loadConfig :: IO Config +loadConfig = do + -- these are on the public internet so they're okay + 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 new file mode 100644 --- /dev/null +++ b/test/SigningSpec.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE RecordWildCards #-} + +module SigningSpec where + +import Control.Monad +import Network.HTTP.Client (httpLbs, parseRequest, 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)) + +spec :: Config -> Spec +spec Config {..} = describe "signing" $ do + it "authorizes a request" $ do + req <- parseRequest url + (signedReq, _) <- oauth cred ser req rng + 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 + resp <- httpLbs signedReq man + pure (newGen, resp:acc) + ) (rng, []) (replicate 100 req) + forM_ resps $ \ resp -> + example $ responseStatus resp `shouldBe` status200 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,10 @@ +import Test.Hspec (hspec) + +import Config (loadConfig) +import qualified SigningSpec + +main :: IO () +main = do + config <- loadConfig + hspec $ do + SigningSpec.spec config