hoauth2 0.2.3 → 0.2.4
raw patch · 8 files changed
+291/−240 lines, 8 filesdep +randomdep +text
Dependencies added: random, text
Files
- README.md +1/−1
- example/Google/test.hs +76/−0
- example/Weibo/test.hs +53/−0
- hoauth2.cabal +6/−4
- src/Network/OAuth2/HTTP/HttpClient.hs +82/−50
- src/Network/OAuth2/OAuth2.hs +73/−57
- test/Google/test.hs +0/−79
- test/Weibo/test.hs +0/−49
README.md view
@@ -2,7 +2,7 @@ ## Introduction -A lightweight oauth2 haskell binding. See examples in `test/` folder.+A lightweight oauth2 haskell binding. See examples in `example/` folder. In additions, [snaplet-oauth] use this lib as well.
+ example/Google/test.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings #-}++{-++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 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 googleKeys `BS.append` "&" `BS.append` extraParams+ putStrLn "visit the url and paste code here: "+ code <- getLine+ (Just (AccessToken accessToken refreshToken)) <- requestAccessToken googleKeys (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+ --+ case refreshToken of+ Nothing -> print "Failed to fetch refresh token"+ Just tk -> refreshAccessToken googleKeys tk >>= print+ where extraParams = renderSimpleQuery False $ ("access_type", "offline"):googleScopeEmail+++normalCase :: IO ()+normalCase = do + print $ authorizationUrl googleKeys `BS.append` "&" `BS.append` extraParams+ putStrLn "visit the url and paste code here: "+ code <- getLine+ (Just (AccessToken accessToken Nothing)) <- requestAccessToken googleKeys (BS.pack code) + print accessToken+ res <- validateToken accessToken+ print res+ where extraParams = renderSimpleQuery False googleScopeEmail+++--------------------------------------------------+-- 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")]++-- | Gain read-only access to basic profile information, including a +googleScopeUserInfo = [("scope", "https://www.googleapis.com/auth/userinfo.profile")]++-- Token Validation+validateToken accessToken = doSimplePostRequest ("https://www.googleapis.com/oauth2/v1/tokeninfo", + (accessTokenToParam accessToken))
+ example/Weibo/test.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}++{-++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 Data.Maybe (fromJust)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Network.HTTP.Types as HT+import Network.HTTP.Conduit+import Control.Monad.Trans.Control (MonadBaseControl)+import Data.Conduit (MonadResource)++import Network.OAuth2.HTTP.HttpClient+import Network.OAuth2.OAuth2++import Weibo.Key++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+ putStrLn "visit the url and paste code here: "+ code <- getLine+ token <- requestAccessToken weibooauth (sToBS code)+ print token++sToBS :: String -> BS.ByteString+sToBS = T.encodeUtf8 . T.pack
hoauth2.cabal view
@@ -1,6 +1,6 @@ Name: hoauth2 -- (http://www.haskell.org/haskellwiki/Package_versioning_policy)-Version: 0.2.3+Version: 0.2.4 Synopsis: hoauth2 Description: @@ -28,8 +28,8 @@ -- a README. Extra-source-files: README.md- test/Google/test.hs- test/Weibo/test.hs+ example/Google/test.hs+ example/Weibo/test.hs Cabal-version: >=1.8 @@ -47,6 +47,7 @@ Build-Depends: aeson >= 0.6 && < 0.7, base >= 4 && < 5,+ text >= 0.11 && < 0.12, bytestring >= 0.9 && < 0.10, bytestring-show >= 0.3.5 && < 0.4, conduit >= 0.5 && < 0.6,@@ -54,7 +55,8 @@ http-types >= 0.7 && < 0.8, monad-control >= 0.3 && < 0.4, mtl >= 1 && < 2.2,- transformers >= 0.2 && < 0.4+ transformers >= 0.2 && < 0.4,+ random if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
src/Network/OAuth2/HTTP/HttpClient.hs view
@@ -1,89 +1,121 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} -- | A simple http client for request OAuth2 tokens and several utils. module Network.OAuth2.HTTP.HttpClient where -import Control.Applicative ((<$>))-import Control.Exception-import Data.Aeson-import Network.HTTP.Conduit-import qualified Data.ByteString.Char8 as BS+import Control.Applicative ((<$>))+import Control.Exception+import Control.Monad.Trans (liftIO)+import Control.Monad (liftM)+import Data.Aeson+import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as BSL-import qualified Network.HTTP.Types as HT-import Control.Monad.Trans (liftIO)-import Control.Monad.IO.Class (MonadIO)-import Network.HTTP.Types (renderSimpleQuery)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Network.HTTP.Conduit+import Network.HTTP.Types (renderSimpleQuery)+import qualified Network.HTTP.Types as HT -import Network.OAuth2.OAuth2+import Network.OAuth2.OAuth2 -------------------------------------------------- --- | Request (POST method) access token URL in order to get @AccessToken@.--- +-- | Request (via POST method) "Access Token".+-- -- FIXME: what if @requestAccessToken'@ return error? -- 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 oa code = decode <$> doSimplePostRequest (accessTokenUrl oa code) -- | Request the "Refresh Token".--- -refreshAccessToken :: OAuth2 - -> BS.ByteString -- ^ refresh token gained after authorization+--+refreshAccessToken :: OAuth2+ -> BS.ByteString -- ^ refresh token gained after authorization -> IO (Maybe AccessToken)-refreshAccessToken oa rtoken = decode <$> postRequest (refreshAccessTokenUrl oa rtoken)+refreshAccessToken oa rtoken = decode <$> doSimplePostRequest (refreshAccessTokenUrl oa rtoken) -------------------------------------------------- --- | Conduct post request in IO monad.+-- | Conduct post request.+--+doSimplePostRequest :: (URI, PostBody) -- ^ The URI and request body for fetching token.+ -> IO BSL.ByteString -- ^ Response as ByteString+doSimplePostRequest (uri, body) = doPostRequst (bsToS uri) body >>= handleResponse++-- | Conduct post request and return response as JSON. -- -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- retOrError rsp = if (HT.statusCode . responseStatus) rsp == 200- then return $ responseBody rsp- else throwIO . OAuthException $ "Gaining token failed: " ++ BSL.unpack (responseBody rsp)+doJSONPostRequest :: FromJSON a+ => (URI, PostBody) -- ^ The URI and request body for fetching token.+ -> IO (Maybe a) -- ^ Response as ByteString+doJSONPostRequest (uri, body) = doPostRequst (bsToS uri) body+ >>= liftM decode . handleResponse ------------------------------------------------------ od Request Utils--- TODO: Some duplication here.--- TODO: Control.Exception.try--- result <- liftIO $ Control.Exception.try $ runResourceT $ httpLbs request man--- - --- | Conduct GET request with given URL.--- -doSimpleGetRequest :: MonadIO m - => String -- ^ URL - -> m (Response BSL.ByteString) -- ^ Response+-- | Conduct GET request.+--+doSimpleGetRequest :: String -- ^ URL+ -> IO (Response BSL.ByteString) -- ^ Response as ByteString doSimpleGetRequest url = liftIO $ withManager $ \man -> do req' <- liftIO $ parseUrl url httpLbs req' man +-- | Conduct GET request and return response as JSON.+--+doJSONGetRequest :: FromJSON a+ => String -- ^ Full URL+ -> IO (Maybe a) -- ^ Response as ByteString+doJSONGetRequest url = doGetRequest url []+ >>= liftM decode . handleResponse++ --liftIO $ withManager $ \man -> do+ -- req' <- liftIO $ parseUrl url+ -- httpLbs req' man+++--------------------------------------------------+-- conduit http request+--------------------------------------------------+ -- | Conduct GET request with given URL by append extra parameters provided.--- -doGetRequest :: MonadIO m - => String -- ^ URL+--+doGetRequest :: String -- ^ URL -> [(BS.ByteString, BS.ByteString)] -- ^ Extra Parameters- -> m (Response BSL.ByteString) -- ^ Response+ -> IO (Response BSL.ByteString) -- ^ Response doGetRequest url pm = liftIO $ withManager $ \man -> do- req' <- liftIO $ parseUrl $ url ++ BS.unpack (renderSimpleQuery True pm)+ req' <- parseUrl $ url ++ bsToS (renderSimpleQuery True pm) httpLbs req' man + -- | 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 :: String -- ^ URL+ -> [(BS.ByteString, BS.ByteString)] -- ^ Data to Post Body+ -> IO (Response BSL.ByteString) -- ^ Response doPostRequst url body = liftIO $ withManager $ \man -> do- req' <- liftIO $ parseUrl url+ req' <- parseUrl url httpLbs (urlEncodedBody body req') man+++--------------------------------------------------++handleResponse :: Response BSL.ByteString -> IO BSL.ByteString+handleResponse rsp = if (HT.statusCode . responseStatus) rsp == 200+ then return (responseBody rsp)+ else throwIO . OAuthException $+ "Gaining token failed: " ++ BSL.unpack (responseBody rsp)+++bsToS :: BS.ByteString -> String+bsToS = T.unpack . T.decodeUtf8++ --else BSL.putStrLn "Error rsp" >> return "ERROR"++-- TODO: Control.Exception.try+-- result <- liftIO $ Control.Exception.try $ runResourceT $ httpLbs request man
src/Network/OAuth2/OAuth2.hs view
@@ -1,31 +1,32 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-} --- | A simple OAuth2 Haskell binding. +-- | A simple OAuth2 Haskell binding. -- (This is supposed to be independent with http client.) module Network.OAuth2.OAuth2 where -import Control.Applicative ((<$>), (<*>))-import Control.Exception-import Control.Monad (mzero)-import Data.Aeson-import Data.Maybe (fromJust)-import Data.Typeable (Typeable)-import Network.HTTP.Types (renderSimpleQuery)-import qualified Data.ByteString as BS+import Control.Applicative ((<$>), (<*>))+import Control.Exception+import Control.Monad (mzero)+import Data.Aeson+import qualified Data.ByteString as BS+import Data.Maybe (fromMaybe)+import Data.Typeable (Typeable)+import Network.HTTP.Types (renderSimpleQuery) +--------------------------------------------------+-- Data Types+--------------------------------------------------+ -- | Query Parameter Representation ----- TODO: 1. add a base endpoint URI.--- 2. May to be State Transform--- -data OAuth2 = OAuth2 { oauthClientId :: BS.ByteString- , oauthClientSecret :: BS.ByteString- , oauthOAuthorizeEndpoint :: BS.ByteString+data OAuth2 = OAuth2 { oauthClientId :: BS.ByteString+ , oauthClientSecret :: BS.ByteString+ , oauthOAuthorizeEndpoint :: BS.ByteString , oauthAccessTokenEndpoint :: BS.ByteString- , oauthCallback :: Maybe BS.ByteString- , oauthAccessToken :: Maybe BS.ByteString+ , oauthCallback :: Maybe BS.ByteString+ , oauthAccessToken :: Maybe BS.ByteString } deriving (Show, Eq) -- | Simple Exception representation.@@ -33,17 +34,19 @@ 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@.--- 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)+-- 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"@@ -51,9 +54,10 @@ parseJSON _ = mzero ----------------------------------------------------- Parameter Util - --- | type synonym of query parameters +-- Types Synonym+--------------------------------------------------++-- | type synonym of query parameters type QueryParams = [(BS.ByteString, BS.ByteString)] -- | type synonym of post body content@@ -62,21 +66,15 @@ -- | type synonym of a URI type URI = BS.ByteString --- | Append query parameters-appendQueryParam :: URI -> QueryParams -> URI-appendQueryParam uri q = uri `BS.append` renderSimpleQuery True q+-- | Access Code that is required for fetching Access Token+type AccessCode = BS.ByteString --- | lift value in the Maybe and abonda Nothing-transform' :: [(a, Maybe b)] -> [(a, b)]-transform' = foldr step' []- where step' :: (a, Maybe b) -> [(a, b)] -> [(a, b)]- step' (a, Just b) xs = (a, b):xs- step' _ xs = xs ----------------------------------------------------- oauth request urls+-- URLs+-------------------------------------------------- --- | Prepare the authorization URL. +-- | Prepare the authorization URL. -- Redirect to this URL asking for user interactive authentication. -- authorizationUrl :: OAuth2 -> URI@@ -87,18 +85,18 @@ -- | 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+ -> AccessCode -- ^ 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) +accessTokenUrl' :: OAuth2+ -> AccessCode -- ^ 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)@@ -108,7 +106,7 @@ -- | 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.@@ -120,20 +118,38 @@ , ("refresh_token", Just rtoken) ] ----------------------------------------------------- UTIL+-- UTILs+-------------------------------------------------- +-- | Append query parameters+appendQueryParam :: URI -> QueryParams -> URI+appendQueryParam uri q = uri `BS.append` renderSimpleQuery True q++ -- | For GET method API. appendAccessToken :: URI -- ^ Base URI -> OAuth2 -- ^ OAuth has Authorized Access Token- -> URI -- ^ Combined Result -appendAccessToken uri oauth = uri `BS.append` renderSimpleQuery True (accessTokenToParam $ token oauth)- where - -- Expect Access Token exists- token :: OAuth2 -> BS.ByteString- token = fromJust . oauthAccessToken+ -> URI -- ^ Combined Result+appendAccessToken uri oauth = appendQueryParam uri+ (token $ oauthAccessToken oauth)+ where token :: Maybe BS.ByteString -> QueryParams+ token = accessTokenToParam . fromMaybe "" -- | Create QueryParams with given access token value.--- +-- accessTokenToParam :: BS.ByteString -> QueryParams accessTokenToParam token = [("access_token", token)]+++-- | lift value in the Maybe and abonda Nothing+transform' :: [(a, Maybe b)] -> [(a, b)]+transform' = foldr step' []+ where step' :: (a, Maybe b) -> [(a, b)] -> [(a, b)]+ step' (a, Just b) xs = (a, b):xs+ step' _ xs = xs+++ -- Expect Access Token exists+ -- FIXME: append empty when Nothing+ --uri `BS.append` renderSimpleQuery True (accessTokenToParam $ token oauth)
− test/Google/test.hs
@@ -1,79 +0,0 @@-{-# 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- }------------------------------------------------------- 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")]---- | 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))
− test/Weibo/test.hs
@@ -1,49 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}--{---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.Char8 as BS-import Data.Maybe (fromJust)-import qualified Data.ByteString.Lazy.Char8 as BSL-import qualified Network.HTTP.Types as HT-import Network.HTTP.Conduit-import Control.Monad.Trans.Control (MonadBaseControl)-import Data.Conduit (MonadResource)--import Network.OAuth2.HTTP.HttpClient-import Network.OAuth2.OAuth2--import Weibo.Key--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- putStrLn "visit the url and paste code here: "- code <- getLine- token <- requestAccessToken weibooauth (BS.pack code)- print token-