hoauth2 0.2.0 → 0.2.2

raw patch · 8 files changed

+164/−151 lines, 8 filesdep +bytestring-showdep +monad-controldep +transformersdep ~aesondep ~conduitdep ~http-conduitPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bytestring-show, monad-control, transformers

Dependency ranges changed: aeson, conduit, http-conduit

API changes (from Hackage documentation)

Files

• README.md +6/−2
• hoauth2.cabal +18/−13
• src/Network/OAuth2/HTTP/HttpClient.hs +32/−30
• src/Network/OAuth2/OAuth2.hs +27/−13
• test/Google/test.hs +32/−0
• test/Weibo/test.hs +49/−0
• test/test-google.hs +0/−31
• test/test-weibo.hs +0/−62

@@ -1,4 +1,8 @@-hoauth2-=======+## hoauth2  haskell oauth 2++## TODO++- To be a snaplet ?+- Chinese decode of response

@@ -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           

@@ -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+

@@ -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)] 

@@ -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")]

@@ -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+

@@ -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")]

@@ -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"