diff --git a/hoauth2.cabal b/hoauth2.cabal --- a/hoauth2.cabal +++ b/hoauth2.cabal @@ -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. diff --git a/src/Network/OAuth2/HTTP/HttpClient.hs b/src/Network/OAuth2/HTTP/HttpClient.hs --- a/src/Network/OAuth2/HTTP/HttpClient.hs +++ b/src/Network/OAuth2/HTTP/HttpClient.hs @@ -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 diff --git a/src/Network/OAuth2/OAuth2.hs b/src/Network/OAuth2/OAuth2.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/OAuth2.hs @@ -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) ] + diff --git a/test/test-google.hs b/test/test-google.hs --- a/test/test-google.hs +++ b/test/test-google.hs @@ -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. diff --git a/test/test-weibo.hs b/test/test-weibo.hs --- a/test/test-weibo.hs +++ b/test/test-weibo.hs @@ -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