hoauth2 (empty) → 0.1
raw patch · 7 files changed
+260/−0 lines, 7 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, conduit, http-conduit, http-types, mtl
Files
- LICENSE +30/−0
- README.md +4/−0
- Setup.hs +2/−0
- hoauth2.cabal +58/−0
- src/Network/OAuth2/HTTP/HttpClient.hs +100/−0
- test/test-google.hs +29/−0
- test/test-weibo.hs +37/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2012, Haisheng Wu++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Haisheng Wu nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,4 @@+hoauth2+=======++haskell oauth 2
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hoauth2.cabal view
@@ -0,0 +1,58 @@+Name: hoauth2+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy)+Version: 0.1++Synopsis: hoauth2+Description: + Haskell OAuth2 authentication.+ .+ Tested following services+ .+ * google web oauth: <https://developers.google.com/accounts/docs/OAuth2WebServer>+ .+ * weibo oauth2: <http://open.weibo.com/wiki/Oauth2>++Homepage: freizl.github.com+License: BSD3+License-file: LICENSE+Author: Haisheng Wu+Maintainer: freizl@gmail.com+Copyright: Haisheng,Wu+Category: Network+Build-type: Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+Extra-source-files: + README.md+ test/test-google.hs+ test/test-weibo.hs++Cabal-version: >=1.6++Source-Repository head+ Type: git+ Location: https://github.com/freizl/hoauth2++Library+ Ghc-Options: -Wall + hs-source-dirs: src+ Exposed-modules: + Network.OAuth2.HTTP.HttpClient++ Build-Depends:+ base >= 4 && < 5,+ http-conduit >= 1.2.5 ,+ conduit >= 0.2,+ aeson >= 0.4 ,+ mtl >= 1 && < 2.2,+ bytestring >= 0.9 && < 0.10,+ http-types >= 0.6.8++ + -- Modules not exported by this package.+ -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+ -- Build-tools: +
+ src/Network/OAuth2/HTTP/HttpClient.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}++{-+ A simple OAuth2 client.+-}++module Network.OAuth2.HTTP.HttpClient + ( OAuth2 (..)+ , AccessToken (..)+ , authorizationUrl+ , postAccessToken+ , signRequest+ )+ where++import Control.Monad.Trans.Resource+import Data.Aeson+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as BSL+import Data.List+import Data.Maybe+import Data.Typeable (Typeable)+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 (mzero)++-- | Query Parameter Representation+data OAuth2 = OAuth2 { oauthClientId :: BS.ByteString+ , oauthClientSecret :: BS.ByteString+ , oauthOAuthorizeEndpoint :: BS.ByteString+ , oauthAccessTokenEndpoint :: BS.ByteString+ , oauthCallback :: Maybe BS.ByteString+ , oauthAccessToken :: Maybe BS.ByteString+ } deriving (Show, Eq)++data OAuthException = OAuthException String+ deriving (Show, Eq, Typeable)++instance Exception OAuthException++-- | The gained Access Token +data AccessToken = AccessToken { accessToken :: BS.ByteString } deriving (Show)++instance FromJSON AccessToken where+ parseJSON (Object o) = AccessToken <$> o .: "access_token"+ parseJSON _ = mzero++-- | Prepare the authorization URL+authorizationUrl :: OAuth2 -> BS.ByteString+authorizationUrl oa = oauthOAuthorizeEndpoint oa `BS.append` queryStr+ where queryStr = renderSimpleQuery True query+ query = foldr step [] [ ("client_id", Just $ oauthClientId oa)+ , ("response_type", Just "code")+ , ("redirect_uri", oauthCallback oa)]++request :: Control.Monad.Trans.Resource.ResourceIO m =>+ Request m -> m (Response BSL.ByteString)+request req = (withManager . httpLbs) (req { checkStatus = \_ _ -> Nothing })++postAccessToken' :: OAuth2 -> BS.ByteString -> Maybe BS.ByteString -> IO BSL.ByteString+postAccessToken' oa code grant_type = do+ print url+ print query+ rsp <- request req+ if (HT.statusCode . statusCode) rsp == 200+ then return $ responseBody rsp+ else throwIO . OAuthException $ "Gaining access_token failed: " ++ BSL.unpack (responseBody rsp)+ where+ req = urlEncodedBody query . fromJust $ parseUrl url+ url = BS.unpack $ oauthAccessTokenEndpoint oa+ query = foldr step [] [ ("client_id", Just $ oauthClientId oa)+ , ("client_secret", Just $ oauthClientSecret oa)+ , ("code", Just code)+ , ("redirect_uri", oauthCallback oa)+ , ("grant_type", grant_type) ]++++step :: (a, Maybe b) -> [(a, b)] -> [(a, b)]+step (a, Just b) xs = (a, b):xs+step _ xs = xs++-- | Request (POST method) access token URL in order to get @AccessToken@.+postAccessToken :: OAuth2 + -> BS.ByteString -- ^ Authentication code gained after authorization+ -> IO (Maybe AccessToken)+postAccessToken oa code = decode <$> postAccessToken' oa code (Just "authorization_code")++-- | +signRequest :: OAuth2 -> Request m -> Request m+signRequest oa req = req { queryString = (renderSimpleQuery False newQuery) }+ where+ newQuery = case oauthAccessToken oa of+ Just at -> insert ("oauth_token", at) oldQuery+ _ -> insert ("client_id", oauthClientId oa) . insert ("client_secret", oauthClientSecret oa) $ oldQuery+ oldQuery = parseSimpleQuery (queryString req)
+ test/test-google.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}++{-+google web oauth: https://developers.google.com/accounts/docs/OAuth2WebServer+-}++module Main where++import Network.OAuth2.HTTP.HttpClient+import qualified Data.ByteString.Char8 as BS+import Network.HTTP.Types (renderSimpleQuery, parseSimpleQuery)+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 <- postAccessToken gauth (BS.pack code) + print token++-- | this is special for google.+googleScopeStr = renderSimpleQuery False [("scope", "https://www.googleapis.com/auth/userinfo.email")]
+ test/test-weibo.hs view
@@ -0,0 +1,37 @@+{-# 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 Network.OAuth2.HTTP.HttpClient+import qualified Data.ByteString.Char8 as BS+import WeiboKey++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 <- postAccessToken weibooauth (BS.pack code) + print token