hoauth2 0.5.0 → 0.5.0.1
raw patch · 9 files changed
+77/−79 lines, 9 filesnew-component:exe:test-facebook
Files
- example/Douban/test.hs +3/−2
- example/Fitbit/test.hs +1/−0
- example/Github/test.hs +1/−0
- example/run-7.6.sh +0/−2
- example/run.sh +0/−2
- hoauth2.cabal +13/−18
- src/Network/OAuth/OAuth2.hs +13/−0
- src/Network/OAuth/OAuth2/HttpClient.hs +27/−25
- src/Network/OAuth/OAuth2/Internal.hs +19/−30
example/Douban/test.hs view
@@ -31,8 +31,9 @@ print token case token of Right r -> do- uid <- authGetBS mgr r "https://api.douban.com/v2/user/~me"- print uid+ -- TODO: display Chinese character. (Text UTF-8 encodeing does not work, why?)+ uid <- authGetBS mgr r "https://api.douban.com/v2/user/~me"+ print uid Left l -> BSL.putStrLn l sToBS :: String -> BS.ByteString
example/Fitbit/test.hs view
@@ -3,6 +3,7 @@ module Main where +import Control.Applicative import Control.Monad (mzero) import Data.Aeson import Data.Char (chr)
example/Github/test.hs view
@@ -5,6 +5,7 @@ module Main where +import Control.Applicative import Control.Monad (mzero) import Data.Aeson import qualified Data.ByteString as BS
− example/run-7.6.sh
@@ -1,2 +0,0 @@-runghc -package-db=../cabal-dev/packages-7.6.1.conf $*-
− example/run.sh
@@ -1,2 +0,0 @@-runghc -package-conf=../.cabal-sandbox/x86_64-linux-ghc-7.4.1-packages.conf.d $*-
hoauth2.cabal view
@@ -1,24 +1,22 @@ Name: hoauth2--- https://wiki.haskell.org/Package_versioning_policy-Version: 0.5.0+-- http://wiki.haskell.org/Package_versioning_policy+Version: 0.5.0.1 -Synopsis: hoauth2+Synopsis: Haskell OAuth2 authentication client Description:- Haskell OAuth2 authentication.- .- Tested following services+ Haskell OAuth2 authentication client. Tested with the following services: .- * google web oauth: <https://developers.google.com/accounts/docs/OAuth2WebServer>+ * Google web: <https://developers.google.com/accounts/docs/OAuth2WebServer> .- * github oauth: <http://developer.github.com/v3/oauth/>+ * Github: <http://developer.github.com/v3/oauth/> .- * facebook+ * Facebook: <http://developers.facebook.com/docs/facebook-login/> .- * fitbit+ * Fitbit: <http://dev.fitbit.com/docs/oauth2/> .- * weibo oauth2: <http://open.weibo.com/wiki/Oauth2>+ * Weibo: <http://open.weibo.com/wiki/Oauth2> .- * douban <http://developers.douban.com/wiki/?title=oauth2>+ * Douban: <http://developers.douban.com/wiki/?title=oauth2> Homepage: https://github.com/freizl/hoauth2 License: BSD3@@ -31,18 +29,15 @@ stability: alpha tested-with: GHC <= 7.10.2 ---- Extra files to be distributed with the package, such as examples or--- a README. Extra-source-files: README.md example/Google/test.hs example/Weibo/test.hs example/Github/test.hs example/Facebook/test.hs+ example/Fitbit/test.hs+ example/Douban/test.hs example/Keys.hs.sample- example/run-7.6.sh- example/run.sh Cabal-version: >=1.10 @@ -169,7 +164,7 @@ else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -Executable test-fb+Executable test-facebook if flag(test) Buildable: True else
src/Network/OAuth/OAuth2.hs view
@@ -1,3 +1,16 @@+------------------------------------------------------------+-- |+-- Module : Network.OAuth.OAuth2+-- Description : OAuth2 client+-- Copyright : (c) 2012 Haisheng Wu+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Haisheng Wu <freizl@gmail.com>+-- Stability : alpha+-- Portability : portable+--+-- A lightweight oauth2 haskell binding.+------------------------------------------------------------+ module Network.OAuth.OAuth2 (module Network.OAuth.OAuth2.HttpClient, module Network.OAuth.OAuth2.Internal
src/Network/OAuth/OAuth2/HttpClient.hs view
@@ -3,7 +3,25 @@ -- | A simple http client to request OAuth2 tokens and several utils. -module Network.OAuth.OAuth2.HttpClient where+module Network.OAuth.OAuth2.HttpClient (+-- * Token management+ fetchAccessToken,+ fetchRefreshToken,+ doJSONPostRequest,+ doSimplePostRequest,+-- * AUTH requests+ authGetJSON,+ authGetBS,+ authGetBS',+ authPostJSON,+ authPostBS,+ authRequest,+-- * Utilities+ handleResponse,+ parseResponseJSON,+ updateRequestHeaders,+ setMethod+) where import Control.Monad (liftM) import Data.Aeson@@ -16,12 +34,10 @@ import Network.OAuth.OAuth2.Internal ----------------------------------------------------- * Retrieve access token+-- * Token management -------------------------------------------------- -- | Request (via POST method) "Access Token".------ fetchAccessToken :: Manager -- ^ HTTP connection manager -> OAuth2 -- ^ OAuth Data -> BS.ByteString -- ^ Authentication code gained after authorization@@ -66,7 +82,6 @@ -------------------------------------------------- -- | Conduct GET request and return response as JSON.--- authGetJSON :: FromJSON a => Manager -- ^ HTTP connection manager. -> AccessToken@@ -75,7 +90,6 @@ authGetJSON manager t uri = liftM parseResponseJSON $ authGetBS manager t uri -- | Conduct GET request.--- authGetBS :: Manager -- ^ HTTP connection manager. -> AccessToken -> URI -- ^ URL@@ -86,7 +100,6 @@ where upReq = updateRequestHeaders (Just token) . setMethod HT.GET -- | same to 'authGetBS' but set access token to query parameter rather than header--- authGetBS' :: Manager -- ^ HTTP connection manager. -> AccessToken -> URI -- ^ URL@@ -96,7 +109,6 @@ authRequest req upReq manager where upReq = updateRequestHeaders Nothing . setMethod HT.GET - -- | Conduct POST request and return response as JSON. authPostJSON :: FromJSON a => Manager -- ^ HTTP connection manager.@@ -119,27 +131,20 @@ upHeaders = updateRequestHeaders (Just token) . setMethod HT.POST upReq = upHeaders . upBody --- |Sends a HTTP request including the Authorization header with the specified+-- |Send an HTTP request including the Authorization header with the specified -- access token. -- authRequest :: Request -- ^ Request to perform -> (Request -> Request) -- ^ Modify request before sending -> Manager -- ^ HTTP connection manager. -> IO (OAuth2Result BSL.ByteString)-authRequest req upReq manager = liftM handleResponse (authRequest' req upReq manager)--authRequest' :: Request -- ^ Request to perform- -> (Request -> Request) -- ^ Modify request before sending- -> Manager -- ^ HTTP connection manager.- -> IO (Response BSL.ByteString)-authRequest' req upReq = httpLbs (upReq req)+authRequest req upReq manager = liftM handleResponse (httpLbs (upReq req) manager) -------------------------------------------------- -- * Utilities -------------------------------------------------- -- | Parses a @Response@ to to @OAuth2Result@--- handleResponse :: Response BSL.ByteString -> OAuth2Result BSL.ByteString handleResponse rsp = if HT.statusIsSuccessful (responseStatus rsp)@@ -147,7 +152,6 @@ else Left $ BSL.append "Gaining token failed: " (responseBody rsp) -- | Parses a @OAuth2Result BSL.ByteString@ into @FromJSON a => a@--- parseResponseJSON :: FromJSON a => OAuth2Result BSL.ByteString -> OAuth2Result a@@ -156,11 +160,10 @@ Nothing -> Left ("Could not decode JSON" `BSL.append` b) Just x -> Right x --- | set several header values.--- + userAgennt : hoauth2--- + accept : application/json--- + authorization : Bearer xxxxx if AccessToken provided.---+-- | Set several header values:+-- + userAgennt : `hoauth2`+-- + accept : `application/json`+-- + authorization : 'Bearer' `xxxxx` if 'AccessToken' provided. updateRequestHeaders :: Maybe AccessToken -> Request -> Request updateRequestHeaders t req = let extras = [ (HT.hUserAgent, "hoauth2")@@ -170,7 +173,6 @@ in req { requestHeaders = headers } --- | Sets the HTTP method to use---+-- | Set the HTTP method to use. setMethod :: HT.StdMethod -> Request -> Request setMethod m req = req { method = HT.renderStdMethod m }
src/Network/OAuth/OAuth2/Internal.hs view
@@ -2,11 +2,12 @@ {-# OPTIONS_HADDOCK -ignore-exports #-} --- | A simple OAuth2 Haskell binding.--- (This is supposed to be independent with http client.)+-- | A simple OAuth2 Haskell binding. (This is supposed to be+-- independent of the http client used.) module Network.OAuth.OAuth2.Internal where +import Control.Applicative ((<$>), (<*>)) import Control.Monad (mzero) import Data.Aeson import qualified Data.ByteString as BS@@ -20,7 +21,6 @@ -------------------------------------------------- -- | Query Parameter Representation--- data OAuth2 = OAuth2 { oauthClientId :: BS.ByteString , oauthClientSecret :: BS.ByteString@@ -30,10 +30,10 @@ } deriving (Show, Eq) --- | The gained Access Token. Use @Data.Aeson.decode@ to decode string to @AccessToken@.--- The @refresheToken@ is special at some case.--- e.g. https://developers.google.com/accounts/docs/OAuth2---+-- | The gained Access Token. Use @Data.Aeson.decode@ to+-- decode string to @AccessToken@. The @refreshToken@ is+-- special in some cases,+-- e.g. <https://developers.google.com/accounts/docs/OAuth2> data AccessToken = AccessToken { accessToken :: BS.ByteString , refreshToken :: Maybe BS.ByteString@@ -41,8 +41,7 @@ , tokenType :: Maybe BS.ByteString } deriving (Show) --- | Parse JSON data into {AccessToken}---+-- | Parse JSON data into 'AccessToken' instance FromJSON AccessToken where parseJSON (Object o) = AccessToken <$> at <*> rt <*> ei <*> tt where at = fmap encodeUtf8 $ o .: "access_token"@@ -56,7 +55,6 @@ -------------------------------------------------- -- | Is either 'Left' containing an error or 'Right' containg a result--- type OAuth2Result a = Either BSL.ByteString a -- | type synonym of query parameters@@ -73,9 +71,8 @@ -- * URLs -------------------------------------------------- --- | Prepare the authorization URL.--- Redirect to this URL asking for user interactive authentication.---+-- | 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)@@ -83,13 +80,14 @@ , ("redirect_uri", oauthCallback oa)] --- | Prepare URL and the request body query for fetching access token.---+-- | Prepare the URL and the request body query for fetching an access token. 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") +-- | Prepare the URL and the request body query for fetching an access token, with+-- optional grant type. accessTokenUrl' :: OAuth2 -> BS.ByteString -- ^ access code gained via authorization URL -> Maybe BS.ByteString -- ^ Grant Type@@ -102,9 +100,8 @@ , ("redirect_uri", oauthCallback oa) , ("grant_type", gt) ] --- | Using a Refresh Token.--- obtain a new access token by sending a refresh token to the Authorization server.---+-- | Using a Refresh Token. Obtain a new access token by+-- sending a refresh token to the Authorization server. refreshAccessTokenUrl :: OAuth2 -> BS.ByteString -- ^ refresh token gained via authorization URL -> (URI, PostBody) -- ^ refresh token request URL plus the request body.@@ -119,31 +116,23 @@ -- * UTILs -------------------------------------------------- --- | Append query parameters with '?'+-- | Append query parameters using `"?"` or `"&"`. appendQueryParam :: URI -> QueryParams -> URI appendQueryParam uri q = if "?" `BS.isInfixOf` uri then uri `BS.append` "&" `BS.append` renderSimpleQuery False q else uri `BS.append` renderSimpleQuery True q --- | Append query parameters with '&'.--- appendQueryParam' :: URI -> QueryParams -> URI--- appendQueryParam' uri q = uri `BS.append` "&" `BS.append` renderSimpleQuery False q----- | For GET method API.+-- | For `GET` method API. appendAccessToken :: URI -- ^ Base URI -> AccessToken -- ^ Authorized Access Token -> URI -- ^ Combined Result appendAccessToken uri t = appendQueryParam uri (accessTokenToParam t) --- | Create QueryParams with given access token value.------accessTokenToParam :: BS.ByteString -> QueryParams---accessTokenToParam token = [("access_token", token)]+-- | Create 'QueryParams' with given access token value. accessTokenToParam :: AccessToken -> QueryParams accessTokenToParam (AccessToken token _ _ _) = [("access_token", token)] --- | lift value in the Maybe and abonda Nothing+-- | Lift value in the 'Maybe' and abandon 'Nothing'. transform' :: [(a, Maybe b)] -> [(a, b)] transform' = map (\(a, Just b) -> (a, b)) . filter (isJust . snd)