Permalink
Browse files

init

  • Loading branch information...
freizl committed Apr 29, 2012
1 parent 074f56f commit ef4c2d95c9820f91eee05da251f795be4d9ce8df
Showing with 278 additions and 0 deletions.
  1. +2 −0 .gitignore
  2. +30 −0 LICENSE
  3. +23 −0 Makefile
  4. +2 −0 Setup.hs
  5. +55 −0 hoauth2.cabal
  6. +100 −0 src/Network/OAuth2/HTTP/HttpClient.hs
  7. +29 −0 test/test-google.hs
  8. +37 −0 test/test-weibo.hs
View
@@ -0,0 +1,2 @@
+dist
+*Key.hs
View
30 LICENSE
@@ -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.
View
@@ -0,0 +1,23 @@
+
+HC=ghc
+
+DIST=dist
+
+default: build
+
+clean:
+ rm -rf $(DIST)
+
+conf:
+ cabal configure
+
+build: conf
+ cabal build
+
+rebuild: clean build
+
+install : build
+ cabal install
+
+doc : build
+ cabal haddock
View
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
View
@@ -0,0 +1,55 @@
+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:
+
+Cabal-version: >=1.2
+
+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:
+
@@ -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)
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")]
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

0 comments on commit ef4c2d9

Please sign in to comment.