diff --git a/example/Douban/test.hs b/example/Douban/test.hs --- a/example/Douban/test.hs +++ b/example/Douban/test.hs @@ -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 diff --git a/example/Fitbit/test.hs b/example/Fitbit/test.hs --- a/example/Fitbit/test.hs +++ b/example/Fitbit/test.hs @@ -3,6 +3,7 @@ module Main where +import Control.Applicative import Control.Monad (mzero) import Data.Aeson import Data.Char (chr) diff --git a/example/Github/test.hs b/example/Github/test.hs --- a/example/Github/test.hs +++ b/example/Github/test.hs @@ -5,6 +5,7 @@ module Main where +import Control.Applicative import Control.Monad (mzero) import Data.Aeson import qualified Data.ByteString as BS diff --git a/example/run-7.6.sh b/example/run-7.6.sh deleted file mode 100644 --- a/example/run-7.6.sh +++ /dev/null @@ -1,2 +0,0 @@ -runghc -package-db=../cabal-dev/packages-7.6.1.conf $* - diff --git a/example/run.sh b/example/run.sh deleted file mode 100644 --- a/example/run.sh +++ /dev/null @@ -1,2 +0,0 @@ -runghc -package-conf=../.cabal-sandbox/x86_64-linux-ghc-7.4.1-packages.conf.d $* - diff --git a/hoauth2.cabal b/hoauth2.cabal --- a/hoauth2.cabal +++ b/hoauth2.cabal @@ -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: + * Google web: . - * github oauth: + * Github: . - * facebook + * Facebook: . - * fitbit + * Fitbit: . - * weibo oauth2: + * Weibo: . - * douban + * Douban: 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 diff --git a/src/Network/OAuth/OAuth2.hs b/src/Network/OAuth/OAuth2.hs --- a/src/Network/OAuth/OAuth2.hs +++ b/src/Network/OAuth/OAuth2.hs @@ -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 +-- Stability : alpha +-- Portability : portable +-- +-- A lightweight oauth2 haskell binding. +------------------------------------------------------------ + module Network.OAuth.OAuth2 (module Network.OAuth.OAuth2.HttpClient, module Network.OAuth.OAuth2.Internal diff --git a/src/Network/OAuth/OAuth2/HttpClient.hs b/src/Network/OAuth/OAuth2/HttpClient.hs --- a/src/Network/OAuth/OAuth2/HttpClient.hs +++ b/src/Network/OAuth/OAuth2/HttpClient.hs @@ -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 } diff --git a/src/Network/OAuth/OAuth2/Internal.hs b/src/Network/OAuth/OAuth2/Internal.hs --- a/src/Network/OAuth/OAuth2/Internal.hs +++ b/src/Network/OAuth/OAuth2/Internal.hs @@ -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. 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)