-- Copyright (c) 2009, Diego Souza-- All rights reserved.-- -- Redistribution and use in source and binary forms, with or without-- modification, are permitted provided that the following conditions are met:-- -- * Redistributions of source code must retain the above copyright notice,-- this list of conditions and the following disclaimer.-- * Redistributions in binary form must reproduce the above copyright notice,-- this list of conditions and the following disclaimer in the documentation-- and/or other materials provided with the distribution.-- * Neither the name of the <ORGANIZATION> nor the names of its contributors-- may be used to endorse or promote products derived from this software-- without specific prior written permission.-- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND-- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.-- | A Haskell library that implements oauth authentication protocol as defined in <http://tools.ietf.org/html/draft-hammer-oauth-10>.-- -- According to the RFC [1]:-- OAuth provides a method for clients to access server resources on behalf-- of a resource owner (such as a different client or an end- user). It also-- provides a process for end-users to authorize third- party access to their-- server resources without sharing their credentials (typically, a username and-- password pair), using user- agent redirections.-- -- The following code should perform a request using 3 legged oauth, provided the parameters are defined correctly:-- -- > reqUrl = fromJust . parseURL $ "https://service.provider/request_token"-- > accUrl = fromJust . parseURL $ "https://service.provider/access_token"-- > srvUrl = fromJust . parseURL $ "http://service/path/to/resource/"-- > authUrl = ("http://service.provider/authorize?oauth_token="++) . findWithDefault ("oauth_token","") . oauthParams-- > app = Application "consumerKey" "consumerSec" OOB-- > response = runOAuth $ do ignite app-- > oauthRequest PLAINTEXT Nothing reqUrl-- > cliAskAuthorization authUrl-- > oauthRequest PLAINTEXT Nothing accUrl-- > serviceRequest HMACSHA1 (Just "realm") srvUrl--moduleNetwork.OAuth.Consumer(-- * TypesToken(..),Application(..),OAuthCallback(..),SigMethod(..),Realm,Nonce,Timestamp,OAuthMonad-- * OAuthMonad related functions,runOAuth,oauthRequest,completeRequest,serviceRequest,cliAskAuthorization,ignite,getToken,putToken-- * Token related functions,twoLegged,threeLegged,signature,injectOAuthVerifier,fromApplication,fromResponse,authorization)whereimportNetwork.OAuth.Http.HttpClientimportNetwork.OAuth.Http.RequestimportNetwork.OAuth.Http.ResponseimportNetwork.OAuth.Http.PercentEncodingimportControl.Monad.StateimportSystem.Random(randomRIO)importData.Time(getCurrentTime,formatTime)importSystem.Locale(defaultTimeLocale)importData.Char(chr,ord)importData.List(intercalate,sort)importSystem.IOimportqualifiedData.BinaryasBiimportData.Word(Word8)importqualifiedData.Digest.Pure.SHAasSimportqualifiedCodec.Binary.Base64asB64importqualifiedData.ByteString.LazyasB-- | Random string that is unique amongst requests. Refer to <http://oauth.net/core/1.0/#nonce> for more information.typeNonce=String-- | Unix timestamp (seconds since epoch). Refer to <http://oauth.net/core/1.0/#nonce> for more information.typeTimestamp=String-- | The optional authentication realm. Refer to <http://oauth.net/core/1.0/#auth_header_authorization> for more information.typeRealm=String-- | Callback used in oauth authorizationdataOAuthCallback=URLString|OOBderiving(Eq)-- | Identifies the application.dataApplication=Application{consKey::String,consSec::String,callback::OAuthCallback}deriving(Eq)-- | The OAuth Token.dataToken={-| This token is used to perform 2 legged OAuth requests. -}TwoLegg{application::Application,oauthParams::FieldList}{-| The service provider has granted you the request token but the
user has not yet authorized your application. You need to
exchange this token by a proper AccessToken, but this may only
happen after user has granted you permission to do so.
-}|ReqToken{application::Application,oauthParams::FieldList}{-| This is a proper 3 legged OAuth. The difference between this and ReqToken
is that user has authorized your application and you can perform requests
on behalf of that user.
-}|AccessToken{application::Application,oauthParams::FieldList}deriving(Eq)-- | Available signature methods.dataSigMethod={-| The 'PLAINTEXT' /consumer_key/ /token_secret/ method does not provide
any security protection and SHOULD only be used over a secure channel
such as /HTTPS/. It does not use the Signature Base String.
-}PLAINTEXT{-| The 'HMAC_SHA1' /consumer_key/ /token_secret/ signature method uses the
/HMAC-SHA1/ signature algorithm as defined in
<http://tools.ietf.org/html/rfc2104> where the Signature Base String is
the text and the key is the concatenated values (each first encoded per
Parameter Encoding) of the Consumer Secret and Token Secret, separated
by an /&/ character (ASCII code 38) even if empty.
-}|HMACSHA1-- | The OAuth monad.typeOAuthMonadma=StateTTokenma-- | Signs a request using a given signature method. This expects the request-- to be a valid request already (for instance, none and timestamp are not set).signature::SigMethod->Token->Request->Stringsignaturemtokenreq=casemofPLAINTEXT->keyHMACSHA1->b64encode$S.bytestringDigest(S.hmacSha1(bsencodekey)(bsencodetext))wherebsencode=B.pack.map(fromIntegral.ord)b64encode=B64.encode.B.unpackkey=encode(consSec(applicationtoken))++"&"++encode(findWithDefault("oauth_token_secret","")(oauthParamstoken))text=intercalate"&"$mapencode[show(methodreq),showURL(req{qString=empty}),intercalate"&".map(\(k,v)->k++"="++v).sort.map(\(k,v)->(encodek,encodev)).toList$params]params=if(ifindWithDefault("content-type","")(reqHeadersreq)=="application/x-www-form-urlencoded")then(qStringreq)`unionAll`(parseQString.map(chr.fromIntegral).B.unpack.reqPayload$req)elseqStringreq-- | Returns true if the token is able to perform 2-legged oauth requests.twoLegged::Token->BooltwoLegged(TwoLegg__)=TruetwoLegged_=False-- | Tests whether or not the current token is able to perform 3-legged requests.threeLegged::Token->BoolthreeLegged(AccessToken__)=TruethreeLegged_=False-- | Transforms an application into a token.ignite::(MonadIOm)=>Application->OAuthMonadm()ignite=put.fromApplication-- | Transforms an application into a tokenfromApplication::Application->TokenfromApplicationapp=TwoLeggappempty-- | Execute the oauth monad and returns the value it produced.runOAuth::(MonadIOm,HttpClientm)=>OAuthMonadma->marunOAuth=flipevalStateT(TwoLegg(Application""""OOB)empty)-- | Executes an oauth request which is intended to upgrade/refresh the current-- token. Use this combinator to get either a request token or an access-- token.oauthRequest::(MonadIOm,HttpClientm)=>SigMethod->MaybeRealm->Request->OAuthMonadmTokenoauthRequestsigmrealmreq=doresponse<-serviceRequestsigmrealmreqtoken<-getcase(fromResponseresponsetoken)of(Righttoken')->doputtoken'returntoken'(Lefterr)->failerr-- | Simply complete the request with the required information to perform the oauth request.completeRequest::(MonadIOm)=>SigMethod->Token->MaybeRealm->Request->mRequestcompleteRequestsigmtokenrealmreq=dononce<-_noncetimestamp<-_timestampletauthValue=authorizationsigmrealmnoncetimestamptokenreqreturn(req{reqHeaders=insert("Authorization",authValue)(reqHeadersreq)})-- | Performs a signed request with the available token.serviceRequest::(MonadIOm,HttpClientm)=>SigMethod->MaybeRealm->Request->OAuthMonadmResponseserviceRequestsigmrealmreq0=dotoken<-getreq<-completeRequestsigmtokenrealmreq0lift(requestreq)-- | Extracts the token from the OAuthMonad.getToken::(Monadm)=>OAuthMonadmTokengetToken=get-- | Alias to the put function.putToken::(Monadm)=>Token->OAuthMonadm()putToken=put-- | Injects the oauth_verifier into the token. Usually this means the user has-- authorized the app to access his data.injectOAuthVerifier::String->Token->TokeninjectOAuthVerifiervalue(ReqTokenappparams)=ReqTokenapp(replace("oauth_verifier",value)params)injectOAuthVerifier_token=token-- | Probably this is just useful for testing. It asks the user (stdout/stdin)-- to authorize the application and provide the oauth_verifier.cliAskAuthorization::(MonadIOm)=>(Token->String)->OAuthMonadm()cliAskAuthorizationgetUrl=dotoken<-getanswer<-liftIO$dohSetBufferingstdoutNoBufferingputStrLn("open "++(getUrltoken))putStr"oauth_verifier: "getLineput(injectOAuthVerifieranswertoken)-- | Receives a response possibly from a service provider and updates the-- token. As a matter effect, assumes the content-type is-- application/x-www-form-urlencoded (because some service providers send it as-- text/plain) and if the status is [200..300) updates the token accordingly.fromResponse::Response->Token->EitherStringTokenfromResponsersptoken|validRsp=case(token)of(TwoLeggappparams)->Right$ReqTokenapp(payload`union`params)(ReqTokenappparams)->Right$AccessTokenapp(payload`union`params)(AccessTokenappparams)->Right$AccessTokenapp(payload`union`params)|otherwise=Left(statusLinersp)wherepayload=parseQString.map(chr.fromIntegral).B.unpack.rspPayload$rspvalidRsp=statusOk&&paramsOkstatusOk=statusrsp`elem`[200..299]paramsOk=not$null(zipWithM($)(map(find.(==))requiredKeys)(repeatpayload))requiredKeys=casetokenof(TwoLegg__)->["oauth_token","oauth_token_secret","oauth_callback_confirmed"]_->["oauth_token","oauth_token_secret"]-- | Computes the authorization header and updates the request.authorization::SigMethod->MaybeRealm->Nonce->Timestamp->Token->Request->Stringauthorizationmrealmnoncetimetokenreq=oauthPrefix++enquote(("oauth_signature",oauthSignature):oauthFields)whereoauthFields=[("oauth_consumer_key",consKey.application$token),("oauth_nonce",nonce),("oauth_timestamp",time),("oauth_signature_method",showm),("oauth_version","1.0")]++extraoauthPrefix=caserealmofNothing->"OAuth "Justv->"OAuth realm=\""++encodev++"\","extra=casetokenof(TwoLeggapp_)->[("oauth_callback",show.callback$app)](ReqToken_params)->filter(not.null.snd)[("oauth_verifier",findWithDefault("oauth_verifier","")params),("oauth_token",findWithDefault("oauth_token","")params)](AccessToken_params)->filter(not.null.snd)[("oauth_token",findWithDefault("oauth_token","")params),("oauth_session_handle",findWithDefault("oauth_session_handle","")params)]oauthSignature=signaturemtoken(req{qString=(qStringreq)`union`(fromListoauthFields)})enquote=intercalate",".map(\(k,v)->encodek++"=\""++encodev++"\"")_nonce::(MonadIOm)=>mNonce_nonce=dorand<-liftIO(randomRIO(0,maxBound::Int))return(showrand)_timestamp::(MonadIOm)=>mTimestamp_timestamp=doclock<-liftIOgetCurrentTimereturn(formatTimedefaultTimeLocale"%s"clock)instanceShowSigMethodwhereshowsPrec_PLAINTEXT=showString"PLAINTEXT"showsPrec_HMACSHA1=showString"HMAC-SHA1"instanceShowOAuthCallbackwhereshowsPrec_OOB=showString"oob"showsPrec_(URLu)=showStringuinstanceBi.BinaryOAuthCallbackwhereputOOB=Bi.put(0::Word8)put(URLurl)=doBi.put(1::Word8)Bi.puturlget=dot<-Bi.get::Bi.GetWord8casetof0->returnOOB1->fmapURLBi.get_->fail"Consumer: parse error"instanceBi.BinaryApplicationwhereputapp=doBi.put(consKeyapp)Bi.put(consSecapp)Bi.put(callbackapp)get=dockey<-Bi.getcsec<-Bi.getcallback_<-Bi.getreturn(Applicationckeycseccallback_)instanceBi.BinaryTokenwhereput(TwoLeggappparams)=doBi.put(0::Word8)Bi.putappBi.putparamsput(ReqTokenappparams)=doBi.put(1::Word8)Bi.putappBi.putparamsput(AccessTokenappparams)=doBi.put(2::Word8)Bi.putappBi.putparamsget=dot<-Bi.get::Bi.GetWord8casetof0->doapp<-Bi.getparams<-Bi.getreturn(TwoLeggappparams)1->doapp<-Bi.getparams<-Bi.getreturn(ReqTokenappparams)2->doapp<-Bi.getparams<-Bi.getreturn(AccessTokenappparams)_->fail"Consumer: parse error"-- vim:sts=2:sw=2:ts=2:et