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

Merge pull request #7 from konn/master

Browse Source 
Changed to see Response Status
This commit is contained in:
Michael Snoyman 2011-06-09 06:50:38 -07:00
commit 4c0a704bb9
1 changed files with 14 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
Web/Authenticate/OAuth.hs
View File

@ -2,7 +2,7 @@
{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
module Web.Authenticate.OAuth module Web.Authenticate.OAuth
( -- * Data types ( -- * Data types
OAuth(..), SignMethod(..), Credential(..), OAuth(..), SignMethod(..), Credential(..), OAuthException(..),
-- * Operations for credentials -- * Operations for credentials
emptyCredential, insert, delete, inserts, emptyCredential, insert, delete, inserts,
-- * Signature -- * Signature
@ -38,6 +38,7 @@ import Data.Enumerator (($$), run_, Stream (..), continue)
import Data.Monoid (mconcat) import Data.Monoid (mconcat)
import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.IORef (newIORef, readIORef, atomicModifyIORef) import Data.IORef (newIORef, readIORef, atomicModifyIORef)
import Control.Exception (Exception, throwIO)
-- | Data type for OAuth client (consumer). -- | Data type for OAuth client (consumer).
data OAuth = OAuth { oauthServerName :: String -- ^ Service name data OAuth = OAuth { oauthServerName :: String -- ^ Service name
@ -75,7 +76,7 @@ token, tokenSecret :: Credential -> BS.ByteString
token = fromMaybe "" . lookup "oauth_token" . unCredential token = fromMaybe "" . lookup "oauth_token" . unCredential
tokenSecret = fromMaybe "" . lookup "oauth_token_secret" . unCredential tokenSecret = fromMaybe "" . lookup "oauth_token_secret" . unCredential
data OAuthException = ProtocolException String data OAuthException = OAuthException String
deriving (Show, Eq, Data, Typeable) deriving (Show, Eq, Data, Typeable)
instance Exception OAuthException instance Exception OAuthException
@ -93,8 +94,11 @@ getTemporaryCredential oa = do
let req = fromJust $ parseUrl $ oauthRequestUri oa let req = fromJust $ parseUrl $ oauthRequestUri oa
req' <- signOAuth oa emptyCredential (req { method = "POST" }) req' <- signOAuth oa emptyCredential (req { method = "POST" })
rsp <- withManager $ httpLbs req' rsp <- withManager $ httpLbs req'
let dic = parseSimpleQuery . toStrict . responseBody $ rsp if statusCode rsp == 200
return $ Credential dic then do
let dic = parseSimpleQuery . toStrict . responseBody $ rsp
return $ Credential dic
else throwIO . OAuthException $ "Gaining OAuth Temporary Credential Failed: " ++ BSL.unpack (responseBody rsp)
-- | URL to obtain OAuth verifier. -- | URL to obtain OAuth verifier.
authorizeUrl :: OAuth -- ^ OAuth Application authorizeUrl :: OAuth -- ^ OAuth Application
@ -110,8 +114,12 @@ getAccessToken, getTokenCredential
getAccessToken oa cr = do getAccessToken oa cr = do
let req = (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" } let req = (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" }
rsp <- signOAuth oa cr req >>= withManager . httpLbs rsp <- signOAuth oa cr req >>= withManager . httpLbs
let dic = parseSimpleQuery . toStrict . responseBody $ rsp if statusCode rsp == 200
return $ Credential dic then do
let dic = parseSimpleQuery . toStrict . responseBody $ rsp
return $ Credential dic
else throwIO . OAuthException $ "Gaining OAuth Temporary Credential Failed: " ++ BSL.unpack (responseBody rsp)
getTokenCredential = getAccessToken getTokenCredential = getAccessToken