oauthenticated 0.0.5 → 0.1.0
raw patch · 9 files changed
+467/−377 lines, 9 filesdep +eitherdep −contravariantdep ~aesondep ~base64-bytestringdep ~blaze-builder
Dependencies added: either
Dependencies removed: contravariant
Dependency ranges changed: aeson, base64-bytestring, blaze-builder, bytestring, case-insensitive, crypto-random, cryptohash, exceptions, http-client, http-types, mtl, network, time
Files
- oauthenticated.cabal +23/−23
- src/Network/OAuth.hs +51/−82
- src/Network/OAuth/MuLens.hs +5/−37
- src/Network/OAuth/Signing.hs +21/−16
- src/Network/OAuth/Simple.hs +213/−0
- src/Network/OAuth/Stateful.hs +0/−133
- src/Network/OAuth/ThreeLegged.hs +130/−68
- src/Network/OAuth/Types/Credentials.hs +18/−11
- src/Network/OAuth/Types/Params.hs +6/−7
oauthenticated.cabal view
@@ -1,6 +1,6 @@ name: oauthenticated-version: 0.0.5-synopsis: Simple OAuth client code built atop http-conduit+version: 0.1.0+synopsis: Simple OAuth for http-client description: /Warning/: This software is pre 1.0 and thus its API may change very@@ -14,11 +14,11 @@ . @oauthenticated@ is a Haskell library implementing OAuth protocols atop the minimalistic @http-client@ HTTP client library extracted from @http-conduit@.- It offers a simplified main API in "Network.OAuth" which provides simplistic,- authenticated @GET@ and @POST@ requests atop OAuth using a trivial state- monad. It also offers a lower-level API in "Network.OAuth.Signing" which can- be used to sign arbitrary requests while intercepting and modifying the OAuth- parameter set. + "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@@ -43,29 +43,29 @@ library exposed-modules: Network.OAuth- Network.OAuth.MuLens+ Network.OAuth.Simple Network.OAuth.Signing- Network.OAuth.Stateful 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.7- , aeson- , base64-bytestring- , blaze-builder- , bytestring- , case-insensitive- , contravariant- , crypto-random- , cryptohash- , http-client- , http-types- , exceptions- , mtl- , network- , time+ , aeson >= 0.6.2 && < 0.7+ , base64-bytestring >= 1.0 && < 1.1+ , blaze-builder >= 0.3+ , bytestring >= 0.9+ , case-insensitive >= 1.0 && < 1.2+ , crypto-random >= 0.0.7+ , cryptohash >= 0.11 && < 0.12+ , either >= 4.0 && < 5.0+ , exceptions >= 0.3 && < 0.4+ , http-client >= 0.2.0+ , http-types >= 0.8+ , mtl >= 2.0+ , network >= 2.3+ , time >= 1.2 , transformers hs-source-dirs: src
src/Network/OAuth.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE TupleSections #-}- -- | -- Module : Network.OAuth -- Copyright : (c) Joseph Abrahamson 2013@@ -9,95 +7,66 @@ -- Stability : experimental -- Portability : non-portable ----- "Network.OAuth" provides simple OAuth signed requests atop--- "Network.HTTP.Client". This module exports a simplified interface atop--- the monadic interface defined in "Network.OAuth.Stateful".+-- OAuth tools for using @http-client@ for authenticated requests. ----- If more control is needed, the low-level functions for creating, customizing,--- and managing OAuth 'Cred'entials, 'Token's, and parameter sets ('Oa')--- are using them to sign 'Network.HTTP.Client.Types.Request's are--- available in "Network.OAuth.Types.Params",--- "Network.OAuth.Types.Credentials", and "Network.OAuth.Signing".-+-- The functions here form the simplest basis for sending OAuthenticated+-- 'C.Request's. In order to generate credentials according to the OAuth+-- "three-legged workflow" use actions in the "Network.OAuth.ThreeLegged"+-- module.+-- module Network.OAuth ( - -- * The basic monadic API- oauth,-- -- * Simplified requests layer- simpleOAuth, Params (..), Query, QueryItem,-- -- * OAuth Monad+ -- * Authenticating a request --- -- The 'OAuthT' monad is nothing more than a 'Control.Monad.State.StateT'- -- transformer containing OAuth state.- OAuthT, runOAuthT, runOAuthT',-- -- * OAuth Configuration+ -- | The 'oauthSimple' function can be used to sign a 'C.Request' as it+ -- stands. It should be performed just before the 'C.Request' is used as+ -- it uses the current timestamp and thus may only be valid for a limited+ -- amount of time. --- -- OAuth requests are parameterized by 'Server' configuration and client- -- 'Cred'entials. These can be modified within an 'OAuthT' thread by using- -- the 'Network.OAuth.MuLens.Lens'es in "Network.OAuth.Stateful".- Server (..), ParameterMethod (..), SignatureMethod (..), Version (..),- defaultServer,+ -- 'oauthSimple' creates a /new/ random entropy pool every time it is+ -- called, thus it can be both slow and cryptographically dangerous to+ -- use it repeatedly as it can drain system entropy. Instead, the plain 'S.oauth'+ -- function should be used which allows for threading of the random+ -- source.+ --+ oauthSimple, S.oauth, - -- ** Credential managerment+ -- * Lower-level and pure functionality --- -- Credentials are parameterized by 3 types- Permanent, Temporary, Client,+ -- | When necessary to control or observe the signature more+ -- carefully, the lower level API can be used. This requires generating+ -- 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, - -- And are composed of both 'Token's and 'Cred'entials.- Cred, Token (..),- clientCred, temporaryCred, permanentCred,+ -- * OAuth Credentials+ O.Token (..), O.Cred, O.Client, O.Temporary, O.Permanent, - -- ** Access lenses- key, secret, clientToken, resourceToken- ) where+ -- ** Creating Credentials + O.clientCred, O.temporaryCred, O.permanentCred,+ O.fromUrlEncoded, -import Control.Applicative-import Control.Monad.Catch-import Control.Monad.Trans-import qualified Data.ByteString.Lazy as SL-import Data.Maybe (mapMaybe)-import Network.HTTP.Client (httpLbs)-import Network.HTTP.Client.Request (parseUrl, urlEncodedBody)-import Network.HTTP.Client.Response (Response)-import Network.HTTP.Client.Types (HttpException, method,- queryString)-import Network.HTTP.Types (Query, QueryItem, methodGet,- renderQuery)-import Network.OAuth.Stateful-import Network.OAuth.Types.Credentials (Client, Cred, Permanent,- Temporary, Token (..),- clientCred, clientToken, key,- permanentCred, resourceToken,- secret, temporaryCred)-import Network.OAuth.Types.Params (ParameterMethod (..),- Server (..),- SignatureMethod (..),- Version (..), defaultServer)+ -- * OAuth Configuration+ O.Server (..), O.defaultServer,+ O.ParameterMethod (..), O.SignatureMethod (..), O.Version (..), --- | 'Params' quickly set the parameterization of a 'Request', either--- a @GET@ request with a query string or a @POST@ request with--- a @www-form-urlencoded@ body.-data Params = QueryParams Query- | BodyParams Query+ ) where --- | Send an OAuth GET request to a particular URI. Throws an exception if--- the URI cannot be parsed or if errors occur during the request.-simpleOAuth- :: (MonadIO m, MonadCatch m) =>- String -> Params -> OAuthT ty m (Response SL.ByteString)-simpleOAuth url ps = case parseUrl url of- Left err -> lift $ throwM (err :: HttpException)- Right rq -> do- signedRq <- oauth $ addParams ps rq- withManager (liftIO . httpLbs signedRq)- where- addParams (QueryParams q) req =- req { method = methodGet- , queryString = renderQuery True q- }- addParams (BodyParams q) req =- let params = mapMaybe (\(a, b) -> (a,) <$> b) q- in urlEncodedBody params req+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.+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'
src/Network/OAuth/MuLens.hs view
@@ -14,38 +14,21 @@ module Network.OAuth.MuLens ( -- * Basics- Lens, view, use, preview, set,+ view, set, -- * Generalizations over, foldMapOf, -- * Building- lens,- -- * Tools- zoom,- -- * Convenience- (<&>), (&), (^.), (.~), (%~), (<~)+ (<&>), (&), (^.), (.~), (%~), ) where import Control.Applicative-import Control.Monad.Reader-import Control.Monad.State-import Data.Functor.Constant import Data.Functor.Identity-import Data.Monoid--type Lens s t a b = forall f . (Functor f) => (a -> f b) -> s -> f t+import Data.Functor.Constant -view :: MonadReader s m => ((a -> Constant a a) -> s -> Constant a s) -> m a-view inj = asks (foldMapOf inj id)+view :: ((a -> Constant a a) -> s -> Constant a s) -> s -> a+view inj = foldMapOf inj id {-# INLINE view #-} -use :: MonadState s m => ((a -> Constant a a) -> s -> Constant a s) -> m a-use inj = foldMapOf inj id `liftM` get-{-# INLINE use #-}--preview :: ((a -> Constant (First a) a) -> s -> Constant (First a) s) -> s -> Maybe a-preview l = getFirst . foldMapOf l (First . Just)-{-# INLINE preview #-}- over :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t over inj f = runIdentity . inj (Identity . f) {-# INLINE over #-}@@ -58,17 +41,6 @@ foldMapOf inj f = getConstant . inj (Constant . f) {-# INLINE foldMapOf #-} -zoom :: Monad m => Lens s s t t -> StateT t m a -> StateT s m a-zoom l m = do- t <- use l- (a, t') <- lift $ runStateT m t- modify (l .~ t')- return a--lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b-lens gt st inj x = st x <$> inj (gt x)-{-# INLINE lens #-}- infixl 5 <&> (<&>) :: Functor f => f a -> (a -> b) -> f b (<&>) = flip (<$>)@@ -93,7 +65,3 @@ (%~) :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t (%~) = over {-# INLINE (%~) #-}--infixr 2 <~-(<~) :: MonadState s m => ((a -> Identity b) -> s -> Identity s) -> m b -> m ()-l <~ m = do { a <- m; modify (l .~ a) }
src/Network/OAuth/Signing.hs view
@@ -18,15 +18,15 @@ module Network.OAuth.Signing ( -- * Primary interface- + -- | The 'oauth' and 'sign' commands can be used as low level signing -- primitives, and they are indeed used to build the "Network.OAuth.Stateful" -- interface exported by default.- + oauth, sign, -- * Low-level interface- + -- | The low-level interface is used to build 'oauth' and 'sign' and can be -- useful for testing. @@ -39,16 +39,16 @@ import Control.Applicative import Crypto.Hash.SHA1 (hash) import Crypto.MAC.HMAC (hmac)+import Crypto.Random import qualified Data.ByteString as S import qualified Data.ByteString.Base64 as S64 import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as SL import Data.Char (toUpper)-import Data.Int (Int64) import Data.List (sort) import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid-import qualified Network.HTTP.Client.Request as C-import qualified Network.HTTP.Client.Types as C+import qualified Network.HTTP.Client as C import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.QueryLike as H import Network.OAuth.MuLens@@ -56,7 +56,6 @@ import Network.OAuth.Types.Params import Network.OAuth.Util import Network.URI-import Crypto.Random -- | Sign a request with a fresh set of parameters. oauth :: CPRG gen => Cred ty -> Server -> C.Request -> gen -> IO (C.Request, gen)@@ -96,7 +95,7 @@ let replaceHeader :: H.HeaderName -> S.ByteString -> H.RequestHeaders -> H.RequestHeaders replaceHeader n b [] = [(n, b)] replaceHeader n b (x@(hn, _):rest) | n == hn = (n, b):rest- | otherwise = x : replaceHeader n b rest+ | otherwise = x : replaceHeader n b rest authHeader = "OAuth " <> S8.intercalate ", " pairs pairs = map mkPair q mkPair (k, v) = k <> "=\"" <> fromMaybe "" v <> "\""@@ -111,7 +110,7 @@ canonicalBaseString :: Oa ty -> Server -> C.Request -> S.ByteString canonicalBaseString oax server req = S8.intercalate "&" [ S8.map toUpper (C.method req)- , canonicalUri req+ , canonicalUri req , canonicalParams oax server req ] @@ -161,9 +160,9 @@ fauthority Nothing = "" fauthority (Just (URIAuth {..})) = let -- Canonical URIs do not display their port unless it is non-standard- fport | (uriPort == ":443") && (uriScheme == "https:") = ""- | (uriPort == ":80" ) && (uriScheme == "http:" ) = ""- | otherwise = uriPort+ fport | (uriPort == ":443") && (uriScheme == "https:") = ""+ | (uriPort == ":80" ) && (uriScheme == "http:" ) = ""+ | otherwise = uriPort in uriRegName <> fport -- | Queries a 'C.Request' body and tries to interpret it as a set of OAuth@@ -171,10 +170,16 @@ -- streaming variety 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.simplify . C.requestBody where- digestBody :: Either (Int64, Blz.Builder) (Maybe Int64, C.GivesPopper ()) -> H.Query- digestBody (Left (_, builder)) = H.parseQuery (Blz.toByteString builder)- digestBody (Right _) = []+bodyParams = digestBody . C.requestBody where+ digestBody :: C.RequestBody -> H.Query+ digestBody (C.RequestBodyLBS lbs) = H.parseQuery (SL.toStrict lbs)+ digestBody (C.RequestBodyBS bs) = H.parseQuery bs+ digestBody (C.RequestBodyBuilder _ b) = H.parseQuery (Blz.toByteString b)+ digestBody (C.RequestBodyStream _ _) = []+ digestBody (C.RequestBodyStreamChunked _) = []++ -- digestBody (Left (_, builder)) = H.parseQuery (Blz.toByteString builder)+ -- digestBody (Right _) = [] queryParams :: C.Request -> H.Query queryParams = H.parseQuery . C.queryString
+ src/Network/OAuth/Simple.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- |+-- Module : Network.OAuth.Simple+-- Copyright : (c) Joseph Abrahamson 2013+-- License : MIT+--+-- Maintainer : me@jspha.com+-- Stability : experimental+-- Portability : non-portable+--+-- Simplified Monadic interface for managing @http-client@ and+-- @oauthenticated@ state. Re-exposes all of the functionality from+-- "Network.OAuth" and "Network.OAuth.ThreeLegged".+--+module Network.OAuth.Simple (++ -- * A monad for authenticated requests+ --+ -- | "Network.OAuth.Simple" re-exports the "Network.OAuth" and+ -- "Network.Oauth.ThreeLegged" interfaces using the obvious 'StateT' and 'ReaderT'+ -- wrappers for tracking configuration, credentials, and random generator state.+ -- Managing 'C.Manager' state is out of scope for this module, but since 'OAuthT'+ -- is a monad transformer, it's easy enough to add another layer with the needed+ -- state.++ oauth, runOAuthSimple,++ -- ** More sophisticated interface+ runOAuth, runOAuthT, OAuthT (..), OAuth,++ -- * Configuration management+ upgradeCred, upgrade,++ -- * Configuration re-exports++ -- ** OAuth Credentials+ O.Token (..), O.Cred, O.Client, O.Temporary, O.Permanent,++ -- *** Creating Credentials+ O.clientCred, O.temporaryCred, O.permanentCred,+ O.fromUrlEncoded,++ -- ** OAuth Configuration+ O.Server (..), O.defaultServer,+ O.ParameterMethod (..), O.SignatureMethod (..), O.Version (..),++ -- ** Three-Legged Authorization++ -- *** Configuration types+ O.ThreeLegged (..), O.parseThreeLegged, O.Callback (..),+ O.Verifier,++ -- *** Actions+ requestTemporaryToken, buildAuthorizationUrl, requestPermanentToken,++ -- *** Example System+ requestTokenProtocol, TokenRequestFailure (..)++ ) 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 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+import qualified Network.OAuth.ThreeLegged as O+import qualified Network.OAuth.Types.Credentials as Cred+import Network.URI (URI)++data OaConfig ty =+ OaConfig { cred :: O.Cred ty+ , server :: O.Server+ , threeLegged :: O.ThreeLegged+ }++-- | 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 }+ deriving ( Functor, Applicative, Monad+ , MonadReader (OaConfig ty)+ , MonadState R.SystemRNG+ , E.MonadCatch+ , MonadIO+ )+instance MonadTrans (OAuthT ty) where lift = OAuthT . lift . lift++-- | 'OAuthT' wrapped over 'IO'.+type OAuth ty = OAuthT ty IO++-- | Run's an 'OAuthT' using a fresh 'R.EntropyPool'.+runOAuthT+ :: (MonadIO m) =>+ 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)++runOAuth :: OAuth ty a -> O.Cred ty -> O.Server -> O.ThreeLegged -> IO a+runOAuth = runOAuthT++-- | The simplest way to execute a set of authenticated requests. Produces+-- invalid 'ThreeLegged' requests---use 'runOAuth' to provide 'O.Server' and+-- 'O.ThreeLegged' configuration information.+runOAuthSimple :: OAuth ty a -> O.Cred ty -> IO a+runOAuthSimple oat cr = runOAuth oat cr O.defaultServer tl where+ Just tl = O.parseThreeLegged "http://example.com"+ "http://example.com"+ "http://example.com"+ O.OutOfBand++upgradeCred :: (Cred.ResourceToken ty', Monad m) => O.Token ty' -> OAuthT ty m (O.Cred ty')+upgradeCred tok = liftM (Cred.upgradeCred tok . cred) ask++-- | Given a 'Cred.ResourceToken' of some kind, run an inner 'OAuthT' session+-- 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++liftBasic :: MonadIO m => (R.SystemRNG -> OaConfig ty -> IO (a, R.SystemRNG)) -> OAuthT ty m a+liftBasic f = do+ gen <- get+ conf <- ask+ (a, gen') <- liftIO (f gen conf)+ put gen'+ return a++-- | 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++-- Three-Legged Authorization+--------------------------------------------------------------------------------++requestTemporaryToken+ :: MonadIO m => C.Manager ->+ OAuthT O.Client m (C.Response (Either SL.ByteString (O.Token O.Temporary)))+requestTemporaryToken man =+ liftBasic $ \gen conf ->+ O.requestTemporaryToken (cred conf)+ (server conf)+ (threeLegged conf)+ man+ gen++buildAuthorizationUrl :: Monad m => OAuthT O.Temporary m URI+buildAuthorizationUrl = do+ conf <- ask+ return $ O.buildAuthorizationUrl (cred conf) (threeLegged conf)++requestPermanentToken+ :: 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 ->+ O.requestPermanentToken (cred conf)+ (server conf)+ ver+ (threeLegged conf)+ man+ gen++data TokenRequestFailure =+ OnTemporaryRequest C.HttpException+ | BadTemporaryToken SL.ByteString+ | OnPermanentRequest C.HttpException+ | BadPermanentToken SL.ByteString+ deriving ( Show )++-- | Run a full Three-legged authorization protocol using the simple interface+-- of this module. This is similar to the 'O.requestTokenProtocol' in+-- "Network.OAuth.ThreeLegged", but offers better error handling due in part to+-- the easier management of configuration state.+requestTokenProtocol+ :: (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+ -- 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+ upgradeE ttok $ do+ verifier <- lift $ buildAuthorizationUrl >>= lift . getVerifier+ permResp <- liftE OnPermanentRequest $ E.try (requestPermanentToken man verifier)+ ptok <- upE BadPermanentToken $ 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
− src/Network/OAuth/Stateful.hs
@@ -1,133 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module : Network.OAuth.Stateful--- Copyright : (c) Joseph Abrahamson 2013--- License : MIT------ Maintainer : me@jspha.com--- Stability : experimental--- Portability : non-portable-----module Network.OAuth.Stateful-(- -- * An OAuth Monad Transformer- OAuth, runOAuth,- OAuthT, runOAuthT, runOAuthT',-- -- * Standard operations-- -- | These operations are similar to those exposed by- -- "Network.OAuth.Types.Params" or "Network.OAuth.Signing" but use the- -- OAuth monad state instead of needing manual threading.- oauth, sign, newParams,-- -- * OAuth State- withGen, withManager, withCred, getServer, getCredentials, -- )- where--import Control.Applicative-import Control.Monad.Catch-import Control.Monad.State-import Crypto.Random-import Network.HTTP.Client.Types (Request)-import Network.OAuth.MuLens-import qualified Network.OAuth.Signing as S-import Network.OAuth.Types.Credentials (Cred, Token, clientCred,- clientToken, resourceToken)-import Network.OAuth.Types.Params (Server (..))-import qualified Network.OAuth.Types.Params as P--import Network.HTTP.Client.Manager (Manager, ManagerSettings, closeManager,- defaultManagerSettings, newManager)---- | A simple monad suitable for basic OAuth requests.-newtype OAuthT ty m a =- OAuthT { unOAuthT :: StateT (OAuthConfig ty) m a }- deriving ( Functor, Applicative, Monad, MonadIO )--type OAuth ty a = OAuthT ty IO a--instance MonadTrans (OAuthT ty) where- lift = OAuthT . lift--runOAuth :: Cred ty -> Server -> OAuth ty a -> IO a-runOAuth = runOAuthT--runOAuthT :: (MonadIO m, MonadCatch m) => Cred ty -> Server -> OAuthT ty m a -> m a-runOAuthT = runOAuthT' defaultManagerSettings--runOAuthT' :: (MonadIO m, MonadCatch m) => ManagerSettings -> Cred ty -> Server -> OAuthT ty m a -> m a-runOAuthT' settings creds srv m = do- pool <- liftIO createEntropyPool- bracket (liftIO $ newManager settings) (liftIO . closeManager) $ \man ->- let conf = OAuthConfig man (cprgCreate pool) srv creds- in evalStateT (unOAuthT m) conf---- | Generate default OAuth parameters and use them to sign a request. This--- is the simplest OAuth method.-oauth :: MonadIO m => Request -> OAuthT ty m Request-oauth req = newParams >>= flip sign req---- | 'OAuthT' retains a cryptographic random generator state.-withGen :: Monad m => (SystemRNG -> m (a, SystemRNG)) -> OAuthT ty m a-withGen = OAuthT . zoom crng . StateT---- | 'OAuthT' retains a "Network.HTTP.Client" 'Manager'. The 'Manager' is--- created at the beginning of an 'OAuthT' thread and destroyed at the end,--- so it's efficient to pipeline many OAuth requests together.-withManager :: Monad m => (Manager -> m a) -> OAuthT ty m a-withManager f = OAuthT $ zoom manager (get >>= lift . f)---- | Create a fresh set of parameters.-newParams :: MonadIO m => OAuthT ty m (P.Oa ty)-newParams = do- px <- withGen (liftIO . P.freshPin)- c <- OAuthT $ use credentials- return P.Oa { P.credentials = c- , P.workflow = P.Standard- , P.pin = px- }---- | Sign a request using a set of parameters, 'P.Oa'.-sign :: Monad m => P.Oa ty -> Request -> OAuthT ty m Request-sign oax req = do- s <- OAuthT $ use server- return (S.sign oax s req)--withCred :: Monad m => Cred ty -> OAuthT ty m a -> OAuthT ty' m a-withCred c op = OAuthT $ do- s <- get- lift $ evalStateT (unOAuthT op) (s & credentials .~ c)--data OAuthConfig ty =- OAuthConfig {-# UNPACK #-} !Manager- {-# UNPACK #-} !SystemRNG- {-# UNPACK #-} !Server- !(Cred ty)--getServer :: Monad m => OAuthT ty m Server-getServer = OAuthT (use server)--getCredentials :: Monad m => OAuthT ty m (Cred ty)-getCredentials = OAuthT (use credentials)--manager :: Lens (OAuthConfig ty) (OAuthConfig ty) Manager Manager-manager inj (OAuthConfig m rng sv c) = (\m' -> OAuthConfig m' rng sv c) <$> inj m-{-# INLINE manager #-}--crng :: Lens (OAuthConfig ty) (OAuthConfig ty) SystemRNG SystemRNG-crng inj (OAuthConfig m rng sv c) = (\rng' -> OAuthConfig m rng' sv c) <$> inj rng-{-# INLINE crng #-}--server :: Lens (OAuthConfig ty) (OAuthConfig ty) Server Server-server inj (OAuthConfig m rng sv c) = (\sv' -> OAuthConfig m rng sv' c) <$> inj sv-{-# INLINE server #-}--credentials :: Lens (OAuthConfig ty) (OAuthConfig ty') (Cred ty) (Cred ty')-credentials inj (OAuthConfig m rng sv c) = OAuthConfig m rng sv <$> inj c-{-# INLINE credentials #-}
src/Network/OAuth/ThreeLegged.hs view
@@ -16,8 +16,10 @@ module Network.OAuth.ThreeLegged ( -- * Configuration types- ThreeLegged (..), parseThreeLegged, Callback (..),+ ThreeLegged (..), parseThreeLegged, P.Callback (..), + P.Verifier,+ -- * Actions requestTemporaryToken, buildAuthorizationUrl, requestPermanentToken, @@ -25,24 +27,20 @@ requestTemporaryTokenRaw, requestPermanentTokenRaw, -- * Example system- requestTokenProtocol+ requestTokenProtocol, requestTokenProtocol' ) where import Control.Applicative-import Control.Monad.Trans-import Control.Monad.Trans.Maybe+import Control.Exception as E+import qualified Crypto.Random as R import qualified Data.ByteString.Lazy as SL-import qualified Data.ByteString as S import Data.Data-import Network.HTTP.Client (httpLbs)-import Network.HTTP.Client.Request (getUri,parseUrl)-import Network.HTTP.Client.Types (Request (..), Response (..), HttpException)+import qualified Network.HTTP.Client as C import Network.HTTP.Types (renderQuery)-import Network.OAuth+import qualified Network.OAuth as O import Network.OAuth.MuLens-import Network.OAuth.Stateful-import Network.OAuth.Types.Credentials-import Network.OAuth.Types.Params+import qualified Network.OAuth.Types.Credentials as Cred+import qualified Network.OAuth.Types.Params as P import Network.URI -- | Data parameterizing the \"Three-legged OAuth\" redirection-based@@ -50,98 +48,162 @@ -- in the community editions /OAuth Core 1.0/ and /OAuth Core 1.0a/ as well -- as RFC 5849. data ThreeLegged =- ThreeLegged { temporaryTokenRequest :: Request+ ThreeLegged { temporaryTokenRequest :: C.Request -- ^ Base 'Request' for the \"endpoint used by the client to -- obtain a set of 'Temporary' 'Cred'entials\" in the form of -- a 'Temporary' 'Token'. This request is automatically -- instantiated and performed during the first leg of the -- 'ThreeLegged' authorization protocol.- , resourceOwnerAuthorization :: Request+ , resourceOwnerAuthorization :: C.Request -- ^ Base 'Request' for the \"endpoint to which the resource -- owner is redirected to grant authorization\". This request -- must be performed by the user granting token authorization -- to the client. Transmitting the parameters of this request -- to the user is out of scope of @oauthenticated@, but -- functions are provided to make it easier.- , permanentTokenRequest :: Request+ , permanentTokenRequest :: C.Request -- ^ Base 'Request' for the \"endpoint used by the client to -- request a set of token credentials using the set of -- 'Temporary' 'Cred'entials\". This request is also -- instantiated and performed by @oauthenticated@ in order to -- produce a 'Permanent' 'Token'.- , callback :: Callback+ , callback :: P.Callback -- ^ The 'Callback' parameter configures how the user is -- intended to communicate the 'Verifier' back to the client. } deriving ( Show, Typeable ) -- | Convenience method for creating a 'ThreeLegged' configuration from--- a trio of URLs and a 'Callback'.-parseThreeLegged :: String -> String -> String -> Callback -> Either HttpException ThreeLegged-parseThreeLegged a b c d = ThreeLegged <$> parseUrl a <*> parseUrl b <*> parseUrl c <*> pure d+-- a trio of URLs and a 'Callback'. Returns 'Nothing' if one of the+-- 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+ <*> pure d -- | Request a 'Temporary' 'Token' based on the parameters of -- a 'ThreeLegged' protocol. This returns the raw response which should be -- encoded as @www-form-urlencoded@.-requestTemporaryTokenRaw :: MonadIO m => ThreeLegged -> OAuthT Client m SL.ByteString-requestTemporaryTokenRaw (ThreeLegged {..}) = do- oax <- newParams- req <- sign (oax { workflow = TemporaryTokenRequest callback }) temporaryTokenRequest- resp <- withManager (liftIO . httpLbs req)- return $ responseBody resp+--+-- 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+ let req = O.sign (oax { P.workflow = P.TemporaryTokenRequest callback }) srv temporaryTokenRequest+ lbs <- C.httpLbs req man+ return (lbs, gen') --- | Returns 'Nothing' if the response could not be decoded as a 'Token'.--- Importantly, in RFC 5849 compliant modes this requires that the token--- response includes @callback_confirmed=true@. See also--- 'requestTemporaryTokenRaw'.-requestTemporaryToken :: MonadIO m => ThreeLegged -> OAuthT Client m (Maybe (Token Temporary))-requestTemporaryToken tl = do- raw <- requestTemporaryTokenRaw tl- s <- getServer- let mayToken = fromUrlEncoded $ SL.toStrict raw- return $ do- (confirmed, tok) <- mayToken- case oAuthVersion s of- OAuthCommunity1 -> return tok- _ -> if confirmed then return tok else fail "Must be confirmed"+-- | Returns the raw result if the 'C.Response' could not be parsed as+-- a valid 'O.Token'. Importantly, in RFC 5849 compliant modes this+-- requires that the token response includes @callback_confirmed=true@. See+-- also 'requestTemporaryTokenRaw'.+--+-- 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')+ where+ tryParseToken lbs = case maybeParseToken lbs of+ Nothing -> Left lbs+ Just tok -> Right tok+ maybeParseToken lbs =+ do (confirmed, tok) <- O.fromUrlEncoded $ SL.toStrict lbs+ case P.oAuthVersion srv of+ O.OAuthCommunity1 -> return tok+ _ -> if confirmed then return tok else fail "Must be confirmed" -- | Produce a 'URI' which the user should be directed to in order to -- authorize a set of 'Temporary' 'Cred's.-buildAuthorizationUrl :: Monad m => ThreeLegged -> OAuthT Temporary m URI-buildAuthorizationUrl (ThreeLegged {..}) = do- c <- getCredentials- return $ getUri $ resourceOwnerAuthorization {- queryString = renderQuery True [ ("oauth_token", Just (c ^. resourceToken . key)) ]+buildAuthorizationUrl :: O.Cred O.Temporary -> ThreeLegged -> URI+buildAuthorizationUrl cr (ThreeLegged {..}) =+ C.getUri $ resourceOwnerAuthorization {+ C.queryString = renderQuery True [ ("oauth_token", Just (cr ^. Cred.resourceToken . Cred.key)) ] } -- | Request a 'Permanent 'Token' based on the parameters of -- a 'ThreeLegged' protocol. This returns the raw response which should be -- encoded as @www-form-urlencoded@.-requestPermanentTokenRaw :: MonadIO m => ThreeLegged -> Verifier -> OAuthT Temporary m SL.ByteString-requestPermanentTokenRaw (ThreeLegged {..}) verifier = do- oax <- newParams- req <- sign (oax { workflow = PermanentTokenRequest verifier }) permanentTokenRequest- resp <- withManager (liftIO . httpLbs req)- return $ responseBody resp+--+-- 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+ let req = O.sign (oax { P.workflow = P.PermanentTokenRequest verifier }) srv permanentTokenRequest+ lbs <- C.httpLbs req man+ return (lbs, gen') -- | Returns 'Nothing' if the response could not be decoded as a 'Token'. -- See also 'requestPermanentTokenRaw'.-requestPermanentToken :: MonadIO m => ThreeLegged -> Verifier -> OAuthT Temporary m (Maybe (Token Permanent))-requestPermanentToken tl verifier = do- raw <- requestPermanentTokenRaw tl verifier- return $ fmap snd $ fromUrlEncoded $ SL.toStrict raw+--+-- 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')+ where+ tryParseToken lbs = case maybeParseToken lbs of+ Nothing -> Left lbs+ Just tok -> Right tok+ maybeParseToken = fmap snd . O.fromUrlEncoded . SL.toStrict --- | Performs an interactive token request over stdin assuming that the--- verifier code is acquired out-of-band.-requestTokenProtocol :: MonadIO m => ThreeLegged -> OAuthT Client m (Maybe (Token Permanent))-requestTokenProtocol threeLegged = runMaybeT $ do- cCred <- lift getCredentials- tok <- MaybeT (requestTemporaryToken threeLegged)- MaybeT $ withCred (temporaryCred tok cCred) $ do- url <- buildAuthorizationUrl threeLegged- code <- liftIO $ do - putStr "Please direct the user to the following address\n\n"- putStr " " >> print url >> putStr "\n\n"- putStrLn "... then enter the verification code below (no spaces)\n"- S.getLine- requestPermanentToken threeLegged code+-- | 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' 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)++-- | Performs an interactive token request provided credentials,+-- configuration, and a way to convert a user authorization 'URI' into+-- a 'P.Verifier' out of band. Does not use any kind of TLS protection---it+-- 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 = requestTokenProtocol' C.defaultManagerSettings+++ -- cCred <- lift getCredentials+ -- tok <- MaybeT (requestTemporaryToken threeLegged)+ -- MaybeT $ withCred (temporaryCred tok cCred) $ do+ -- url <- buildAuthorizationUrl threeLegged+ -- code <- liftIO $ do+ -- putStr "Please direct the user to the following address\n\n"+ -- putStr " " >> print url >> putStr "\n\n"+ -- putStrLn "... then enter the verification code below (no spaces)\n"+ -- S.getLine+ -- requestPermanentToken threeLegged code
src/Network/OAuth/Types/Credentials.hs view
@@ -38,7 +38,7 @@ fromUrlEncoded, -- * Credentials and credential construction- Cred, clientCred, temporaryCred, permanentCred,+ Cred, clientCred, temporaryCred, permanentCred, upgradeCred, -- * Accessors key, secret, clientToken, resourceToken, getResourceTokenDef, signingKey@@ -51,7 +51,6 @@ import Data.Data import Data.Monoid import Network.HTTP.Types (parseQuery, urlEncode)-import Network.OAuth.MuLens import Network.OAuth.Util -- Constructors aren't exported. They're only used for derivation@@ -90,10 +89,16 @@ deriving ( Show, Eq, Ord, Data, Typeable ) class ResourceToken tk where+ upgradeCred' :: Token tk -> Cred tk' -> Cred tk+ upgradeCred' tok (Cred k s ) = CredAndToken k s tok+ upgradeCred' tok (CredAndToken k s _) = CredAndToken k s tok instance ResourceToken Temporary instance ResourceToken Permanent +upgradeCred :: ResourceToken tk => Token tk -> Cred tk' -> Cred tk+upgradeCred = upgradeCred'+ -- | Parses a JSON object with keys @oauth_token@ and @oauth_token_secret@, the -- standard format for OAuth 1.0. instance FromJSON (Token ty) where@@ -128,11 +133,13 @@ lookupV k = join . lookup k -key :: Lens (Token ty) (Token ty) Key Key+-- | Lens on the key component of a 'Token'.+key :: Functor f => (Key -> f Key) -> Token ty -> f (Token ty) key inj (Token k s) = (`Token` s) <$> inj k {-# INLINE key #-} -secret :: Lens (Token ty) (Token ty) Secret Secret+-- | Lens on the key secret component of a 'Token'.+secret :: Functor f => (Secret -> f Secret) -> Token ty -> f (Token ty) secret inj (Token k s) = Token k <$> inj s {-# INLINE secret #-} @@ -143,20 +150,20 @@ | CredAndToken {-# UNPACK #-} !Key {-# UNPACK #-} !Secret {-# UNPACK #-} !(Token ty) deriving ( Show, Eq, Ord, Data, Typeable ) --- | All 'Cred's have 'Client' 'Token' information.-clientToken :: Lens (Cred ty) (Cred ty) (Token Client) (Token Client)+-- | A lens on the client 'Token' in any 'Cred'.+clientToken :: Functor f => (Token Client -> f (Token Client)) -> Cred ty -> f (Cred ty) clientToken inj (Cred k s) = fixUp <$> inj (Token k s) where fixUp (Token k' s') = Cred k' s' clientToken inj (CredAndToken k s tok) = fixUp <$> inj (Token k s) where fixUp (Token k' s') = CredAndToken k' s' tok {-# INLINE clientToken #-} --- | Some 'Cred's have resource 'Token' information, i.e. either 'Temporary' or--- 'Permanent' credentials. This lens can be used to change the type of a--- 'Cred'.+-- | A lens focused on the resource 'Token' when available. The only+-- instances of 'ResourceToken' are 'Temporary' and 'Permanent'. This can+-- be used to upgrade 'Temporary' 'Cred's to 'Permanent' 'Cred's. resourceToken- :: (ResourceToken ty, ResourceToken ty') =>- Lens (Cred ty) (Cred ty') (Token ty) (Token ty')+ :: (ResourceToken ty, ResourceToken ty', Functor f) =>+ (Token ty -> f (Token ty')) -> Cred ty -> f (Cred ty') resourceToken inj (CredAndToken k s tok) = CredAndToken k s <$> inj tok {-# INLINE resourceToken #-}
src/Network/OAuth/Types/Params.hs view
@@ -27,8 +27,7 @@ import Data.Data import Data.Time import Data.Time.Clock.POSIX-import Network.HTTP.Client.Request (getUri)-import Network.HTTP.Client.Types (Request)+import qualified Network.HTTP.Client as Client import qualified Network.HTTP.Types.QueryLike as H import Network.OAuth.Types.Credentials import Network.OAuth.Util@@ -79,7 +78,7 @@ -- it is the modern standard. Some servers may only be compliant with an -- earlier OAuth version---this should be tested against each server, in -- particular the protocols defined in "Network.OAuth.ThreeLegged".-data Version = OAuthCommunity1 +data Version = OAuthCommunity1 -- ^ OAuth Core 1.0 Community Edition -- <<http://oauth.net/core/1.0>> | OAuthCommunity1a@@ -103,17 +102,17 @@ -- for the workflow. This 'Callback' method may be a URL where the parameters -- are returned to or the string @\"oob\"@ which indicates that the user is -- responsible for returning the @oauth_verifier@ to the client 'OutOfBand'.-data Callback = OutOfBand | Callback Request+data Callback = OutOfBand | Callback Client.Request deriving ( Typeable ) instance Show Callback where show OutOfBand = "OutOfBand"- show (Callback req) = "Callback <" ++ show (getUri req) ++ ">"+ show (Callback req) = "Callback <" ++ show (Client.getUri req) ++ ">" -- | Prints out in Epoch time format, a printed integer instance H.QueryValueLike Callback where toQueryValue OutOfBand = Just "oob"- toQueryValue (Callback req) = Just . pctEncode . S8.pack . show . getUri $ req+ toQueryValue (Callback req) = Just . pctEncode . S8.pack . show . Client.getUri $ req -- | An Epoch time format timestamp. newtype Timestamp = Timestamp UTCTime deriving ( Show, Eq, Ord, Data, Typeable )@@ -188,7 +187,7 @@ -- | Uses 'emptyPin' to create an empty set of params 'Oa'. emptyOa :: Cred ty -> Oa ty-emptyOa creds = +emptyOa creds = Oa { credentials = creds, workflow = Standard, pin = emptyPin } -- | Uses 'freshPin' to create a fresh, default set of params 'Oa'.