oauthenticated (empty) → 0.0.4
raw patch · 11 files changed
+1184/−0 lines, 11 filesdep +aesondep +basedep +base64-bytestringsetup-changed
Dependencies added: aeson, base, base64-bytestring, blaze-builder, bytestring, case-insensitive, contravariant, crypto-random, cryptohash, exceptions, http-client, http-client-tls, http-types, mtl, network, time, transformers
Files
- LICENSE +19/−0
- Setup.hs +2/−0
- oauthenticated.cabal +78/−0
- src/Network/OAuth.hs +103/−0
- src/Network/OAuth/MuLens.hs +99/−0
- src/Network/OAuth/Signing.hs +180/−0
- src/Network/OAuth/Stateful.hs +139/−0
- src/Network/OAuth/ThreeLegged.hs +147/−0
- src/Network/OAuth/Types/Credentials.hs +192/−0
- src/Network/OAuth/Types/Params.hs +208/−0
- src/Network/OAuth/Util.hs +17/−0
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2013, Joseph Abrahamson++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ oauthenticated.cabal view
@@ -0,0 +1,78 @@+name: oauthenticated+version: 0.0.4+synopsis: Simple OAuth client code built atop http-conduit++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@.+ 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. + .+ 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.++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++library+ exposed-modules:+ Network.OAuth+ Network.OAuth.MuLens+ Network.OAuth.Signing+ Network.OAuth.Stateful+ Network.OAuth.ThreeLegged+ Network.OAuth.Types.Credentials+ Network.OAuth.Types.Params+ other-modules:+ 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-client-tls+ , http-types+ , exceptions+ , mtl+ , network+ , time+ , transformers++ hs-source-dirs: src + ghc-options: -Wall+ default-language: Haskell2010++source-repository head+ type: git+ location: git://github.com/tel/oauthenticated.git
+ src/Network/OAuth.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE TupleSections #-}++-- |+-- Module : Network.OAuth+-- Copyright : (c) Joseph Abrahamson 2013+-- License : MIT+--+-- Maintainer : me@jspha.com+-- 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".+--+-- 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".++module Network.OAuth (++ -- * The basic monadic API+ oauth,++ -- * Simplified requests layer+ simpleOAuth, Params (..), Query, QueryItem,++ -- * OAuth Monad+ --+ -- The 'OAuthT' monad is nothing more than a 'Control.Monad.State.StateT'+ -- transformer containing OAuth state.+ OAuthT, runOAuthT, runOAuthT',++ -- * OAuth Configuration+ --+ -- 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,++ -- ** Credential managerment+ --+ -- Credentials are parameterized by 3 types+ Permanent, Temporary, Client,++ -- And are composed of both 'Token's and 'Cred'entials.+ Cred, Token (..),+ clientCred, temporaryCred, permanentCred,++ -- ** Access lenses+ key, secret, clientToken, resourceToken+ ) where++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)++-- | '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++-- | 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
+ src/Network/OAuth/MuLens.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- Module : Network.OAuth.MuLens+-- Copyright : (c) Joseph Abrahamson 2013+-- License : MIT+--+-- Maintainer : me@jspha.com+-- Stability : experimental+-- Portability : non-portable+--+-- Tiny, @Control.Lens@ compatibility layer.++module Network.OAuth.MuLens (+ -- * Basics+ Lens, view, use, preview, 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++view :: MonadReader s m => ((a -> Constant a a) -> s -> Constant a s) -> m a+view inj = asks (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 #-}++set :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t+set l = over l . const+{-# INLINE set #-}++foldMapOf :: ((a -> Constant r b) -> s -> Constant r t) -> (a -> r) -> s -> r+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 (<$>)+{-# INLINE (<&>) #-}++infixl 1 &+(&) :: b -> (b -> c) -> c+(&) = flip ($)+{-# INLINE (&) #-}++infixl 8 ^.+(^.) :: s -> ((a -> Constant a a) -> s -> Constant a s) -> a+(^.) = flip view+{-# INLINE (^.) #-}++infixr 4 .~+(.~) :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t+(.~) = set+{-# INLINE (.~) #-}++infixr 4 %~+(%~) :: ((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
@@ -0,0 +1,180 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}++-- |+-- Module : Network.OAuth.Signing+-- Copyright : (c) Joseph Abrahamson 2013+-- License : MIT+--+-- Maintainer : me@jspha.com+-- Stability : experimental+-- Portability : non-portable+--+-- Signing forms the core process for OAuth. Given a 'C.Request' about to be+-- sent, 'Server' parameters, and a full 'Oa' we append a set of parameters to+-- the 'C.Request' which turns it into a signed OAuth request.++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.++ makeSignature, augmentRequest, canonicalBaseString, canonicalParams,+ oauthParams, canonicalUri, bodyParams, queryParams++ ) where++import qualified Blaze.ByteString.Builder as Blz+import Control.Applicative+import Crypto.Hash.SHA1 (hash)+import Crypto.MAC.HMAC (hmac)+import qualified Data.ByteString as S+import qualified Data.ByteString.Base64 as S64+import qualified Data.ByteString.Char8 as S8+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.Types as H+import qualified Network.HTTP.Types.QueryLike as H+import Network.OAuth.MuLens+import Network.OAuth.Types.Credentials+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)+oauth creds sv req gen = do+ (oax, gen') <- freshOa creds gen+ return (sign oax sv req, gen')++-- | Sign a request given generated parameters+sign :: Oa ty -> Server -> C.Request -> C.Request+sign oax server req =+ let payload = canonicalBaseString oax server req+ sigKey = signingKey (credentials oax)+ sig = makeSignature (signatureMethod server) sigKey payload+ params = ("oauth_signature", H.toQueryValue sig) : oauthParams oax server+ in augmentRequest (parameterMethod server) params req++makeSignature :: SignatureMethod -> S.ByteString -> S.ByteString -> S.ByteString+makeSignature HmacSha1 sigKey payload = S64.encode (hmac hash 64 sigKey payload)+makeSignature Plaintext sigKey _ = sigKey++-- | Augments whatever component of the 'C.Request' is specified by+-- 'ParameterMethod' with one built from the apropriate OAuth parameters+-- (passed as a 'H.Query').+--+-- Currently this actually /replaces/ the @Authorization@ header if one+-- exists. This may be a bad idea if the @realm@ parameter is pre-set,+-- perhaps.+--+-- TODO: Parse @Authorization@ header and augment it.+--+-- Currently this actually /replaces/ the entity body if one+-- exists. This is definitely just me being lazy.+--+-- TODO: Try to parse entity body and augment it.+augmentRequest :: ParameterMethod -> H.Query -> C.Request -> C.Request+augmentRequest AuthorizationHeader q req =+ 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+ authHeader = "OAuth " <> S8.intercalate ", " pairs+ pairs = map mkPair q+ mkPair (k, v) = k <> "=\"" <> fromMaybe "" v <> "\""+ in req { C.requestHeaders = replaceHeader H.hAuthorization authHeader (C.requestHeaders req) }+augmentRequest QueryString q req =+ let q0 = H.parseQuery (C.queryString req)+ in req { C.queryString = H.renderQuery True (q ++ q0) }+augmentRequest RequestEntityBody q req =+ let fixQ = mapMaybe (\(a, mayB) -> (a,) <$> mayB) q+ in C.urlEncodedBody fixQ req++canonicalBaseString :: Oa ty -> Server -> C.Request -> S.ByteString+canonicalBaseString oax server req =+ S8.intercalate "&" [ S8.map toUpper (C.method req)+ , canonicalUri req+ , canonicalParams oax server req+ ]++canonicalParams :: Oa ty -> Server -> C.Request -> S.ByteString+canonicalParams oax server req =+ let build :: H.QueryItem -> S.ByteString+ build (k, mayV) = pctEncode k <> maybe S.empty (\v -> "=" <> pctEncode v) mayV++ combine :: [S.ByteString] -> S.ByteString+ combine = pctEncode . S8.intercalate "&"+ in combine . sort . map build . mconcat+ $ [ oauthParams oax server+ , bodyParams req+ , queryParams req+ ]++oauthParams :: Oa ty -> Server -> H.Query+oauthParams (Oa {..}) (Server {..}) =+ let++ OaPin {..} = pin++ infix 8 -:+ s -: v = (s, H.toQueryValue v)++ workflowParams Standard = []+ workflowParams (TemporaryTokenRequest callback) =+ [ "oauth_callback" -: callback ]+ workflowParams (PermanentTokenRequest verifier) =+ [ "oauth_verifier" -: verifier ]++ 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++canonicalUri :: C.Request -> S.ByteString+canonicalUri req =+ pctEncode $ S8.pack $ uriScheme <> "//" <> fauthority uriAuthority <> uriPath+ where+ URI {..} = C.getUri req+ 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+ in uriRegName <> fport++-- | 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.+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 _) = []++queryParams :: C.Request -> H.Query+queryParams = H.parseQuery . C.queryString
+ src/Network/OAuth/Stateful.hs view
@@ -0,0 +1,139 @@+{-# 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, createCredential++ )+ 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)++createCredential :: Monad m => Token ty' -> OAuthT ty m (Cred ty')+createCredential tok = do+ cc <- getCredentials+ let clientTok = view clientToken cc+ return $ set resourceToken (clientCred clientTok) tok++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
@@ -0,0 +1,147 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- |+-- Module : Network.OAuth.ThreeLegged+-- Copyright : (c) Joseph Abrahamson 2013+-- License : MIT+--+-- Maintainer : me@jspha.com+-- Stability : experimental+-- Portability : non-portable+--+-- The \"Three-legged OAuth\" protocol implementing RFC 5849's+-- /Redirection-Based Authorization/.++module Network.OAuth.ThreeLegged (+ -- * Configuration types+ ThreeLegged (..), parseThreeLegged, Callback (..),++ -- * Actions+ requestTemporaryToken, buildAuthorizationUrl, requestPermanentToken,++ -- ** Raw forms+ requestTemporaryTokenRaw, requestPermanentTokenRaw,++ -- * Example system+ requestTokenProtocol+ ) where++import Control.Applicative+import Control.Monad.Trans+import Control.Monad.Trans.Maybe+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 Network.HTTP.Types (renderQuery)+import Network.OAuth+import Network.OAuth.MuLens+import Network.OAuth.Stateful+import Network.OAuth.Types.Credentials+import Network.OAuth.Types.Params+import Network.URI++-- | Data parameterizing the \"Three-legged OAuth\" redirection-based+-- authorization protocol. These parameters cover the protocol as described+-- in the community editions /OAuth Core 1.0/ and /OAuth Core 1.0a/ as well+-- as RFC 5849.+data ThreeLegged =+ ThreeLegged { temporaryTokenRequest :: 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+ -- ^ 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+ -- ^ 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+ -- ^ 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++-- | 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++-- | 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"++-- | 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)) ]+ }++-- | 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++-- | 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++-- | 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
+ src/Network/OAuth/Types/Credentials.hs view
@@ -0,0 +1,192 @@+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module : Network.OAuth.Type.Credentials+-- Copyright : (c) Joseph Abrahamson 2013+-- License : MIT+--+-- Maintainer : me@jspha.com+-- Stability : experimental+-- Portability : non-portable+--+-- Credentials, 'Cred's, are built from 'Token's, public/private key pairs, and+-- come in 3 varieties.+--+-- - 'Client': Represents a particular client or consumer, used as part of+-- every transaction that client signs.+--+-- - 'Temporary': Resource token representing a short-lived grant to access a+-- restricted set of server resources on behalf of the user. Typically used as+-- part of a authorization negotiation protocol.+--+-- - 'Permanent': Resource token representing a long-lived grant to access an+-- authorized set of server resources on behalf of the user. Outside of access+-- negotiation this is the most common kind of resource 'Token'.++-- 'Token's are constructed freely from public/private pairs and have+-- 'FromJSON' instances for easy retreival. 'Cred's are more strictly+-- controlled and must be constructed out of a 'Client' 'Token' and+-- (optionally) some kind of resource 'Token'.++module Network.OAuth.Types.Credentials (+ -- * Tokens and their parameterization+ Token (..), Key, Secret, Client, Temporary, Permanent, ResourceToken,++ -- ** Deserialization+ fromUrlEncoded,++ -- * Credentials and credential construction+ Cred, clientCred, temporaryCred, permanentCred,++ -- * Accessors+ key, secret, clientToken, resourceToken, getResourceTokenDef, signingKey+ ) where++import Control.Applicative+import Control.Monad+import Data.Aeson+import qualified Data.ByteString as S+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+-- purposes.++-- | 'Client' 'Cred'entials and 'Token's are assigned to a particular client by+-- the server and are used for all requests sent by that client. They form the+-- core component of resource specific credentials.+data Client = Client deriving ( Data, Typeable )++-- | 'Temporary' 'Token's and 'Cred'entials are created during authorization+-- protocols and are rarely meant to be kept for more than a few minutes.+-- Typically they are authorized to access only a very select set of server+-- resources. During \"three-legged authorization\" in OAuth 1.0 they are used+-- to generate the authorization request URI the client sends and, after that,+-- in the 'Permanent' 'Token' request.+data Temporary = Temporary deriving ( Data, Typeable )++-- | 'Permanent' 'Token's and 'Cred'entials are the primary means of accessing+-- server resources. They must be maintained by the client for each user who+-- authorizes that client to access resources on their behalf.+data Permanent = Permanent deriving ( Data, Typeable )++-- | 'Token' 'Key's are public keys which allow a server to uniquely identify a+-- particular 'Token'.+type Key = S.ByteString++-- | 'Token' 'Secret's are private keys which the 'Token' uses for+-- cryptographic purposes.+type Secret = S.ByteString++-- | 'Token's are public, private key pairs and come in many varieties,+-- 'Client', 'Temporary', and 'Permanent'.+data Token ty = Token {-# UNPACK #-} !Key+ {-# UNPACK #-} !Secret+ deriving ( Show, Eq, Ord, Data, Typeable )++class ResourceToken tk where++instance ResourceToken Temporary+instance ResourceToken Permanent++-- | Parses a JSON object with keys @oauth_token@ and @oauth_token_secret@, the+-- standard format for OAuth 1.0.+instance FromJSON (Token ty) where+ parseJSON = withObject "OAuth Token" $ \o ->+ Token <$> o .: "oauth_token"+ <*> o .: "oauth_token_secret"++-- | Produces a JSON object using keys named @oauth_token@ and+-- @oauth_token_secret@.+instance ToJSON (Token ty) where+ toJSON (Token k s) = object [ "oauth_token" .= k+ , "oauth_token_secret" .= s+ ]++-- | Parses a @www-form-urlencoded@ stream to produce a 'Token' if possible. +-- The first result value is whether or not the token data is OAuth 1.0a +-- compatible.+--+-- >>> fromUrlEncoded "oauth_token=key&oauth_token_secret=secret"+-- Just (False, Token "key" "secret")+--+-- >>> fromUrlEncoded "oauth_token=key&oauth_token_secret=secret&oauth_callback_confirmed=true"+-- Just (True, Token "key" "secret")+--+fromUrlEncoded :: S.ByteString -> Maybe (Bool, Token ty)+fromUrlEncoded = tryParse . parseQuery where+ tryParse q = do + tok <- Token <$> lookupV "oauth_token" q+ <*> lookupV "oauth_token_secret" q+ confirmed <- lookupV "oauth_callback_confirmed" q <|> pure ""+ return (confirmed == "true", tok)++ lookupV k = join . lookup k++key :: Lens (Token ty) (Token ty) Key Key+key inj (Token k s) = (`Token` s) <$> inj k+{-# INLINE key #-}++secret :: Lens (Token ty) (Token ty) Secret Secret+secret inj (Token k s) = Token k <$> inj s+{-# INLINE secret #-}++-- | 'Cred'entials pair a 'Client' 'Token' and either a 'Temporary' or+-- 'Permanent' token corresponding to a particular set of user+-- resources on the server.+data Cred ty = Cred {-# UNPACK #-} !Key {-# UNPACK #-} !Secret+ | 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)+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'.+resourceToken+ :: (ResourceToken ty, ResourceToken ty') =>+ Lens (Cred ty) (Cred ty') (Token ty) (Token ty')+resourceToken inj (CredAndToken k s tok) = CredAndToken k s <$> inj tok+{-# INLINE resourceToken #-}++-- | OAuth assumes that, by default, any credential has a resource 'Token' that+-- is by default completely blank. In this way we can talk about the resource+-- 'Token' of even 'Client' 'Cred's.+--+-- >>> getResourceTokenDef (clientCred $ Token "key" "secret")+-- Token "" ""+getResourceTokenDef :: Cred ty -> Token ty+getResourceTokenDef Cred{} = Token "" ""+getResourceTokenDef (CredAndToken _ _ tok) = tok++clientCred :: Token Client -> Cred Client+clientCred (Token k s) = Cred k s++temporaryCred :: Token Temporary -> Cred Client -> Cred Temporary+temporaryCred tok (Cred k s ) = CredAndToken k s tok++permanentCred :: Token Permanent -> Cred Client -> Cred Permanent+permanentCred tok (Cred k s ) = CredAndToken k s tok++-- | Produce a 'signingKey' from a set of credentials. This is a URL+-- encoded string built from the client secret and the token+-- secret.+--+-- If no token secret exists then the blank string is used.+--+-- prop> \secret -> signingKey (clientCred $ Token "key" secret) == (pctEncode secret <> "&" <> "")+signingKey :: Cred ty -> S.ByteString+signingKey (Cred _ clSec) = urlEncode True clSec <> "&" <> ""+signingKey (CredAndToken _ clSec (Token _ tkSec)) =+ pctEncode clSec <> "&" <> pctEncode tkSec
+ src/Network/OAuth/Types/Params.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module : Network.OAuth.Types.Params+-- Copyright : (c) Joseph Abrahamson 2013+-- License : MIT+--+-- Maintainer : me@jspha.com+-- Stability : experimental+-- Portability : non-portable+--+-- /OAuth Parameters/+--+-- OAuth 1.0 operates by creating a set of \"oauth parameters\" here+-- called 'Oa' which augment a request with OAuth specific+-- metadata. They may be used to augment the request by one of several+-- 'ParameterMethods'.++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+import qualified Data.ByteString.Char8 as S8+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.Types.QueryLike as H+import Network.OAuth.Types.Credentials+import Network.OAuth.Util++-- Basics+--------------------------------------------------------------------------------++-- | The OAuth spec suggest that the OAuth parameter be passed via the+-- @Authorization@ header, but allows for other methods of+-- transmission (see section "3.5. Parameter Transmission") so we+-- select the 'Server'\'s preferred method with this type.+data ParameterMethod = AuthorizationHeader+ -- ^ Place the 'Oa' parameters in the+ -- @Authorization@ HTTP header.+ | RequestEntityBody+ -- ^ Augment the @www-form-urlencoded@ request+ -- body with 'Oa' parameters.+ | QueryString+ -- ^ Augment the @www-form-urlencoded@ query+ -- string with 'Oa' parameters.+ deriving ( Show, Eq, Ord, Data, Typeable )++-- | OAuth culminates in the creation of the @oauth_signature@ which+-- signs and authenticates the request using the secret components of+-- a particular OAuth 'Network.OAuth.Types.Credentials.Cred'.+--+-- Several methods exist for generating these signatures, the most+-- popular being 'HmacSha1'.+data SignatureMethod = HmacSha1+ | Plaintext+ deriving ( Show, Eq, Ord, Data, Typeable )++instance H.QueryValueLike SignatureMethod where+ toQueryValue HmacSha1 = Just "HMAC-SHA1"+ toQueryValue Plaintext = Just "PLAINTEXT"++-- | OAuth has progressed through several versions since its inception. In+-- particular, there are two community editions \"OAuth Core 1.0\" (2007)+-- <<http://oauth.net/core/1.0>> and \"OAuth Core 1.0a\" (2009)+-- <<http://oauth.net/core/1.0a>> along with the IETF Official version RFC+-- 5849 (2010) <<http://tools.ietf.org/html/rfc5849>> which is confusingly+-- named "OAuth 1.0".+--+-- /Servers which only implement the obsoleted community edition \"OAuth+-- Core 1.0\" are susceptible to a session fixation attack./+--+-- If at all possible, choose the RFC 5849 version (the 'OAuth1' value) as+-- 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 + -- ^ OAuth Core 1.0 Community Edition+ -- <<http://oauth.net/core/1.0>>+ | OAuthCommunity1a+ -- ^ OAuth Core 1.0 Community Edition, Revision+ -- A <<http://oauth.net/core/1.0a>>+ | OAuth1+ -- ^ RFC 5849 <<http://tools.ietf.org/html/rfc5849>>+ deriving ( Show, Eq, Ord, Data, Typeable )++-- | All three OAuth 1.0 versions confusingly report the same version+-- number.+instance H.QueryValueLike Version where+ toQueryValue OAuthCommunity1 = Just "1.0"+ toQueryValue OAuthCommunity1a = Just "1.0"+ toQueryValue OAuth1 = Just "1.0"++-- | When performing the second leg of the three-leg token request workflow,+-- the user must pass the @oauth_verifier@ code back to the client. In order to+-- ensure that this protocol is secure, OAuth demands that the client+-- associates this \"callback method\" with the temporary credentials generated+-- 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+ deriving ( Typeable )++instance Show Callback where+ show OutOfBand = "OutOfBand"+ show (Callback req) = "Callback <" ++ show (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++-- | An Epoch time format timestamp.+newtype Timestamp = Timestamp UTCTime deriving ( Show, Eq, Ord, Data, Typeable )++-- | Create a 'Timestamp' deterministically from a POSIX Epoch Time.+timestampFromSeconds :: Integer -> Timestamp+timestampFromSeconds = Timestamp . posixSecondsToUTCTime . fromIntegral++-- | Prints out in Epoch time format, a printed integer+instance H.QueryValueLike Timestamp where+ toQueryValue (Timestamp u) =+ let i = round (utcTimeToPOSIXSeconds u) :: Int+ in Just $ S8.pack $ show i++-- Server information+--------------------------------------------------------------------------------++-- | The 'Server' information contains details which parameterize how a+-- particular server wants to interpret OAuth requests.+data Server =+ Server { parameterMethod :: ParameterMethod+ , signatureMethod :: SignatureMethod+ , oAuthVersion :: Version+ } deriving ( Show, Eq, Ord, Data, Typeable )++-- | The default 'Server' parameterization uses OAuth recommended parameters.+defaultServer :: Server+defaultServer = Server AuthorizationHeader HmacSha1 OAuth1++-- Params+--------------------------------------------------------------------------------++-- | A 'Verifier' is produced when a user authorizes a set of 'Temporary'+-- 'Cred's. Using the 'Verifier' allows the client to request 'Permanent'+-- 'Cred's.+type Verifier = S.ByteString++-- | Some special OAuth requests use extra @oauth_*@ parameters. For example,+-- when requesting a temporary credential, it's necessary that a+-- @oauth_callback@ parameter be specified. 'WorkflowParams' allows these extra+-- parameters to be specified.+data Workflow = Standard+ -- ^ No special OAuth parameters needed+ | TemporaryTokenRequest Callback+ | PermanentTokenRequest S.ByteString+ -- ^ Includes the @oauth_verifier@+ deriving ( Show, Typeable )++-- | The 'OaPin' is a set of impure OAuth parameters which are generated for each+-- request in order to ensure uniqueness and temporality.+data OaPin =+ OaPin { timestamp :: Timestamp+ , nonce :: S.ByteString+ } deriving ( Show, Eq, Ord, Data, Typeable )++-- | An \"empty\" pin useful for testing. This 'OaPin' is referentially+-- transparent and thus has none of the necessary security features---it should+-- /never/ be used in an actual transaction!+emptyPin :: OaPin+emptyPin = OaPin { timestamp = Timestamp (UTCTime (ModifiedJulianDay 0) 0)+ , nonce = "\0\0\0\0\0"+ }++-- | Creates a new, unique, unpredictable 'OaPin'. This should be used quickly+-- as dependent on the OAuth server settings it may expire.+freshPin :: CPRG gen => gen -> IO (OaPin, gen)+freshPin gen = do+ t <- Timestamp <$> getCurrentTime+ return (OaPin { timestamp = t, nonce = n }, gen')+ where+ (n, gen') = withRandomBytes gen 8 S64.encode++-- | Uses 'emptyPin' to create an empty set of params 'Oa'.+emptyOa :: Cred ty -> Oa ty+emptyOa creds = + Oa { credentials = creds, workflow = Standard, pin = emptyPin }++-- | Uses 'freshPin' to create a fresh, default set of params 'Oa'.+freshOa :: CPRG gen => Cred ty -> gen -> IO (Oa ty, gen)+freshOa creds gen = do+ (pinx, gen') <- freshPin gen+ return (Oa { credentials = creds, workflow = Standard, pin = pinx }, gen')++-- | The 'Oa' parameters include all the OAuth information specific to a single+-- request. They are not sufficient information by themselves to generate the+-- entire OAuth request but instead must be augmented with 'Server' information.+data Oa ty =+ Oa { credentials :: Cred ty+ , workflow :: Workflow+ , pin :: OaPin+ }+ deriving ( Show, Typeable )
+ src/Network/OAuth/Util.hs view
@@ -0,0 +1,17 @@+-- |+-- Module : Network.OAuth.Util+-- Copyright : (c) Joseph Abrahamson 2013+-- License : MIT+--+-- Maintainer : me@jspha.com+-- Stability : experimental+-- Portability : non-portable+--++module Network.OAuth.Util where++import qualified Data.ByteString as S+import Network.HTTP.Types (urlEncode)++pctEncode :: S.ByteString -> S.ByteString+pctEncode = urlEncode True