diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,8 @@ -hoauth2 -======= +## hoauth2 haskell oauth 2 + +## TODO + +- To be a snaplet ? +- Chinese decode of response 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.0 +Version: 0.2.2 Synopsis: hoauth2 Description: @@ -20,7 +20,7 @@ Copyright: Haisheng,Wu Category: Network Build-type: Simple -stability: experimental +stability: alpha tested-with: GHC == 7.0.3 @@ -28,8 +28,8 @@ -- a README. Extra-source-files: README.md - test/test-google.hs - test/test-weibo.hs + test/Google/test.hs + test/Weibo/test.hs Cabal-version: >=1.6 @@ -37,6 +37,7 @@ Type: git Location: https://github.com/freizl/hoauth2 + Library Ghc-Options: -Wall hs-source-dirs: src @@ -46,17 +47,21 @@ Build-Depends: base >= 4 && < 5, - http-conduit >= 1.2.5 && < 1.3.0, - conduit >= 0.2 && < 0.3.0, - aeson >= 0.4 && < 0.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 + 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 - -- Modules not exported by this package. - -- Other-modules: - - -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. - -- Build-tools: + if impl(ghc >= 6.12.0) + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 + -fno-warn-orphans -fno-warn-unused-do-bind + else + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 + -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 @@ -1,34 +1,32 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} {- A simple OAuth2 http client. -} -module Network.OAuth2.HTTP.HttpClient - ( requestAccessToken - , doRequest - , signRequest - ) where +module Network.OAuth2.HTTP.HttpClient where -import Control.Monad.Trans.Resource +import Control.Applicative ((<$>)) +import Control.Exception import Data.Aeson +import Network.HTTP.Conduit import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL -import Data.List -import Data.Maybe -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.Trans (liftIO) +import Control.Monad.IO.Class (MonadIO) +import Network.HTTP.Types (renderSimpleQuery) import Network.OAuth2.OAuth2 -------------------------------------------------- -- | 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) @@ -36,30 +34,34 @@ requestAccessToken' :: OAuth2 -> BS.ByteString -> IO BSL.ByteString -requestAccessToken' oa code = doRequest req >>= retOrError +requestAccessToken' oa code = doPostRequst (BS.unpack uri) body >>= retOrError where - req = urlEncodedBody body $ toReq' uri (uri, body) = accessTokenUrl oa code - retOrError rsp = if (HT.statusCode . statusCode) rsp == 200 + 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) --- | 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 - _ -> insert ("client_id", oauthClientId oa) . insert ("client_secret", oauthClientSecret oa) $ oldQuery - oldQuery = parseSimpleQuery (queryString req) - -------------------------------------------------- --- UTIL +-- od Request Utils -toReq' :: BS.ByteString -> Request a -toReq' = fromJust . parseUrl . BS.unpack +-- 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) +doSimpleGetRequest url = liftIO $ withManager $ \man -> do + req' <- liftIO $ parseUrl url + httpLbs req' man --- | Performance a http @Request@ -doRequest :: ResourceIO m => Request m -> m (Response BSL.ByteString) -doRequest = withManager . httpLbs +doGetRequest :: MonadIO m => String -> [(BS.ByteString, BS.ByteString)] -> m (Response BSL.ByteString) +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) +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 @@ -6,23 +6,21 @@ This is sopposed to be independent with http client. -} -module Network.OAuth2.OAuth2 - ( OAuth2 (..) - , AccessToken (..) - , OAuthException (..) - , authorizationUrl - , accessTokenUrl - ) where +module Network.OAuth2.OAuth2 where +import Control.Applicative ((<$>)) +import Control.Exception +import Control.Monad (mzero) import Data.Aeson -import qualified Data.ByteString.Char8 as BS +import Data.Maybe (fromJust) import Data.Typeable (Typeable) import Network.HTTP.Types (renderSimpleQuery) -import Control.Exception -import Control.Applicative ((<$>)) -import Control.Monad (mzero) +import qualified Data.ByteString as BS -- | Query Parameter Representation +-- +-- TODO: add a base endpoint URI. +-- data OAuth2 = OAuth2 { oauthClientId :: BS.ByteString , oauthClientSecret :: BS.ByteString , oauthOAuthorizeEndpoint :: BS.ByteString @@ -72,14 +70,13 @@ -- | Prepare the authorization URL. Redirect to this URL asking for user interactive authentication. authorizationUrl :: OAuth2 -> URI -authorizationUrl oa = (oauthOAuthorizeEndpoint oa) `appendQueryParam` queryStr +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. @@ -97,4 +94,21 @@ , ("code", Just code) , ("redirect_uri", oauthCallback oa) , ("grant_type", gt) ] + + +-------------------------------------------------- +-- UTIL + +-- | For GET method API. +appendAccessToken :: URI -- ^ Base URI + -> OAuth2 -- ^ OAuth has Authorized Access Token + -> URI -- ^ Combined Result +appendAccessToken uri oauth = uri `BS.append` renderSimpleQuery True (accessTokenToParam $ token oauth) + where + -- Expect Access Token exists + token :: OAuth2 -> BS.ByteString + token = fromJust . oauthAccessToken + +accessTokenToParam :: BS.ByteString -> [(BS.ByteString, BS.ByteString)] +accessTokenToParam token = [("access_token", token)] diff --git a/test/Google/test.hs b/test/Google/test.hs new file mode 100644 --- /dev/null +++ b/test/Google/test.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- +google web oauth: https://developers.google.com/accounts/docs/OAuth2WebServer +-} + +module Main where + +import qualified Data.ByteString.Char8 as BS +import Network.HTTP.Types (renderSimpleQuery, parseSimpleQuery) + +import Network.OAuth2.HTTP.HttpClient +import Network.OAuth2.OAuth2 +import Google.Key + +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 + + +-- | this is special for google. +--googleScopeStr = renderSimpleQuery False [("scope", "https://www.googleapis.com/auth/userinfo.email")] diff --git a/test/Weibo/test.hs b/test/Weibo/test.hs new file mode 100644 --- /dev/null +++ b/test/Weibo/test.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +{- + +weibo oauth2: http://open.weibo.com/wiki/Oauth2 + +This is very trivial testing of the httpclient api. +1. this case will print out a URL +2. run the URL in browser and will navigate to weibo auth page +3. conform the authentication and browser will navigate back to the callback url, + which obviously will failed cause there is no local server. +4. copy the `code` in the callback url and parse into console +5. this test case will gain access token using the `code` and print it out. + +check for integration testing at: +https://github.com/HaskellCNOrg/snaplet-oauth/tree/master/test + +-} + +module Main where + +import qualified Data.ByteString.Char8 as BS +import Data.Maybe (fromJust) +import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Network.HTTP.Types as HT +import Network.HTTP.Conduit +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.Conduit (MonadResource) + +import Network.OAuth2.HTTP.HttpClient +import Network.OAuth2.OAuth2 + +import Weibo.Key + +weibooauth :: OAuth2 +weibooauth = weiboKey { oauthOAuthorizeEndpoint = "https://api.weibo.com/oauth2/authorize" + , oauthAccessTokenEndpoint = "https://api.weibo.com/oauth2/access_token" + , oauthAccessToken = Nothing + } + +main :: IO () +main = do + print $ authorizationUrl weibooauth + putStr "visit the url and paste code here: " + code <- getLine + token <- requestAccessToken weibooauth (BS.pack code) + print token + diff --git a/test/test-google.hs b/test/test-google.hs deleted file mode 100644 --- a/test/test-google.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{- -google web oauth: https://developers.google.com/accounts/docs/OAuth2WebServer --} - -module Main where - -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 -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 - --- | this is special for google. -googleScopeStr = renderSimpleQuery False [("scope", "https://www.googleapis.com/auth/userinfo.email")] diff --git a/test/test-weibo.hs b/test/test-weibo.hs deleted file mode 100644 --- a/test/test-weibo.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{- - -weibo oauth2: http://open.weibo.com/wiki/Oauth2 - -This is very trivial testing of the httpclient api. -1. this case will print out a URL -2. run the URL in browser and will navigate to weibo auth page -3. conform the authentication and browser will navigate back to the callback url, - which obviously will failed cause there is no local server. -4. copy the `code` in the callback url and parse into console -5. this test case will gain access token using the `code` and print it out. - -TODO: - 1. a simple local server in order to make the test automatically. --} - -module Main where - -import qualified Data.ByteString.Char8 as BS -import Data.Maybe (fromJust) -import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Network.HTTP.Types as HT -import Network.HTTP.Conduit - -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" - , oauthAccessToken = Nothing - } - -urlToRequest = fromJust . parseUrl - -accountUidReq = urlToRequest "https://api.weibo.com/2/account/get_uid.json" - --- | send a request and get a response body if successfully otherwise error -sendRequest :: Request IO -> IO BSL.ByteString -sendRequest req = do - rsp <- doRequest req - if (HT.statusCode . statusCode) rsp == 200 - then return $ responseBody rsp - else return $ BSL.pack $ "Error when requesting: " ++ BSL.unpack (responseBody rsp) - --- | fetch UID -main :: IO () -main = do - print $ authorizationUrl weibooauth - putStr "visit the url and paste code here: " - code <- getLine - token <- requestAccessToken weibooauth (BS.pack code) - case token of - Just (AccessToken token') -> do - req <- return $ signRequest (weibooauth { oauthAccessToken = Just token'} ) accountUidReq - print (queryString req) - sendRequest req >>= print - _ -> print "no token found"