hoauth2 0.1.2 → 0.2.0
raw patch · 5 files changed
+150/−82 lines, 5 filesdep ~aesondep ~conduitdep ~http-conduit
Dependency ranges changed: aeson, conduit, http-conduit, http-types
Files
- hoauth2.cabal +9/−5
- src/Network/OAuth2/HTTP/HttpClient.hs +30/−65
- src/Network/OAuth2/OAuth2.hs +100/−0
- test/test-google.hs +4/−2
- test/test-weibo.hs +7/−10
hoauth2.cabal view
@@ -1,6 +1,6 @@ Name: hoauth2 -- (http://www.haskell.org/haskellwiki/Package_versioning_policy)-Version: 0.1.2+Version: 0.2.0 Synopsis: hoauth2 Description: @@ -20,7 +20,10 @@ Copyright: Haisheng,Wu Category: Network Build-type: Simple+stability: experimental+tested-with: GHC == 7.0.3 + -- Extra files to be distributed with the package, such as examples or -- a README. Extra-source-files: @@ -39,15 +42,16 @@ hs-source-dirs: src Exposed-modules: Network.OAuth2.HTTP.HttpClient+ Network.OAuth2.OAuth2 Build-Depends: base >= 4 && < 5,- http-conduit >= 1.2.5 ,- conduit >= 0.2,- aeson >= 0.4 ,+ http-conduit >= 1.2.5 && < 1.3.0,+ conduit >= 0.2 && < 0.3.0,+ aeson >= 0.4 && < 0.5, mtl >= 1 && < 2.2, bytestring >= 0.9 && < 0.10,- http-types >= 0.6.8+ http-types >= 0.6.8 && < 0.7 -- Modules not exported by this package.
src/Network/OAuth2/HTTP/HttpClient.hs view
@@ -2,18 +2,14 @@ {-# LANGUAGE DeriveDataTypeable #-} {-- A simple OAuth2 client.+ A simple OAuth2 http client. -} module Network.OAuth2.HTTP.HttpClient - ( OAuth2 (..)- , AccessToken (..)- , authorizationUrl- , postAccessToken- , request+ ( requestAccessToken+ , doRequest , signRequest- )- where+ ) where import Control.Monad.Trans.Resource import Data.Aeson@@ -21,80 +17,49 @@ import qualified Data.ByteString.Lazy.Char8 as BSL import Data.List import Data.Maybe-import Data.Typeable (Typeable) import Network.HTTP.Types (renderSimpleQuery, parseSimpleQuery) import qualified Network.HTTP.Types as HT import Network.HTTP.Conduit import Control.Exception import Control.Applicative ((<$>))-import Control.Monad (mzero) --- | Query Parameter Representation-data OAuth2 = OAuth2 { oauthClientId :: BS.ByteString- , oauthClientSecret :: BS.ByteString- , oauthOAuthorizeEndpoint :: BS.ByteString- , oauthAccessTokenEndpoint :: BS.ByteString- , oauthCallback :: Maybe BS.ByteString- , oauthAccessToken :: Maybe BS.ByteString- } deriving (Show, Eq)+import Network.OAuth2.OAuth2 -data OAuthException = OAuthException String- deriving (Show, Eq, Typeable)+-------------------------------------------------- -instance Exception OAuthException+-- | Request (POST method) access token URL in order to get @AccessToken@.+-- FIXME: what if @requestAccessToken'@ return error?+requestAccessToken :: OAuth2 + -> BS.ByteString -- ^ Authentication code gained after authorization+ -> IO (Maybe AccessToken)+requestAccessToken oa code = decode <$> requestAccessToken' oa code --- | The gained Access Token -data AccessToken = AccessToken { accessToken :: BS.ByteString } deriving (Show) -instance FromJSON AccessToken where- parseJSON (Object o) = AccessToken <$> o .: "access_token"- parseJSON _ = mzero---- | Prepare the authorization URL-authorizationUrl :: OAuth2 -> BS.ByteString-authorizationUrl oa = oauthOAuthorizeEndpoint oa `BS.append` queryStr- where queryStr = renderSimpleQuery True query- query = transformParam [ ("client_id", Just $ oauthClientId oa)- , ("response_type", Just "code")- , ("redirect_uri", oauthCallback oa)]--request :: Control.Monad.Trans.Resource.ResourceIO m =>- Request m -> m (Response BSL.ByteString)-request req = (withManager . httpLbs) (req { checkStatus = \_ _ -> Nothing })--postAccessToken' :: OAuth2 -> BS.ByteString -> Maybe BS.ByteString -> IO BSL.ByteString-postAccessToken' oa code grant_type = do- rsp <- request req- if (HT.statusCode . statusCode) rsp == 200- then return $ responseBody rsp- else throwIO . OAuthException $ "Gaining access_token failed: " ++ BSL.unpack (responseBody rsp)+requestAccessToken' :: OAuth2 -> BS.ByteString -> IO BSL.ByteString+requestAccessToken' oa code = doRequest req >>= retOrError where- req = urlEncodedBody query . fromJust $ parseUrl url- url = BS.unpack $ oauthAccessTokenEndpoint oa- query = transformParam [ ("client_id", Just $ oauthClientId oa)- , ("client_secret", Just $ oauthClientSecret oa)- , ("code", Just code)- , ("redirect_uri", oauthCallback oa)- , ("grant_type", grant_type) ]+ req = urlEncodedBody body $ toReq' uri+ (uri, body) = accessTokenUrl oa code+ retOrError rsp = if (HT.statusCode . statusCode) rsp == 200+ then return $ responseBody rsp+ else throwIO . OAuthException $ "Gaining access_token failed: " ++ BSL.unpack (responseBody rsp) --- | lift value in the Maybe and abonda Nothing-transformParam :: [(a, Maybe b)] -> [(a, b)]-transformParam = foldr step' []- where step' :: (a, Maybe b) -> [(a, b)] -> [(a, b)]- step' (a, Just b) xs = (a, b):xs- step' _ xs = xs --- | Request (POST method) access token URL in order to get @AccessToken@.-postAccessToken :: OAuth2 - -> BS.ByteString -- ^ Authentication code gained after authorization- -> IO (Maybe AccessToken)-postAccessToken oa code = decode <$> postAccessToken' oa code (Just "authorization_code")- -- | insert access token into the request signRequest :: OAuth2 -> Request m -> Request m signRequest oa req = req { queryString = renderSimpleQuery False newQuery } where newQuery = case oauthAccessToken oa of- Just at -> insert ("access_token", at) oldQuery -- ^ TODO: allow access_token to be configuable+ Just at -> insert ("access_token", at) oldQuery _ -> insert ("client_id", oauthClientId oa) . insert ("client_secret", oauthClientSecret oa) $ oldQuery oldQuery = parseSimpleQuery (queryString req)++--------------------------------------------------+-- UTIL++toReq' :: BS.ByteString -> Request a+toReq' = fromJust . parseUrl . BS.unpack++-- | Performance a http @Request@+doRequest :: ResourceIO m => Request m -> m (Response BSL.ByteString)+doRequest = withManager . httpLbs
+ src/Network/OAuth2/OAuth2.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}++{-+ A simple OAuth2 Haskell binding. + This is sopposed to be independent with http client.+-}++module Network.OAuth2.OAuth2+ ( OAuth2 (..)+ , AccessToken (..)+ , OAuthException (..)+ , authorizationUrl+ , accessTokenUrl+ ) where++import Data.Aeson+import qualified Data.ByteString.Char8 as BS+import Data.Typeable (Typeable)+import Network.HTTP.Types (renderSimpleQuery)+import Control.Exception+import Control.Applicative ((<$>))+import Control.Monad (mzero)++-- | Query Parameter Representation+data OAuth2 = OAuth2 { oauthClientId :: BS.ByteString+ , oauthClientSecret :: BS.ByteString+ , oauthOAuthorizeEndpoint :: BS.ByteString+ , oauthAccessTokenEndpoint :: BS.ByteString+ , oauthCallback :: Maybe BS.ByteString+ , oauthAccessToken :: Maybe BS.ByteString+ } deriving (Show, Eq)++-- | Simple Exception representation.+data OAuthException = OAuthException String+ deriving (Show, Eq, Typeable)++instance Exception OAuthException++-- | The gained Access Token. Use @Data.Aeson.decode@ to decode string to @AccessToken@.+data AccessToken = AccessToken { accessToken :: BS.ByteString } deriving (Show)++instance FromJSON AccessToken where+ parseJSON (Object o) = AccessToken <$> o .: "access_token"+ parseJSON _ = mzero++--------------------------------------------------+-- Parameter Util + +-- | type synonym of query parameters +type QueryParams = [(BS.ByteString, BS.ByteString)]++-- | type synonym of post body content+type PostBody = [(BS.ByteString, BS.ByteString)]++-- | type synonym of a URI+type URI = BS.ByteString++-- | Append query parameters+appendQueryParam :: URI -> QueryParams -> URI+appendQueryParam uri q = uri `BS.append` renderSimpleQuery True q++-- | lift value in the Maybe and abonda Nothing+transform' :: [(a, Maybe b)] -> [(a, b)]+transform' = foldr step' []+ where step' :: (a, Maybe b) -> [(a, b)] -> [(a, b)]+ step' (a, Just b) xs = (a, b):xs+ step' _ xs = xs++--------------------------------------------------+-- oauth request urls++-- | Prepare the authorization URL. Redirect to this URL asking for user interactive authentication.+authorizationUrl :: OAuth2 -> URI+authorizationUrl oa = (oauthOAuthorizeEndpoint oa) `appendQueryParam` queryStr+ where queryStr = transform' [ ("client_id", Just $ oauthClientId oa)+ , ("response_type", Just "code")+ , ("redirect_uri", oauthCallback oa)]+++-- | Prepare access token URL and the request body query.++accessTokenUrl :: OAuth2 + -> BS.ByteString -- ^ access code gained via authorization URL+ -> (URI, PostBody) -- ^ access token request URL plus the request body.+accessTokenUrl oa code = accessTokenUrl' oa code (Just "authorization_code") +++accessTokenUrl' :: OAuth2 + -> BS.ByteString -- ^ access code gained via authorization URL+ -> Maybe BS.ByteString -- ^ Grant Type+ -> (URI, PostBody) -- ^ access token request URL plus the request body.+accessTokenUrl' oa code gt = (uri, body) + where uri = oauthAccessTokenEndpoint oa+ body = transform' [ ("client_id", Just $ oauthClientId oa)+ , ("client_secret", Just $ oauthClientSecret oa)+ , ("code", Just code)+ , ("redirect_uri", oauthCallback oa)+ , ("grant_type", gt) ]+
test/test-google.hs view
@@ -6,9 +6,11 @@ module Main where -import Network.OAuth2.HTTP.HttpClient import qualified Data.ByteString.Char8 as BS import Network.HTTP.Types (renderSimpleQuery, parseSimpleQuery)++import Network.OAuth2.HTTP.HttpClient+import Network.OAuth2.OAuth2 import GoogleKey gauth :: OAuth2@@ -22,7 +24,7 @@ print $ (authorizationUrl gauth) `BS.append` "&" `BS.append` googleScopeStr putStr "visit the url and paste code here: " code <- getLine- token <- postAccessToken gauth (BS.pack code) + token <- requestAccessToken gauth (BS.pack code) print token -- | this is special for google.
test/test-weibo.hs view
@@ -18,20 +18,17 @@ module Main where -import Network.OAuth2.HTTP.HttpClient import qualified Data.ByteString.Char8 as BS-import WeiboKey import Data.Maybe (fromJust)--import Control.Monad.Trans-import Control.Monad.Trans.Resource import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Network.HTTP.Types as HT import Network.HTTP.Conduit-import Control.Exception-import Control.Applicative ((<$>))-import Control.Monad (mzero) +import Network.OAuth2.HTTP.HttpClient+import Network.OAuth2.OAuth2++import WeiboKey+ weibooauth :: OAuth2 weibooauth = weiboKey { oauthOAuthorizeEndpoint = "https://api.weibo.com/oauth2/authorize" , oauthAccessTokenEndpoint = "https://api.weibo.com/oauth2/access_token" @@ -45,7 +42,7 @@ -- | send a request and get a response body if successfully otherwise error sendRequest :: Request IO -> IO BSL.ByteString sendRequest req = do- rsp <- request req+ rsp <- doRequest req if (HT.statusCode . statusCode) rsp == 200 then return $ responseBody rsp else return $ BSL.pack $ "Error when requesting: " ++ BSL.unpack (responseBody rsp)@@ -56,7 +53,7 @@ print $ authorizationUrl weibooauth putStr "visit the url and paste code here: " code <- getLine- token <- postAccessToken weibooauth (BS.pack code)+ token <- requestAccessToken weibooauth (BS.pack code) case token of Just (AccessToken token') -> do req <- return $ signRequest (weibooauth { oauthAccessToken = Just token'} ) accountUidReq