diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/example/Google/test.hs b/example/Google/test.hs new file mode 100644 --- /dev/null +++ b/example/Google/test.hs @@ -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)) diff --git a/example/Weibo/test.hs b/example/Weibo/test.hs new file mode 100644 --- /dev/null +++ b/example/Weibo/test.hs @@ -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 diff --git a/hoauth2.cabal b/hoauth2.cabal --- a/hoauth2.cabal +++ b/hoauth2.cabal @@ -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 diff --git a/src/Network/OAuth2/HTTP/HttpClient.hs b/src/Network/OAuth2/HTTP/HttpClient.hs --- a/src/Network/OAuth2/HTTP/HttpClient.hs +++ b/src/Network/OAuth2/HTTP/HttpClient.hs @@ -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 diff --git a/src/Network/OAuth2/OAuth2.hs b/src/Network/OAuth2/OAuth2.hs --- a/src/Network/OAuth2/OAuth2.hs +++ b/src/Network/OAuth2/OAuth2.hs @@ -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) diff --git a/test/Google/test.hs b/test/Google/test.hs deleted file mode 100644 --- a/test/Google/test.hs +++ /dev/null @@ -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)) diff --git a/test/Weibo/test.hs b/test/Weibo/test.hs deleted file mode 100644 --- a/test/Weibo/test.hs +++ /dev/null @@ -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 -