hoauth2-0.5.0/0000755000000000000000000000000012642354043011257 5ustar0000000000000000hoauth2-0.5.0/hoauth2.cabal0000644000000000000000000001527412642354043013626 0ustar0000000000000000Name: hoauth2 -- https://wiki.haskell.org/Package_versioning_policy Version: 0.5.0 Synopsis: hoauth2 Description: Haskell OAuth2 authentication. . Tested following services . * google web oauth: . * github oauth: . * facebook . * fitbit . * weibo oauth2: . * 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: alpha tested-with: GHC <= 7.10.2 -- Extra files to be distributed with the package, such as examples or -- a README. Extra-source-files: README.md example/Google/test.hs example/Weibo/test.hs example/Github/test.hs example/Facebook/test.hs example/Keys.hs.sample example/run-7.6.sh example/run.sh 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.10 && < 0.11, 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.10 && < 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-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.10 && < 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-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.10 && < 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-fb 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.10 && < 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-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.10 && < 0.11, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, http-conduit >= 2.0 && < 2.2, http-types >= 0.9 && < 0.10, wai >= 3.0 && < 3.2, warp >= 3.0 && < 3.2, 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 hoauth2-0.5.0/LICENSE0000644000000000000000000000275712642354043012277 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.0/README.md0000644000000000000000000000057212642354043012542 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.0/Setup.hs0000644000000000000000000000005612642354043012714 0ustar0000000000000000import Distribution.Simple main = defaultMain hoauth2-0.5.0/example/0000755000000000000000000000000012642354043012712 5ustar0000000000000000hoauth2-0.5.0/example/Keys.hs.sample0000644000000000000000000000535312642354043015447 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://test.com/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" } hoauth2-0.5.0/example/run-7.6.sh0000644000000000000000000000007012642354043014357 0ustar0000000000000000runghc -package-db=../cabal-dev/packages-7.6.1.conf $* hoauth2-0.5.0/example/run.sh0000644000000000000000000000012212642354043014045 0ustar0000000000000000runghc -package-conf=../.cabal-sandbox/x86_64-linux-ghc-7.4.1-packages.conf.d $* hoauth2-0.5.0/example/Douban/0000755000000000000000000000000012642354043014122 5ustar0000000000000000hoauth2-0.5.0/example/Douban/test.hs0000644000000000000000000000166312642354043015443 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 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.0/example/Facebook/0000755000000000000000000000000012642354043014423 5ustar0000000000000000hoauth2-0.5.0/example/Facebook/test.hs0000644000000000000000000000403212642354043015735 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.0/example/Fitbit/0000755000000000000000000000000012642354043014133 5ustar0000000000000000hoauth2-0.5.0/example/Fitbit/test.hs0000644000000000000000000000652212642354043015453 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Main where import Control.Monad (mzero) import Data.Aeson import Data.Char (chr) import Data.Text (Text) import qualified Data.Text as T import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Map as M import Network.HTTP.Conduit hiding (queryString,Request) import Network.Wai import Network.HTTP.Types (status200,Query) import Network.Wai.Handler.Warp (run) import Network.OAuth.OAuth2 import Keys (fitbitKey) ------------------------------------------------------------------------------ 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.0/example/Github/0000755000000000000000000000000012642354043014134 5ustar0000000000000000hoauth2-0.5.0/example/Github/test.hs0000644000000000000000000000310112642354043015442 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- | Github API: http://developer.github.com/v3/oauth/ module Main where 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.0/example/Google/0000755000000000000000000000000012642354043014126 5ustar0000000000000000hoauth2-0.5.0/example/Google/test.hs0000644000000000000000000001174412642354043015450 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.0/example/Weibo/0000755000000000000000000000000012642354043013757 5ustar0000000000000000hoauth2-0.5.0/example/Weibo/test.hs0000644000000000000000000000274012642354043015275 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.0/src/0000755000000000000000000000000012642354043012046 5ustar0000000000000000hoauth2-0.5.0/src/Network/0000755000000000000000000000000012642354043013477 5ustar0000000000000000hoauth2-0.5.0/src/Network/OAuth/0000755000000000000000000000000012642354043014517 5ustar0000000000000000hoauth2-0.5.0/src/Network/OAuth/OAuth2.hs0000644000000000000000000000036012642354043016154 0ustar0000000000000000module 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.0/src/Network/OAuth/OAuth2/0000755000000000000000000000000012642354043015621 5ustar0000000000000000hoauth2-0.5.0/src/Network/OAuth/OAuth2/HttpClient.hs0000644000000000000000000001762212642354043020243 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- | A simple http client to request OAuth2 tokens and several utils. module Network.OAuth.OAuth2.HttpClient 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 -------------------------------------------------- -- * Retrieve access token -------------------------------------------------- -- | 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 -- |Sends a 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 (authRequest' req upReq manager) authRequest' :: Request -- ^ Request to perform -> (Request -> Request) -- ^ Modify request before sending -> Manager -- ^ HTTP connection manager. -> IO (Response BSL.ByteString) authRequest' req upReq = httpLbs (upReq req) -------------------------------------------------- -- * 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 "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 ("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 } -- | Sets the HTTP method to use -- setMethod :: HT.StdMethod -> Request -> Request setMethod m req = req { method = HT.renderStdMethod m } hoauth2-0.5.0/src/Network/OAuth/OAuth2/Internal.hs0000644000000000000000000001324412642354043017735 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK -ignore-exports #-} -- | A simple OAuth2 Haskell binding. -- (This is supposed to be independent with http client.) module Network.OAuth.OAuth2.Internal where 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 @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 , expiresIn :: Maybe Int , tokenType :: Maybe BS.ByteString } deriving (Show) -- | Parse JSON data into {AccessToken} -- instance FromJSON AccessToken where parseJSON (Object o) = AccessToken <$> at <*> rt <*> ei <*> tt 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" 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 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. accessTokenUrl oa code = accessTokenUrl' oa code (Just "authorization_code") 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 with '?' 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 -- | Append query parameters with '&'. -- appendQueryParam' :: URI -> QueryParams -> URI -- appendQueryParam' uri q = uri `BS.append` "&" `BS.append` renderSimpleQuery False 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 :: BS.ByteString -> QueryParams --accessTokenToParam token = [("access_token", token)] accessTokenToParam :: AccessToken -> QueryParams accessTokenToParam (AccessToken token _ _ _) = [("access_token", token)] -- | lift value in the Maybe and abonda Nothing transform' :: [(a, Maybe b)] -> [(a, b)] transform' = map (\(a, Just b) -> (a, b)) . filter (isJust . snd)