diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/oauthenticated.cabal b/oauthenticated.cabal new file mode 100644 --- /dev/null +++ b/oauthenticated.cabal @@ -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 diff --git a/src/Network/OAuth.hs b/src/Network/OAuth.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth.hs @@ -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 diff --git a/src/Network/OAuth/MuLens.hs b/src/Network/OAuth/MuLens.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth/MuLens.hs @@ -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) } diff --git a/src/Network/OAuth/Signing.hs b/src/Network/OAuth/Signing.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth/Signing.hs @@ -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 diff --git a/src/Network/OAuth/Stateful.hs b/src/Network/OAuth/Stateful.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth/Stateful.hs @@ -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 #-} diff --git a/src/Network/OAuth/ThreeLegged.hs b/src/Network/OAuth/ThreeLegged.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth/ThreeLegged.hs @@ -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 diff --git a/src/Network/OAuth/Types/Credentials.hs b/src/Network/OAuth/Types/Credentials.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth/Types/Credentials.hs @@ -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 diff --git a/src/Network/OAuth/Types/Params.hs b/src/Network/OAuth/Types/Params.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth/Types/Params.hs @@ -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) +-- <> and \"OAuth Core 1.0a\" (2009) +-- <> along with the IETF Official version RFC +-- 5849 (2010) <> 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 + -- <> + | OAuthCommunity1a + -- ^ OAuth Core 1.0 Community Edition, Revision + -- A <> + | OAuth1 + -- ^ RFC 5849 <> + 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 ) diff --git a/src/Network/OAuth/Util.hs b/src/Network/OAuth/Util.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth/Util.hs @@ -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