diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,13 @@ -## hoauth2 +[![Build Status](https://secure.travis-ci.org/freizl/hoauth2.png?branch=master)](http://travis-ci.org/freizl/hoauth2) -haskell oauth 2 +## Introduction -## TODO +A lightweight oauth2 haskell binding. See examples in `test/` folder. -- To be a snaplet ? -- Chinese decode of response +In additions, [snaplet-oauth] use this lib as well. + +[snaplet-oauth]: https://github.com/HaskellCNOrg/snaplet-oauth + +## Contribute + +Feel free send pull request or submit issue ticket. 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.2.2 +Version: 0.2.3 Synopsis: hoauth2 Description: @@ -21,7 +21,7 @@ Category: Network Build-type: Simple stability: alpha -tested-with: GHC == 7.0.3 +tested-with: GHC <= 7.4.1 -- Extra files to be distributed with the package, such as examples or @@ -31,7 +31,7 @@ test/Google/test.hs test/Weibo/test.hs -Cabal-version: >=1.6 +Cabal-version: >=1.8 Source-Repository head Type: git @@ -39,29 +39,27 @@ Library - Ghc-Options: -Wall hs-source-dirs: src Exposed-modules: Network.OAuth2.HTTP.HttpClient Network.OAuth2.OAuth2 Build-Depends: - base >= 4 && < 5, - http-conduit >= 1.4 && < 1.5, - conduit >= 0.4.1 && < 0.5, - aeson >= 0.6 && < 0.7, - mtl >= 1 && < 2.2, - bytestring >= 0.9 && < 0.10, - http-types >= 0.6.8 && < 0.7, - monad-control >= 0.3 && < 0.4, - transformers >= 0.2 && < 0.3, - bytestring-show >= 0.3.5 && < 0.4 - + aeson >= 0.6 && < 0.7, + base >= 4 && < 5, + bytestring >= 0.9 && < 0.10, + bytestring-show >= 0.3.5 && < 0.4, + conduit >= 0.5 && < 0.6, + http-conduit >= 1.6 && < 1.7, + http-types >= 0.7 && < 0.8, + monad-control >= 0.3 && < 0.4, + mtl >= 1 && < 2.2, + transformers >= 0.2 && < 0.4 if impl(ghc >= 6.12.0) - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-orphans -fno-warn-unused-do-bind else - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-orphans - + 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,9 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} -{- - A simple OAuth2 http client. --} +-- | A simple http client for request OAuth2 tokens and several utils. module Network.OAuth2.HTTP.HttpClient where @@ -27,41 +25,65 @@ -- -- 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 +requestAccessToken :: OAuth2 -- ^ OAuth Data + -> BS.ByteString -- ^ Authentication code gained after authorization + -> IO (Maybe AccessToken) -- ^ Access Token +requestAccessToken oa code = decode <$> postRequest (accessTokenUrl oa code) -requestAccessToken' :: OAuth2 -> BS.ByteString -> IO BSL.ByteString -requestAccessToken' oa code = doPostRequst (BS.unpack uri) body >>= retOrError +-- | Request the "Refresh Token". +-- +refreshAccessToken :: OAuth2 + -> BS.ByteString -- ^ refresh token gained after authorization + -> IO (Maybe AccessToken) +refreshAccessToken oa rtoken = decode <$> postRequest (refreshAccessTokenUrl oa rtoken) + + +-------------------------------------------------- + +-- | Conduct post request in IO monad. +-- +postRequest :: (URI, PostBody) -- ^ The URI and request body for fetching token. + -> IO BSL.ByteString -- ^ request response +postRequest (uri, body) = doPostRequst (BS.unpack uri) body >>= retOrError where - (uri, body) = accessTokenUrl oa code retOrError rsp = if (HT.statusCode . responseStatus) rsp == 200 - --then (print $ responseBody rsp ) >> (return $ responseBody rsp) then return $ responseBody rsp - else throwIO . OAuthException $ "Gaining access_token failed: " ++ BSL.unpack (responseBody rsp) + else throwIO . OAuthException $ "Gaining token failed: " ++ BSL.unpack (responseBody rsp) -------------------------------------------------- -- od Request Utils - -- TODO: Some duplication here. -- TODO: Control.Exception.try -- result <- liftIO $ Control.Exception.try $ runResourceT $ httpLbs request man -- -doSimpleGetRequest :: MonadIO m => String -> m (Response BSL.ByteString) + +-- | Conduct GET request with given URL. +-- +doSimpleGetRequest :: MonadIO m + => String -- ^ URL + -> m (Response BSL.ByteString) -- ^ Response doSimpleGetRequest url = liftIO $ withManager $ \man -> do req' <- liftIO $ parseUrl url httpLbs req' man -doGetRequest :: MonadIO m => String -> [(BS.ByteString, BS.ByteString)] -> m (Response BSL.ByteString) +-- | Conduct GET request with given URL by append extra parameters provided. +-- +doGetRequest :: MonadIO m + => String -- ^ URL + -> [(BS.ByteString, BS.ByteString)] -- ^ Extra Parameters + -> m (Response BSL.ByteString) -- ^ Response doGetRequest url pm = liftIO $ withManager $ \man -> do req' <- liftIO $ parseUrl $ url ++ BS.unpack (renderSimpleQuery True pm) httpLbs req' man -doPostRequst :: MonadIO m => String -> [(BS.ByteString, BS.ByteString)] -> m (Response BSL.ByteString) +-- | Conduct POST request with given URL with post body data. +-- +doPostRequst :: MonadIO m + => String -- ^ URL + -> [(BS.ByteString, BS.ByteString)] -- ^ Data to Post Body + -> m (Response BSL.ByteString) -- ^ Response doPostRequst url body = liftIO $ withManager $ \man -> do req' <- liftIO $ parseUrl url httpLbs (urlEncodedBody body req') man - diff --git a/src/Network/OAuth2/OAuth2.hs b/src/Network/OAuth2/OAuth2.hs --- a/src/Network/OAuth2/OAuth2.hs +++ b/src/Network/OAuth2/OAuth2.hs @@ -1,14 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} -{- - A simple OAuth2 Haskell binding. - This is sopposed to be independent with http client. --} +-- | A simple OAuth2 Haskell binding. +-- (This is supposed to be independent with http client.) module Network.OAuth2.OAuth2 where -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<*>)) import Control.Exception import Control.Monad (mzero) import Data.Aeson @@ -19,7 +17,8 @@ -- | Query Parameter Representation -- --- TODO: add a base endpoint URI. +-- TODO: 1. add a base endpoint URI. +-- 2. May to be State Transform -- data OAuth2 = OAuth2 { oauthClientId :: BS.ByteString , oauthClientSecret :: BS.ByteString @@ -33,13 +32,22 @@ data OAuthException = OAuthException String deriving (Show, Eq, Typeable) +-- | OAuthException is kind of Exception. +-- instance Exception OAuthException -- | The gained Access Token. Use @Data.Aeson.decode@ to decode string to @AccessToken@. -data AccessToken = AccessToken { accessToken :: BS.ByteString } deriving (Show) +-- The @refresheToken@ is special at some case, e.g. https://developers.google.com/accounts/docs/OAuth2 +-- +data AccessToken = AccessToken { accessToken :: BS.ByteString + , refreshToken :: Maybe BS.ByteString } deriving (Show) +-- | Parse JSON data into {AccessToken} +-- instance FromJSON AccessToken where - parseJSON (Object o) = AccessToken <$> o .: "access_token" + parseJSON (Object o) = AccessToken + <$> o .: "access_token" + <*> o .:? "refresh_token" parseJSON _ = mzero -------------------------------------------------- @@ -68,7 +76,9 @@ -------------------------------------------------- -- oauth request 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) @@ -76,7 +86,8 @@ , ("redirect_uri", oauthCallback oa)] --- | Prepare access token URL and the request body query. +-- | Prepare URL and the request body query for fetching access token. +-- accessTokenUrl :: OAuth2 -> BS.ByteString -- ^ access code gained via authorization URL -> (URI, PostBody) -- ^ access token request URL plus the request body. @@ -95,6 +106,18 @@ , ("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. +-- +refreshAccessTokenUrl :: OAuth2 + -> BS.ByteString -- ^ refresh token gained via authorization URL + -> (URI, PostBody) -- ^ refresh token request URL plus the request body. +refreshAccessTokenUrl oa rtoken = (uri, body) + where uri = oauthAccessTokenEndpoint oa + body = transform' [ ("client_id", Just $ oauthClientId oa) + , ("client_secret", Just $ oauthClientSecret oa) + , ("grant_type", Just "refresh_token") + , ("refresh_token", Just rtoken) ] -------------------------------------------------- -- UTIL @@ -109,6 +132,8 @@ token :: OAuth2 -> BS.ByteString token = fromJust . oauthAccessToken -accessTokenToParam :: BS.ByteString -> [(BS.ByteString, BS.ByteString)] +-- | Create QueryParams with given access token value. +-- +accessTokenToParam :: BS.ByteString -> QueryParams accessTokenToParam token = [("access_token", token)] diff --git a/test/Google/test.hs b/test/Google/test.hs --- a/test/Google/test.hs +++ b/test/Google/test.hs @@ -1,32 +1,79 @@ {-# LANGUAGE OverloadedStrings #-} {- + +This is basically very manual test. Check following link for details. + google web oauth: https://developers.google.com/accounts/docs/OAuth2WebServer + -} module Main where import qualified Data.ByteString.Char8 as BS +import Data.Maybe (fromJust) import Network.HTTP.Types (renderSimpleQuery, parseSimpleQuery) +import System.Environment import Network.OAuth2.HTTP.HttpClient import Network.OAuth2.OAuth2 import Google.Key + +-------------------------------------------------- + +main :: IO () +main = do + (x:_) <- getArgs + case x of + "normal" -> normalCase + "offline" -> offlineCase + + +offlineCase :: IO () +offlineCase = do + print $ authorizationUrl gauth `BS.append` "&" `BS.append` extraParams + putStrLn "visit the url and paste code here: " + code <- getLine + (Just (AccessToken accessToken refreshToken)) <- requestAccessToken gauth (BS.pack code) + print (accessToken, refreshToken) + validateToken accessToken >>= print + -- + -- obtain a new access token with refresh token, which turns out only in response at first time. + -- Revoke Access https://www.google.com/settings/security + -- + refreshAccessToken gauth (fromJust refreshToken) >>= print + where extraParams = renderSimpleQuery False $ ("access_type", "offline"):googleScopeEmail + + +normalCase :: IO () +normalCase = do + print $ authorizationUrl gauth `BS.append` "&" `BS.append` extraParams + putStrLn "visit the url and paste code here: " + code <- getLine + (Just (AccessToken accessToken Nothing)) <- requestAccessToken gauth (BS.pack code) + print accessToken + res <- validateToken accessToken + print res + where extraParams = renderSimpleQuery False googleScopeEmail + +-------------------------------------------------- + gauth :: OAuth2 gauth = googleKeys { oauthOAuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth" , oauthAccessTokenEndpoint = "https://accounts.google.com/o/oauth2/token" , oauthAccessToken = Nothing } -main :: IO () -main = do - print $ authorizationUrl gauth `BS.append` "&" `BS.append` googleScopeStr - putStr "visit the url and paste code here: " - code <- getLine - token <- requestAccessToken gauth (BS.pack code) - print token +-------------------------------------------------- +-- Google API +-- | this is special for google Gain read-only access to the user's email address. +googleScopeEmail = [("scope", "https://www.googleapis.com/auth/userinfo.email")] --- | this is special for google. ---googleScopeStr = renderSimpleQuery False [("scope", "https://www.googleapis.com/auth/userinfo.email")] +-- | Gain read-only access to basic profile information, including a +googleScopeUserInfo = [("scope", "https://www.googleapis.com/auth/userinfo.profile")] + +-- Token Validation +validateToken accessToken = postRequest ("https://www.googleapis.com/oauth2/v1/tokeninfo", + (accessTokenToParam accessToken)) diff --git a/test/Weibo/test.hs b/test/Weibo/test.hs --- a/test/Weibo/test.hs +++ b/test/Weibo/test.hs @@ -42,7 +42,7 @@ main :: IO () main = do print $ authorizationUrl weibooauth - putStr "visit the url and paste code here: " + putStrLn "visit the url and paste code here: " code <- getLine token <- requestAccessToken weibooauth (BS.pack code) print token