diff --git a/oauthenticated.cabal b/oauthenticated.cabal --- a/oauthenticated.cabal +++ b/oauthenticated.cabal @@ -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 diff --git a/src/Network/OAuth.hs b/src/Network/OAuth.hs --- a/src/Network/OAuth.hs +++ b/src/Network/OAuth.hs @@ -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' 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 @@ -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) } 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 @@ -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 diff --git a/src/Network/OAuth/Simple.hs b/src/Network/OAuth/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth/Simple.hs @@ -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 diff --git a/src/Network/OAuth/Stateful.hs b/src/Network/OAuth/Stateful.hs deleted file mode 100644 --- a/src/Network/OAuth/Stateful.hs +++ /dev/null @@ -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 #-} 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 @@ -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 diff --git a/src/Network/OAuth/Types/Credentials.hs b/src/Network/OAuth/Types/Credentials.hs --- a/src/Network/OAuth/Types/Credentials.hs +++ b/src/Network/OAuth/Types/Credentials.hs @@ -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 #-} 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 @@ -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 -- <> | 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'.