hoauth2-0.5.4.0/0000755000000000000000000000000012730030223011406 5ustar0000000000000000hoauth2-0.5.4.0/hoauth2.cabal0000644000000000000000000001700212730030223013744 0ustar0000000000000000Name: hoauth2 -- http://wiki.haskell.org/Package_versioning_policy Version: 0.5.4.0 Synopsis: Haskell OAuth2 authentication client Description: Haskell OAuth2 authentication client. Tested with the following services: . * Google web: . * Github: . * Facebook: . * Fitbit: . * Weibo: . * Douban: Homepage: https://github.com/freizl/hoauth2 License: BSD3 License-file: LICENSE Author: Haisheng Wu Maintainer: Haisheng Wu Copyright: Haisheng Wu Category: Network Build-type: Simple stability: Beta tested-with: GHC <= 7.10.2 Extra-source-files: README.md example/Google/test.hs example/Weibo/test.hs example/Github/test.hs example/Facebook/test.hs example/Fitbit/test.hs example/Douban/test.hs example/Keys.hs.sample Cabal-version: >=1.10 Source-Repository head Type: git Location: git://github.com/freizl/hoauth2.git Flag test Description: Build the executables Default: False Library hs-source-dirs: src default-language: Haskell2010 Exposed-modules: Network.OAuth.OAuth2.HttpClient Network.OAuth.OAuth2.Internal Network.OAuth.OAuth2 Build-Depends: base >= 4 && < 5, aeson >= 0.9 && < 0.12, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, http-conduit >= 2.0 && < 2.2, http-types >= 0.9 && < 0.10 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields Executable test-weibo if flag(test) Buildable: True else Buildable: False main-is: Weibo/test.hs hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, http-types >= 0.9 && < 0.10, http-conduit >= 2.0 && < 2.2, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, hoauth2 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields Executable test-google if flag(test) Buildable: True else Buildable: False main-is: Google/test.hs hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, http-types >= 0.9 && < 0.10, http-conduit >= 2.0 && < 2.2, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, aeson >= 0.9 && < 0.12, hoauth2 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields Executable test-github if flag(test) Buildable: True else Buildable: False main-is: Github/test.hs hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, http-types >= 0.9 && < 0.10, http-conduit >= 2.0 && < 2.2, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, aeson >= 0.9 && < 0.12, hoauth2 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields Executable test-douban if flag(test) Buildable: True else Buildable: False main-is: Douban/test.hs hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, http-types >= 0.9 && < 0.10, http-conduit >= 2.0 && < 2.2, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, aeson >= 0.9 && < 0.12, hoauth2 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields Executable test-facebook if flag(test) Buildable: True else Buildable: False main-is: Facebook/test.hs hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, http-types >= 0.9 && < 0.10, http-conduit >= 2.0 && < 2.2, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, aeson >= 0.9 && < 0.12, hoauth2 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields Executable test-fitbit if flag(test) Buildable: True else Buildable: False main-is: Fitbit/test.hs hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, aeson >= 0.9 && < 0.12, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, http-conduit >= 2.0 && < 2.2, http-types >= 0.9 && < 0.10, wai >= 3.2 && < 3.3, warp >= 3.2 && < 3.3, containers >= 0.4 && < 0.6, hoauth2 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields Executable test-stackexchange if flag(test) Buildable: True else Buildable: False main-is: StackExchange/test.hs hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, http-types >= 0.9 && < 0.10, http-conduit >= 2.0 && < 2.2, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, aeson >= 0.9 && < 0.12, hoauth2 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields hoauth2-0.5.4.0/LICENSE0000644000000000000000000000275712730030223012426 0ustar0000000000000000Copyright (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. hoauth2-0.5.4.0/README.md0000644000000000000000000000057212730030223012671 0ustar0000000000000000[![Build Status](https://secure.travis-ci.org/freizl/hoauth2.svg?branch=master)](http://travis-ci.org/freizl/hoauth2) [![Hackage](https://img.shields.io/hackage/v/hoauth2.svg)](https://hackage.haskell.org/package/hoauth2) # Introduction A lightweight oauth2 haskell binding. See examples in `example/` folder. # Contribute Feel free send pull request or submit issue ticket. hoauth2-0.5.4.0/Setup.hs0000644000000000000000000000005612730030223013043 0ustar0000000000000000import Distribution.Simple main = defaultMain hoauth2-0.5.4.0/example/0000755000000000000000000000000012730030223013041 5ustar0000000000000000hoauth2-0.5.4.0/example/Keys.hs.sample0000644000000000000000000000625012730030223015573 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Keys where import Network.OAuth.OAuth2 weiboKey :: OAuth2 weiboKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx" , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxx" , oauthCallback = Just "http://127.0.0.1:9988/oauthCallback" , oauthOAuthorizeEndpoint = "https://api.weibo.com/oauth2/authorize" , oauthAccessTokenEndpoint = "https://api.weibo.com/oauth2/access_token" } -- | http://developer.github.com/v3/oauth/ githubKey :: OAuth2 githubKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx" , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxx" , oauthCallback = Just "http://127.0.0.1:9988/githubCallback" , oauthOAuthorizeEndpoint = "https://github.com/login/oauth/authorize" , oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token" } -- | oauthCallback = Just "https://developers.google.com/oauthplayground" googleKey :: OAuth2 googleKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx.apps.googleusercontent.com" , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxx" , oauthCallback = Just "http://127.0.0.1:9988/googleCallback" , oauthOAuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth" , oauthAccessTokenEndpoint = "https://www.googleapis.com/oauth2/v3/token" } facebookKey :: OAuth2 facebookKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx" , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxx" , oauthCallback = Just "http://t.haskellcn.org/cb" , oauthOAuthorizeEndpoint = "https://www.facebook.com/dialog/oauth" , oauthAccessTokenEndpoint = "https://graph.facebook.com/v2.3/oauth/access_token" } doubanKey :: OAuth2 doubanKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx" , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxx" , oauthCallback = Just "http://localhost:9999/oauthCallback" , oauthOAuthorizeEndpoint = "https://www.douban.com/service/auth2/auth" , oauthAccessTokenEndpoint = "https://www.douban.com/service/auth2/token" } fitbitKey :: OAuth2 fitbitKey = OAuth2 { oauthClientId = "xxxxxx" , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" , oauthCallback = Just "http://localhost:9988/oauth2/callback" , oauthOAuthorizeEndpoint = "https://www.fitbit.com/oauth2/authorize" , oauthAccessTokenEndpoint = "https://api.fitbit.com/oauth2/token" } stackexchangeKey :: OAuth2 stackexchangeKey = OAuth2 { oauthClientId = "xx" , oauthClientSecret = "xxxxxxxxxxxxxxx" , oauthCallback = Just "http://c.haskellcn.org/cb" , oauthOAuthorizeEndpoint = "https://stackexchange.com/oauth" , oauthAccessTokenEndpoint = "https://stackexchange.com/oauth/access_token" } hoauth2-0.5.4.0/example/Douban/0000755000000000000000000000000012730030223014251 5ustar0000000000000000hoauth2-0.5.4.0/example/Douban/test.hs0000644000000000000000000000176612730030223015576 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {- douban oauth2: http://developers.douban.com/wiki/?title=oauth2 /v2/movie/nowplaying -} module Main where import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.Text as T import qualified Data.Text.Encoding as T import Network.HTTP.Conduit import Network.OAuth.OAuth2 import Keys main :: IO () main = do print $ authorizationUrl doubanKey putStrLn "visit the url and paste code here: " code <- getLine mgr <- newManager tlsManagerSettings token <- fetchAccessToken mgr doubanKey (sToBS code) print token case token of Right r -> do -- TODO: display Chinese character. (Text UTF-8 encodeing does not work, why?) uid <- authGetBS mgr r "https://api.douban.com/v2/user/~me" print uid Left l -> BSL.putStrLn l sToBS :: String -> BS.ByteString sToBS = T.encodeUtf8 . T.pack hoauth2-0.5.4.0/example/Facebook/0000755000000000000000000000000012730030223014552 5ustar0000000000000000hoauth2-0.5.4.0/example/Facebook/test.hs0000644000000000000000000000403212730030223016064 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {- Facebook example -} module Main where import Keys (facebookKey) import Network.OAuth.OAuth2 import Data.Aeson (FromJSON) import Data.Aeson.TH (defaultOptions, deriveJSON) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BL import Data.Text (Text) import Network.HTTP.Conduit import Prelude hiding (id) -------------------------------------------------- data User = User { id :: Text , name :: Text , email :: Text } deriving (Show) $(deriveJSON defaultOptions ''User) -------------------------------------------------- main :: IO () main = do print $ authorizationUrl facebookKey `appendQueryParam` facebookScope putStrLn "visit the url and paste code here: " code <- fmap BS.pack getLine mgr <- newManager tlsManagerSettings let (url, body) = accessTokenUrl facebookKey code resp <- doJSONPostRequest mgr facebookKey url (body ++ [("state", "test")]) case (resp :: OAuth2Result AccessToken) of Right token -> do print token --userinfo mgr token >>= print userinfo' mgr token >>= print Left l -> print l -------------------------------------------------- -- FaceBook API -- | Gain read-only access to the user's id, name and email address. facebookScope :: QueryParams facebookScope = [("scope", "user_about_me,email")] -- | Fetch user id and email. userinfo :: Manager -> AccessToken -> IO (OAuth2Result BL.ByteString) userinfo mgr token = authGetBS mgr token "https://graph.facebook.com/me?fields=id,name,email" userinfo' :: FromJSON User => Manager -> AccessToken -> IO (OAuth2Result User) userinfo' mgr token = authGetJSON mgr token "https://graph.facebook.com/me?fields=id,name,email" hoauth2-0.5.4.0/example/Fitbit/0000755000000000000000000000000012730030223014262 5ustar0000000000000000hoauth2-0.5.4.0/example/Fitbit/test.hs0000644000000000000000000000657112730030223015606 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Main where import Control.Applicative import Control.Monad (mzero) import Data.Aeson import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Char (chr) import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T import Network.HTTP.Conduit hiding (Request, queryString) import Network.HTTP.Types (Query, status200) import Network.Wai import Network.Wai.Handler.Warp (run) import Keys (fitbitKey) import Network.OAuth.OAuth2 ------------------------------------------------------------------------------ data FitbitUser = FitbitUser { userId :: Text , userName :: Text , userAge :: Int } deriving (Show, Eq) instance FromJSON FitbitUser where parseJSON (Object o) = FitbitUser <$> ((o .: "user") >>= (.: "encodedId")) <*> ((o .: "user") >>= (.: "fullName")) <*> ((o .: "user") >>= (.: "age")) parseJSON _ = mzero instance ToJSON FitbitUser where toJSON (FitbitUser fid name age) = object [ "id" .= fid , "name" .= name , "age" .= age ] ------------------------------------------------------------------------------ main :: IO () main = do print $ authorizationUrl fitbitKey `appendQueryParam` [("state", state), ("scope", "profile")] putStrLn "visit the url to continue" run 9988 application state :: B.ByteString state = "testFitbitApi" application :: Application application request respond = do response <- handleRequest requestPath request respond $ responseLBS status200 [("Content-Type", "text/plain")] response where requestPath = T.intercalate "/" $ pathInfo request handleRequest :: Text -> Request -> IO BL.ByteString handleRequest "favicon.ico" _ = return "" handleRequest _ request = do mgr <- newManager tlsManagerSettings token <- getApiToken mgr $ getApiCode request print token user <- getApiUser mgr token print user return $ encode user getApiCode :: Request -> B.ByteString getApiCode request = case M.lookup "code" queryMap of Just code -> code Nothing -> error "request doesn't include code" where queryMap = convertQueryToMap $ queryString request getApiToken :: Manager -> B.ByteString -> IO (AccessToken) getApiToken mgr code = do result <- doJSONPostRequest mgr fitbitKey url $ body ++ [("state", state)] case result of Right token -> return token Left e -> error $ lazyBSToString e where (url, body) = accessTokenUrl fitbitKey code getApiUser :: Manager -> AccessToken -> IO (FitbitUser) getApiUser mgr token = do result <- authGetJSON mgr token "https://api.fitbit.com/1/user/-/profile.json" case result of Right user -> return user Left e -> error $ lazyBSToString e convertQueryToMap :: Query -> M.Map B.ByteString B.ByteString convertQueryToMap query = M.fromList $ map normalize query where normalize (k, Just v) = (k, v) normalize (k, Nothing) = (k, B.empty) lazyBSToString :: BL.ByteString -> String lazyBSToString s = map (chr . fromIntegral) (BL.unpack s) hoauth2-0.5.4.0/example/Github/0000755000000000000000000000000012730030223014263 5ustar0000000000000000hoauth2-0.5.4.0/example/Github/test.hs0000644000000000000000000000314612730030223015602 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- | Github API: http://developer.github.com/v3/oauth/ module Main where import Control.Applicative import Control.Monad (mzero) import Data.Aeson import qualified Data.ByteString as BS import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Network.HTTP.Conduit import Network.OAuth.OAuth2 import Keys main :: IO () main = do let state = "testGithubApi" print $ authorizationUrl githubKey `appendQueryParam` [("state", state)] putStrLn "visit the url and paste code here: " code <- getLine mgr <- newManager tlsManagerSettings let (url, body) = accessTokenUrl githubKey (sToBS code) token <- doJSONPostRequest mgr githubKey url (body ++ [("state", state)]) print (token :: OAuth2Result AccessToken) case token of Right at -> userInfo mgr at >>= print Left _ -> putStrLn "no access token found yet" -- | Test API: user -- userInfo :: Manager -> AccessToken -> IO (OAuth2Result GithubUser) userInfo mgr token = authGetJSON mgr token "https://api.github.com/user" data GithubUser = GithubUser { gid :: Integer , gname :: Text } deriving (Show, Eq) instance FromJSON GithubUser where parseJSON (Object o) = GithubUser <$> o .: "id" <*> o .: "name" parseJSON _ = mzero sToBS :: String -> BS.ByteString sToBS = T.encodeUtf8 . T.pack hoauth2-0.5.4.0/example/Google/0000755000000000000000000000000012730030223014255 5ustar0000000000000000hoauth2-0.5.4.0/example/Google/test.hs0000644000000000000000000001174412730030223015577 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {- This is basically very manual test. Check following link for details. Google web oauth: https://developers.google.com/accounts/docs/OAuth2WebServer Google OAuth 2.0 playround: https://developers.google.com/oauthplayground/ -} module Main where import Keys (googleKey) import Network.OAuth.OAuth2 import Control.Monad (liftM) import Data.Aeson (FromJSON) import Data.Aeson.TH (defaultOptions, deriveJSON) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Internal as BL import Data.Text (Text) import Network.HTTP.Conduit import Prelude hiding (id) import System.Environment (getArgs) -------------------------------------------------- data Token = Token { issued_to :: Text , audience :: Text , user_id :: Maybe Text , scope :: Text , expires_in :: Integer , access_type :: Text } deriving (Show) $(deriveJSON defaultOptions ''Token) data User = User { id :: Text , name :: Text , given_name :: Text , family_name :: Text , link :: Text , picture :: Text , gender :: Text , locale :: Text } deriving (Show) $(deriveJSON defaultOptions ''User) -------------------------------------------------- main :: IO () main = do xs <- getArgs mgr <- newManager tlsManagerSettings case xs of ["offline"] -> offlineCase mgr _ -> normalCase mgr offlineCase :: Manager -> IO () offlineCase mgr = do BS.putStrLn $ authorizationUrl googleKey `appendQueryParam` (googleScopeEmail ++ googleAccessOffline) putStrLn "visit the url and paste code here: " code <- fmap BS.pack getLine (Right token) <- fetchAccessToken mgr googleKey code f token -- -- 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 -- case refreshToken token of Nothing -> putStrLn "Failed to fetch refresh token" Just tk -> do (Right token') <- fetchRefreshToken mgr googleKey tk f token' --validateToken accessToken >>= print --(validateToken' accessToken :: IO (OAuth2Result Token)) >>= print where f token = do print token validateToken mgr token >>= print (validateToken' mgr token :: IO (OAuth2Result Token)) >>= print normalCase :: Manager -> IO () normalCase mgr = do BS.putStrLn $ authorizationUrl googleKey `appendQueryParam` googleScopeUserInfo putStrLn "visit the url and paste code here: " code <- fmap BS.pack getLine (Right token) <- fetchAccessToken mgr googleKey code putStr "AccessToken: " >> print token -- get response in ByteString validateToken mgr token >>= print -- get response in JSON (validateToken' mgr token :: IO (OAuth2Result Token)) >>= print -- get response in ByteString userinfo mgr token >>= print -- get response in JSON (userinfo' mgr token :: IO (OAuth2Result User)) >>= print -------------------------------------------------- -- Google API -- | This is special for google Gain read-only access to the user's email address. googleScopeEmail :: QueryParams googleScopeEmail = [("scope", "https://www.googleapis.com/auth/userinfo.email")] -- | Gain read-only access to basic profile information, including a googleScopeUserInfo :: QueryParams googleScopeUserInfo = [("scope", "https://www.googleapis.com/auth/userinfo.profile")] -- | Access offline googleAccessOffline :: QueryParams googleAccessOffline = [("access_type", "offline") ,("approval_prompt", "force")] -- | Token Validation validateToken :: Manager -> AccessToken -> IO (OAuth2Result BL.ByteString) validateToken mgr token = authGetBS' mgr token url where url = "https://www.googleapis.com/oauth2/v1/tokeninfo" validateToken' :: FromJSON a => Manager -> AccessToken -> IO (OAuth2Result a) validateToken' mgr token = liftM parseResponseJSON $ validateToken mgr token -- | fetch user email. -- for more information, please check the playround site. -- userinfo :: Manager -> AccessToken -> IO (OAuth2Result BL.ByteString) userinfo mgr token = authGetBS mgr token "https://www.googleapis.com/oauth2/v2/userinfo" userinfo' :: FromJSON a => Manager -> AccessToken -> IO (OAuth2Result a) userinfo' mgr token = authGetJSON mgr token "https://www.googleapis.com/oauth2/v2/userinfo" hoauth2-0.5.4.0/example/StackExchange/0000755000000000000000000000000012730030223015551 5ustar0000000000000000hoauth2-0.5.4.0/example/StackExchange/test.hs0000644000000000000000000000606212730030223017070 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- | Github API: http://developer.github.com/v3/oauth/ module Main where import Control.Applicative import Control.Monad (mzero) import Data.Aeson import Data.Aeson.TH (defaultOptions, deriveJSON) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Network.HTTP.Conduit import Network.OAuth.OAuth2 import Keys data SiteInfo = SiteInfo { items :: [SiteItem] , has_more :: Bool , quota_max :: Integer , quota_remaining :: Integer } deriving (Show, Eq) data SiteItem = SiteItem { new_active_users :: Integer , total_users :: Integer , badges_per_minute :: Double , total_badges :: Integer , total_votes :: Integer , total_comments :: Integer , answers_per_minute :: Double , questions_per_minute :: Double , total_answers :: Integer , total_accepted :: Integer , total_unanswered :: Integer , total_questions :: Integer , api_revision :: Text } deriving (Show, Eq) $(deriveJSON defaultOptions ''SiteInfo) $(deriveJSON defaultOptions ''SiteItem) main :: IO () main = do print $ authorizationUrl stackexchangeKey putStrLn "visit the url and paste code here: " code <- getLine mgr <- newManager tlsManagerSettings let (url, body) = accessTokenUrl stackexchangeKey (sToBS code) token <- doSimplePostRequest mgr stackexchangeKey url (body) print (token :: OAuth2Result BSL.ByteString) case token of Right at -> siteInfo mgr (getAccessToken at) >>= print Left _ -> putStrLn "no access token found yet" -- stackexchange access token api does not respond json but an string -- https://api.stackexchange.com/docs/authentication getAccessToken :: BSL.ByteString -> AccessToken getAccessToken str = let xs = BSL.split '&' str ys = BSL.split '=' (xs !! 0) in AccessToken { accessToken = BSL.toStrict (ys !! 1) , refreshToken = Nothing , expiresIn = Nothing , tokenType = Nothing } -- | Test API: info siteInfo :: Manager -> AccessToken -> IO (OAuth2Result SiteInfo) siteInfo mgr token = authGetJSON mgr token "https://api.stackexchange.com/2.2/info?site=stackoverflow" sToBS :: String -> BS.ByteString sToBS = T.encodeUtf8 . T.pack hoauth2-0.5.4.0/example/Weibo/0000755000000000000000000000000012730030223014106 5ustar0000000000000000hoauth2-0.5.4.0/example/Weibo/test.hs0000644000000000000000000000274012730030223015424 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# 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. check for integration testing at: https://github.com/HaskellCNOrg/snaplet-oauth/tree/master/test -} module Main where import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.Text as T import qualified Data.Text.Encoding as T import Network.HTTP.Conduit import Network.OAuth.OAuth2 import Keys main :: IO () main = do print $ authorizationUrl weiboKey putStrLn "visit the url and paste code here: " code <- getLine mgr <- newManager tlsManagerSettings token <- fetchAccessToken mgr weiboKey (sToBS code) print token case token of Right r -> do uid <- authGetBS' mgr r "https://api.weibo.com/2/account/get_uid.json" print uid Left l -> BSL.putStrLn l sToBS :: String -> BS.ByteString sToBS = T.encodeUtf8 . T.pack hoauth2-0.5.4.0/src/0000755000000000000000000000000012730030223012175 5ustar0000000000000000hoauth2-0.5.4.0/src/Network/0000755000000000000000000000000012730030223013626 5ustar0000000000000000hoauth2-0.5.4.0/src/Network/OAuth/0000755000000000000000000000000012730030223014646 5ustar0000000000000000hoauth2-0.5.4.0/src/Network/OAuth/OAuth2.hs0000644000000000000000000000124112730030223016302 0ustar0000000000000000------------------------------------------------------------ -- | -- Module : Network.OAuth.OAuth2 -- Description : OAuth2 client -- Copyright : (c) 2012 Haisheng Wu -- License : BSD-style (see the file LICENSE) -- Maintainer : Haisheng Wu -- Stability : alpha -- Portability : portable -- -- A lightweight oauth2 haskell binding. ------------------------------------------------------------ module Network.OAuth.OAuth2 (module Network.OAuth.OAuth2.HttpClient, module Network.OAuth.OAuth2.Internal ) where import Network.OAuth.OAuth2.HttpClient import Network.OAuth.OAuth2.Internal hoauth2-0.5.4.0/src/Network/OAuth/OAuth2/0000755000000000000000000000000012730030223015750 5ustar0000000000000000hoauth2-0.5.4.0/src/Network/OAuth/OAuth2/HttpClient.hs0000644000000000000000000001766312730030223020377 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- | A simple http client to request OAuth2 tokens and several utils. module Network.OAuth.OAuth2.HttpClient ( -- * Token management fetchAccessToken, fetchRefreshToken, doJSONPostRequest, doSimplePostRequest, -- * AUTH requests authGetJSON, authGetBS, authGetBS', authPostJSON, authPostBS, authRequest, -- * Utilities handleResponse, parseResponseJSON, updateRequestHeaders, setMethod ) where import Control.Monad (liftM) import Data.Aeson import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Maybe import Network.HTTP.Conduit hiding (withManager) import qualified Network.HTTP.Types as HT import Network.OAuth.OAuth2.Internal -------------------------------------------------- -- * Token management -------------------------------------------------- -- | Request (via POST method) "Access Token". fetchAccessToken :: Manager -- ^ HTTP connection manager -> OAuth2 -- ^ OAuth Data -> BS.ByteString -- ^ Authentication code gained after authorization -> IO (OAuth2Result AccessToken) -- ^ Access Token fetchAccessToken manager oa code = doJSONPostRequest manager oa uri body where (uri, body) = accessTokenUrl oa code -- | Request the "Refresh Token". fetchRefreshToken :: Manager -- ^ HTTP connection manager. -> OAuth2 -- ^ OAuth context -> BS.ByteString -- ^ refresh token gained after authorization -> IO (OAuth2Result AccessToken) fetchRefreshToken manager oa rtoken = doJSONPostRequest manager oa uri body where (uri, body) = refreshAccessTokenUrl oa rtoken -- | Conduct post request and return response as JSON. doJSONPostRequest :: FromJSON a => Manager -- ^ HTTP connection manager. -> OAuth2 -- ^ OAuth options -> URI -- ^ The URL -> PostBody -- ^ request body -> IO (OAuth2Result a) -- ^ Response as ByteString doJSONPostRequest manager oa uri body = liftM parseResponseJSON (doSimplePostRequest manager oa uri body) -- | Conduct post request. doSimplePostRequest :: Manager -- ^ HTTP connection manager. -> OAuth2 -- ^ OAuth options -> URI -- ^ URL -> PostBody -- ^ Request body. -> IO (OAuth2Result BSL.ByteString) -- ^ Response as ByteString doSimplePostRequest manager oa url body = liftM handleResponse go where go = do req <- parseUrl $ BS.unpack url let addBasicAuth = applyBasicAuth (oauthClientId oa) (oauthClientSecret oa) req' = (addBasicAuth . updateRequestHeaders Nothing) req httpLbs (urlEncodedBody body req') manager -------------------------------------------------- -- * AUTH requests -------------------------------------------------- -- | Conduct GET request and return response as JSON. authGetJSON :: FromJSON a => Manager -- ^ HTTP connection manager. -> AccessToken -> URI -- ^ Full URL -> IO (OAuth2Result a) -- ^ Response as JSON authGetJSON manager t uri = liftM parseResponseJSON $ authGetBS manager t uri -- | Conduct GET request. authGetBS :: Manager -- ^ HTTP connection manager. -> AccessToken -> URI -- ^ URL -> IO (OAuth2Result BSL.ByteString) -- ^ Response as ByteString authGetBS manager token url = do req <- parseUrl $ BS.unpack url authRequest req upReq manager where upReq = updateRequestHeaders (Just token) . setMethod HT.GET -- | same to 'authGetBS' but set access token to query parameter rather than header authGetBS' :: Manager -- ^ HTTP connection manager. -> AccessToken -> URI -- ^ URL -> IO (OAuth2Result BSL.ByteString) -- ^ Response as ByteString authGetBS' manager token url = do req <- parseUrl $ BS.unpack $ url `appendAccessToken` token authRequest req upReq manager where upReq = updateRequestHeaders Nothing . setMethod HT.GET -- | Conduct POST request and return response as JSON. authPostJSON :: FromJSON a => Manager -- ^ HTTP connection manager. -> AccessToken -> URI -- ^ Full URL -> PostBody -> IO (OAuth2Result a) -- ^ Response as JSON authPostJSON manager t uri pb = liftM parseResponseJSON $ authPostBS manager t uri pb -- | Conduct POST request. authPostBS :: Manager -- ^ HTTP connection manager. -> AccessToken -> URI -- ^ URL -> PostBody -> IO (OAuth2Result BSL.ByteString) -- ^ Response as ByteString authPostBS manager token url pb = do req <- parseUrl $ BS.unpack url authRequest req upReq manager where upBody = urlEncodedBody (pb ++ accessTokenToParam token) upHeaders = updateRequestHeaders (Just token) . setMethod HT.POST upReq = upHeaders . upBody -- |Send an HTTP request including the Authorization header with the specified -- access token. -- authRequest :: Request -- ^ Request to perform -> (Request -> Request) -- ^ Modify request before sending -> Manager -- ^ HTTP connection manager. -> IO (OAuth2Result BSL.ByteString) authRequest req upReq manager = liftM handleResponse (httpLbs (upReq req) manager) -------------------------------------------------- -- * Utilities -------------------------------------------------- -- | Parses a @Response@ to to @OAuth2Result@ handleResponse :: Response BSL.ByteString -> OAuth2Result BSL.ByteString handleResponse rsp = if HT.statusIsSuccessful (responseStatus rsp) then Right $ responseBody rsp else Left $ BSL.append "hoauth2.HttpClient.parseResponseJSON/Gaining token failed: " (responseBody rsp) -- | Parses a @OAuth2Result BSL.ByteString@ into @FromJSON a => a@ parseResponseJSON :: FromJSON a => OAuth2Result BSL.ByteString -> OAuth2Result a parseResponseJSON (Left b) = Left b parseResponseJSON (Right b) = case decode b of Nothing -> Left ("hoauth2.HttpClient.parseResponseJSON/Could not decode JSON: " `BSL.append` b) Just x -> Right x -- | Set several header values: -- + userAgennt : `hoauth2` -- + accept : `application/json` -- + authorization : 'Bearer' `xxxxx` if 'AccessToken' provided. updateRequestHeaders :: Maybe AccessToken -> Request -> Request updateRequestHeaders t req = let extras = [ (HT.hUserAgent, "hoauth2") , (HT.hAccept, "application/json") ] bearer = [(HT.hAuthorization, "Bearer " `BS.append` accessToken (fromJust t)) | isJust t] headers = bearer ++ extras ++ requestHeaders req in req { requestHeaders = headers } -- | Set the HTTP method to use. setMethod :: HT.StdMethod -> Request -> Request setMethod m req = req { method = HT.renderStdMethod m } hoauth2-0.5.4.0/src/Network/OAuth/OAuth2/Internal.hs0000644000000000000000000001321612730030223020063 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK -ignore-exports #-} -- | A simple OAuth2 Haskell binding. (This is supposed to be -- independent of the http client used.) module Network.OAuth.OAuth2.Internal where import Control.Applicative ((<$>), (<*>)) import Control.Monad (mzero) import Data.Aeson import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.Maybe import Data.Text.Encoding import Network.HTTP.Types (renderSimpleQuery) -------------------------------------------------- -- * Data Types -------------------------------------------------- -- | Query Parameter Representation data OAuth2 = OAuth2 { oauthClientId :: BS.ByteString , oauthClientSecret :: BS.ByteString , oauthOAuthorizeEndpoint :: BS.ByteString , oauthAccessTokenEndpoint :: BS.ByteString , oauthCallback :: Maybe BS.ByteString } deriving (Show, Eq) -- | The gained Access Token. Use @Data.Aeson.decode@ to -- decode string to @AccessToken@. The @refreshToken@ is -- special in some cases, -- e.g. data AccessToken = AccessToken { accessToken :: BS.ByteString , refreshToken :: Maybe BS.ByteString , expiresIn :: Maybe Int , tokenType :: Maybe BS.ByteString , idToken :: Maybe BS.ByteString } deriving (Show) -- | Parse JSON data into 'AccessToken' instance FromJSON AccessToken where parseJSON (Object o) = AccessToken <$> at <*> rt <*> ei <*> tt <*> id_ where at = fmap encodeUtf8 $ o .: "access_token" rt = fmap (fmap encodeUtf8) $ o .:? "refresh_token" ei = o .:? "expires_in" tt = fmap (fmap encodeUtf8) $ o .:? "token_type" id_ = fmap (fmap encodeUtf8) $ o .:? "id_token" parseJSON _ = mzero -------------------------------------------------- -- * Types Synonym -------------------------------------------------- -- | Is either 'Left' containing an error or 'Right' containg a result type OAuth2Result a = Either BSL.ByteString a -- | type synonym of query parameters type QueryParams = [(BS.ByteString, BS.ByteString)] -- | type synonym of post body content type PostBody = [(BS.ByteString, BS.ByteString)] -- | type synonym of a URI type URI = BS.ByteString -------------------------------------------------- -- * URLs -------------------------------------------------- -- | 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) , ("response_type", Just "code") , ("redirect_uri", oauthCallback oa)] -- | Prepare the URL and the request body query for fetching an access token. accessTokenUrl :: OAuth2 -> BS.ByteString -- ^ access code gained via authorization URL -> (URI, PostBody) -- ^ access token request URL plus the request body. accessTokenUrl oa code = accessTokenUrl' oa code (Just "authorization_code") -- | Prepare the URL and the request body query for fetching an access token, with -- optional grant type. accessTokenUrl' :: OAuth2 -> BS.ByteString -- ^ access code gained via authorization URL -> Maybe BS.ByteString -- ^ Grant Type -> (URI, PostBody) -- ^ access token request URL plus the request body. accessTokenUrl' oa code gt = (uri, body) where uri = oauthAccessTokenEndpoint oa body = transform' [ ("client_id", Just $ oauthClientId oa) , ("client_secret", Just $ oauthClientSecret oa) , ("code", Just code) , ("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) ] -------------------------------------------------- -- * UTILs -------------------------------------------------- -- | Append query parameters using `"?"` or `"&"`. appendQueryParam :: URI -> QueryParams -> URI appendQueryParam uri q = if "?" `BS.isInfixOf` uri then uri `BS.append` "&" `BS.append` renderSimpleQuery False q else uri `BS.append` renderSimpleQuery True q -- | For `GET` method API. appendAccessToken :: URI -- ^ Base URI -> AccessToken -- ^ Authorized Access Token -> URI -- ^ Combined Result appendAccessToken uri t = appendQueryParam uri (accessTokenToParam t) -- | Create 'QueryParams' with given access token value. accessTokenToParam :: AccessToken -> QueryParams accessTokenToParam at = [("access_token", accessToken at)] -- | Lift value in the 'Maybe' and abandon 'Nothing'. transform' :: [(a, Maybe b)] -> [(a, b)] transform' = map (\(a, Just b) -> (a, b)) . filter (isJust . snd)