hoauth2 0.2.2 → 0.2.3

raw patch · 6 files changed

+158/−61 lines, 6 filesdep ~conduitdep ~http-conduitdep ~http-typesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: conduit, http-conduit, http-types, transformers

API changes (from Hackage documentation)

Files

• README.md +10/−5
• hoauth2.cabal +16/−18
• src/Network/OAuth2/HTTP/HttpClient.hs +39/−17
• src/Network/OAuth2/OAuth2.hs +36/−11
• test/Google/test.hs +56/−9
• test/Weibo/test.hs +1/−1

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

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

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

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

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

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