haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

- Changed to include "oauth_callback" only in the temporary credential phase.

Browse Source 
- Proxy & Scope parameter support in OAuth by hook (thx!> pqwy & himura).
This commit is contained in:
Hiromi Ishii 2011-07-15 01:14:41 +09:00
parent e762a42f23
commit 588cf6ab58
1 changed files with 12 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
Web/Authenticate/OAuth.hs
View File

@ -115,8 +115,9 @@ getTemporaryCredential' :: (Request IO -> Request IO) -- ^ Request Hook
-> IO Credential -- ^ Temporary Credential (Request Token & Secret). -> IO Credential -- ^ Temporary Credential (Request Token & Secret).
getTemporaryCredential' hook oa = do getTemporaryCredential' hook oa = do
let req = fromJust $ parseUrl $ oauthRequestUri oa let req = fromJust $ parseUrl $ oauthRequestUri oa
req' <- signOAuth oa emptyCredential (req { method = "POST" }) crd = maybe id (insert "oauth_callback") (oauthCallback oa) $ emptyCredential
rsp <- withManager . httpLbs . hook $ req' req' <- signOAuth oa crd $ hook (req { method = "POST" })
rsp <- withManager . httpLbs $ req'
if statusCode rsp == 200 if statusCode rsp == 200
then do then do
let dic = parseSimpleQuery . toStrict . responseBody $ rsp let dic = parseSimpleQuery . toStrict . responseBody $ rsp
@ -149,13 +150,13 @@ getAccessToken' :: (Request IO -> Request IO) -- ^ Request Hook
-> Credential -- ^ Temporary Credential with oauth_verifier -> Credential -- ^ Temporary Credential with oauth_verifier
-> IO Credential -- ^ Token Credential (Access Token & Secret) -> IO Credential -- ^ Token Credential (Access Token & Secret)
getAccessToken' hook oa cr = do getAccessToken' hook oa cr = do
let req = (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" } let req = hook (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" }
rsp <- signOAuth oa cr req >>= withManager . httpLbs . hook rsp <- signOAuth oa cr req >>= withManager . httpLbs . hook
if statusCode rsp == 200 if statusCode rsp == 200
then do then do
let dic = parseSimpleQuery . toStrict . responseBody $ rsp let dic = parseSimpleQuery . toStrict . responseBody $ rsp
return $ Credential dic return $ Credential dic
else throwIO . OAuthException $ "Gaining OAuth Temporary Credential Failed: " ++ BSL.unpack (responseBody rsp) else throwIO . OAuthException $ "Gaining OAuth Token Credential Failed: " ++ BSL.unpack (responseBody rsp)
getTokenCredential = getAccessToken getTokenCredential = getAccessToken
@ -216,11 +217,11 @@ addTimeStamp cred = do
return $ insert "oauth_timestamp" (BS.pack $ show stamp) cred return $ insert "oauth_timestamp" (BS.pack $ show stamp) cred
injectOAuthToCred :: OAuth -> Credential -> Credential injectOAuthToCred :: OAuth -> Credential -> Credential
injectOAuthToCred oa cred = maybe id (insert "oauth_callback") (oauthCallback oa) $ injectOAuthToCred oa cred =
inserts [ ("oauth_signature_method", showSigMtd $ oauthSignatureMethod oa) inserts [ ("oauth_signature_method", showSigMtd $ oauthSignatureMethod oa)
, ("oauth_consumer_key", oauthConsumerKey oa) , ("oauth_consumer_key", oauthConsumerKey oa)
, ("oauth_version", "1.0") , ("oauth_version", "1.0")
] cred ] cred
genSign :: MonadIO m => OAuth -> Credential -> Request m -> m BS.ByteString genSign :: MonadIO m => OAuth -> Credential -> Request m -> m BS.ByteString
genSign oa tok req = genSign oa tok req =
@ -266,7 +267,8 @@ getBaseString tok req = do
allParams = bsQuery++bsBodyQ++bsAuthParams allParams = bsQuery++bsBodyQ++bsAuthParams
bsParams = BS.intercalate "&" $ map (\(a,b)->BS.concat[a,"=",b]) $ sortBy compareTuple bsParams = BS.intercalate "&" $ map (\(a,b)->BS.concat[a,"=",b]) $ sortBy compareTuple
$ map (\(a,b) -> (paramEncode a,paramEncode b)) allParams $ map (\(a,b) -> (paramEncode a,paramEncode b)) allParams
-- FIXME it would be much better to use http-types functions here -- parameter encoding method in OAuth is slight different from ordinary one.
-- So this is OK.
return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams] return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams]
toLBS :: MonadIO m => RequestBody m -> m BS.ByteString toLBS :: MonadIO m => RequestBody m -> m BS.ByteString