diff --git a/example/Facebook/test.hs b/example/Facebook/test.hs new file mode 100644 --- /dev/null +++ b/example/Facebook/test.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +{- Facebook example -} + +module Main where + +import Keys (facebookKey) +import Network.OAuth.OAuth2 +import Network.OAuth.OAuth2.HttpClient + +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (mzero) +import Data.Aeson (FromJSON, Value (Object), + parseJSON, (.:), (.:?)) +import Data.Aeson.TH (deriveJSON) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Text (Text) +import Prelude hiding (id) +import qualified Prelude as P (id) +import System.Environment (getArgs) + +-------------------------------------------------- + +data User = User { id :: Text + , name :: Text + , email :: Text + } deriving (Show) + +$(deriveJSON P.id ''User) + +-------------------------------------------------- + +main :: IO () +main = do + print $ authorizationUrl facebookKey `appendQueryParam` facebookScope + putStrLn "visit the url and paste code here: " + code <- fmap BS.pack getLine + let (url, body) = accessTokenUrl facebookKey code + (Right token) <- doJSONPostRequest url (body ++ [("state", "test")]) + userinfo token >>= print + userinfo' token >>= print + +-------------------------------------------------- +-- 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 :: AccessToken -> IO (OAuth2Result BL.ByteString) +userinfo token = authGetJSON token "https://graph.facebook.com/me?fields=id,name,email&" + +userinfo' :: FromJSON User => AccessToken -> IO (OAuth2Result User) +userinfo' token = authGetJSON token "https://graph.facebook.com/me?fields=id,name,email" + diff --git a/example/Github/test.hs b/example/Github/test.hs --- a/example/Github/test.hs +++ b/example/Github/test.hs @@ -1,55 +1,51 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -- | Github API: http://developer.github.com/v3/oauth/ 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 Data.Text (Text) -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 Control.Applicative -import Control.Monad (mzero) +import Control.Monad (mzero) +import Control.Monad.Trans.Control (MonadBaseControl) import Data.Aeson +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.Conduit (MonadResource) +import Data.Maybe (fromJust) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Network.HTTP.Conduit +import qualified Network.HTTP.Types as HT -import Network.OAuth.OAuth2.HttpClient -import Network.OAuth.OAuth2 +import Network.OAuth.OAuth2 +import Network.OAuth.OAuth2.HttpClient -import Keys +import Keys main :: IO () main = do let state = "testGithubApi" - print $ (authorizationUrl githubKey) `appendQueryParam` [("state", state)] + print $ authorizationUrl githubKey `appendQueryParam` [("state", state)] putStrLn "visit the url and paste code here: " code <- getLine let (url, body) = accessTokenUrl githubKey (sToBS code) - token <- doJSONPostRequest (url, body ++ [("state", state)]) - print (token :: Maybe AccessToken) + token <- doJSONPostRequest url (body ++ [("state", state)]) + print (token :: OAuth2Result AccessToken) case token of - Just (AccessToken t _) -> userInfo (githubKey {oauthAccessToken = Just t}) >>= print - _ -> print "no access token found yet" + Right at -> userInfo at >>= print + Left l -> print "no access token found yet" -sToBS :: String -> BS.ByteString -sToBS = T.encodeUtf8 . T.pack -- | Test API: user -- -userInfo :: OAuth2 -> IO (Maybe GithubUser) -userInfo oauth = doJSONGetRequest (appendAccessToken - "https://api.github.com/user" - oauth) +userInfo :: AccessToken -> IO (OAuth2Result GithubUser) +userInfo token = authGetJSON token "https://api.github.com/user" -data GithubUser = GithubUser { gid :: Integer - , gname :: Text +data GithubUser = GithubUser { gid :: Integer + , gname :: Text } deriving (Show, Eq) instance FromJSON GithubUser where @@ -57,3 +53,6 @@ <$> o .: "id" <*> o .: "name" parseJSON _ = mzero + +sToBS :: String -> BS.ByteString +sToBS = T.encodeUtf8 . T.pack diff --git a/example/Google/test.hs b/example/Google/test.hs --- a/example/Google/test.hs +++ b/example/Google/test.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {- @@ -12,45 +13,49 @@ module Main where -import Network.OAuth.OAuth2.HttpClient -import Network.OAuth.OAuth2 -import Keys (googleKey) +import Keys (googleKey) +import Network.OAuth.OAuth2 +import Network.OAuth.OAuth2.HttpClient -import Control.Applicative ((<$>), (<*>)) -import Control.Monad (mzero) -import Data.Aeson (FromJSON, Value(Object), parseJSON, (.:), (.:?)) -import Data.Aeson.TH (deriveJSON) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Internal as BL -import Data.Text (Text) -import Prelude hiding (id) -import qualified Prelude as P (id) -import System.Environment (getArgs) +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (mzero) +import Data.Aeson (FromJSON, Value (Object), + parseJSON, (.:), (.:?)) +import Data.Aeson.TH (deriveJSON) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Internal as BL +import Data.Text (Text) +import Network.HTTP.Types (renderSimpleQuery) +import Prelude hiding (id) +import qualified Prelude as P (id) +import System.Environment (getArgs) -------------------------------------------------- -data Token = Token { issued_to :: Text - , audience :: Text - , user_id :: Maybe Text - , scope :: Text - , expires_in :: Integer - , email :: Maybe Text +data Token = Token { issued_to :: Text + , audience :: Text + , user_id :: Maybe Text + , scope :: Text + , expires_in :: Integer + , email :: Maybe Text , verified_email :: Maybe Bool - , access_type :: Text + , access_type :: Text } deriving (Show) -instance FromJSON Token where - parseJSON (Object o) = Token - <$> o .: "issued_to" - <*> o .: "audience" - <*> o .:? "user_id" - <*> o .: "scope" - <*> o .: "expires_in" - <*> o .:? "email" - <*> o .:? "verified_email" - <*> o .: "access_type" - parseJSON _ = mzero +-- ance FromJSON Token where +-- parseJSON (Object o) = Token +-- <$> o .: "issued_to" +-- <*> o .: "audience" +-- <*> o .:? "user_id" +-- <*> o .: "scope" +-- <*> o .: "expires_in" +-- <*> o .:? "email" +-- <*> o .:? "verified_email" +-- <*> o .: "access_type" +-- parseJSON _ = mzero +$(deriveJSON P.id ''Token) + data User = User { id :: Text , name :: Text , given_name :: Text @@ -75,36 +80,38 @@ offlineCase :: IO () offlineCase = do - print $ authorizationUrl googleKey `appendQueryParam'` googleScopeEmail `appendQueryParam'` googleAccessOffline + print $ authorizationUrl googleKey `appendQueryParam` (googleScopeEmail ++ googleAccessOffline) putStrLn "visit the url and paste code here: " code <- fmap BS.pack getLine - (Just (AccessToken accessToken refreshToken)) <- requestAccessToken googleKey code - print (accessToken, refreshToken) - validateToken accessToken >>= print - (validateToken' accessToken :: IO (Maybe Token)) >>= print + (Right token) <- fetchAccessToken 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 of + case refreshToken token of Nothing -> print "Failed to fetch refresh token" Just tk -> do - (Just (AccessToken accessToken refreshToken)) <- refreshAccessToken googleKey tk - print (accessToken, refreshToken) - validateToken accessToken >>= print - (validateToken' accessToken :: IO (Maybe Token)) >>= print + (Right token) <- fetchAccessToken googleKey tk + f token + --validateToken accessToken >>= print + --(validateToken' accessToken :: IO (OAuth2Result Token)) >>= print + where f token = do + print token + validateToken token >>= print + (validateToken' token :: IO (OAuth2Result Token)) >>= print normalCase :: IO () normalCase = do - print $ authorizationUrl googleKey `appendQueryParam'` googleScopeUserInfo + print $ authorizationUrl googleKey `appendQueryParam` googleScopeUserInfo putStrLn "visit the url and paste code here: " code <- fmap BS.pack getLine - (Just (AccessToken accessToken Nothing)) <- requestAccessToken googleKey code - putStr "AccessToken: " >> print accessToken - validateToken accessToken >>= print - (validateToken' accessToken :: IO (Maybe Token)) >>= print - userinfo accessToken >>= print - (userinfo' accessToken :: IO (Maybe User)) >>= print + (Right token) <- fetchAccessToken googleKey code + putStr "AccessToken: " >> print token + validateToken token >>= print + (validateToken' token :: IO (OAuth2Result Token)) >>= print + userinfo token >>= print + (userinfo' token :: IO (OAuth2Result User)) >>= print -------------------------------------------------- -- Google API @@ -123,18 +130,18 @@ ,("approval_prompt", "force")] -- | Token Validation -validateToken :: BS.ByteString -> IO BL.ByteString -validateToken accessToken = doSimpleGetRequest ("https://www.googleapis.com/oauth2/v1/tokeninfo" `appendQueryParam` (accessTokenToParam accessToken)) +validateToken :: AccessToken -> IO (OAuth2Result BL.ByteString) +validateToken token = authGetJSON token "https://www.googleapis.com/oauth2/v1/tokeninfo" -validateToken' :: FromJSON a => BS.ByteString -> IO (Maybe a) -validateToken' accessToken = doJSONGetRequest ("https://www.googleapis.com/oauth2/v1/tokeninfo" `appendQueryParam` (accessTokenToParam accessToken)) +validateToken' :: FromJSON a => AccessToken -> IO (OAuth2Result a) +validateToken' token = authGetJSON token "https://www.googleapis.com/oauth2/v1/tokeninfo" -- | fetch user email. -- for more information, please check the playround site. -- -userinfo :: BS.ByteString -> IO BL.ByteString -userinfo accessToken = doSimpleGetRequest ("https://www.googleapis.com/oauth2/v2/userinfo" `appendQueryParam` (accessTokenToParam accessToken)) +userinfo :: AccessToken -> IO (OAuth2Result BL.ByteString) +userinfo token = authGetJSON token "https://www.googleapis.com/oauth2/v2/userinfo" -userinfo' :: FromJSON a => BS.ByteString -> IO (Maybe a) -userinfo' accessToken = doJSONGetRequest ("https://www.googleapis.com/oauth2/v2/userinfo" `appendQueryParam` (accessTokenToParam accessToken)) +userinfo' :: FromJSON a => AccessToken -> IO (OAuth2Result a) +userinfo' token = authGetJSON token "https://www.googleapis.com/oauth2/v2/userinfo" diff --git a/example/Keys.hs.sample b/example/Keys.hs.sample --- a/example/Keys.hs.sample +++ b/example/Keys.hs.sample @@ -2,39 +2,39 @@ module Keys where -import Network.OAuth.OAuth2 +import Network.OAuth.OAuth2 weiboKey :: OAuth2 weiboKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx" , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxx" , oauthCallback = Just "http://127.0.0.1:9988/oauthCallback" - , oauthOAuthorizeEndpoint = "" - , oauthAccessTokenEndpoint = "" - , oauthAccessToken = Nothing + , oauthOAuthorizeEndpoint = "https://api.weibo.com/oauth2/authorize" + , oauthAccessTokenEndpoint = "https://api.weibo.com/oauth2/access_token" } +-- | http://developer.github.com/v3/oauth/ githubKeys :: OAuth2 githubKeys = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx" , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxx" , oauthCallback = Just "http://127.0.0.1:9988/oauthCallback" - , oauthOAuthorizeEndpoint = "http://developer.github.com/v3/oauth/" - , oauthAccessTokenEndpoint = "http://developer.github.com/v3/oauth/" - , oauthAccessToken = Nothing + , 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 "https://developers.google.com/oauthplayground" -                , oauthOAuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth" -                , oauthAccessTokenEndpoint = "https://accounts.google.com/o/oauth2/token" -                , oauthAccessToken = Nothing} + , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxx" + , oauthCallback = Just "http://127.0.0.1:9988/googleCallback" + , oauthOAuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth" + , oauthAccessTokenEndpoint = "https://accounts.google.com/o/oauth2/token" + } facebookKey :: OAuth2 facebookKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx" -                , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxx" -                 , oauthCallback = Just "https://developers.facebook.com/tools/debug" -                 , oauthOAuthorizeEndpoint = "https://www.facebook.com/dialog/oauth" -                 , oauthAccessTokenEndpoint = "https://graph.facebook.com/oauth/access_token" -                 , oauthAccessToken = Nothing} + , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxx" + , oauthCallback = Just "https://developers.facebook.com/tools/debug" + , oauthOAuthorizeEndpoint = "https://www.facebook.com/dialog/oauth" + , oauthAccessTokenEndpoint = "https://graph.facebook.com/oauth/access_token" + } diff --git a/example/Weibo/test.hs b/example/Weibo/test.hs --- a/example/Weibo/test.hs +++ b/example/Weibo/test.hs @@ -1,5 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} {- @@ -20,28 +20,33 @@ 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 Control.Monad.Trans.Control (MonadBaseControl) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.Conduit (MonadResource) +import Data.Maybe (fromJust) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Network.HTTP.Conduit +import qualified Network.HTTP.Types as HT -import Network.OAuth.OAuth2.HttpClient -import Network.OAuth.OAuth2 +import Network.OAuth.OAuth2 +import Network.OAuth.OAuth2.HttpClient -import Keys +import Keys main :: IO () main = do print $ authorizationUrl weiboKey putStrLn "visit the url and paste code here: " code <- getLine - token <- requestAccessToken weiboKey (sToBS code) + token <- fetchAccessToken weiboKey (sToBS code) print token + case token of + Right r -> do + uid <- authGetBS 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 diff --git a/example/run-7.4.sh b/example/run-7.4.sh deleted file mode 100644 --- a/example/run-7.4.sh +++ /dev/null @@ -1,2 +0,0 @@ -runghc -package-conf=../cabal-dev/packages-7.4.1.conf $* - diff --git a/example/run-7.6.sh b/example/run-7.6.sh new file mode 100644 --- /dev/null +++ b/example/run-7.6.sh @@ -0,0 +1,2 @@ +runghc -package-db=../cabal-dev/packages-7.6.1.conf $* + diff --git a/example/run.sh b/example/run.sh --- a/example/run.sh +++ b/example/run.sh @@ -1,2 +1,2 @@ -runghc -package-db=../cabal-dev/packages-7.6.1.conf $* +runghc -package-conf=../cabal-dev/packages-7.4.1.conf $* 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.3.0 +Version: 0.3.5 Synopsis: hoauth2 Description: @@ -11,6 +11,8 @@ * google web oauth: . * weibo oauth2: + . + * github oauth: Homepage: https://github.com/freizl/hoauth2 License: BSD3 @@ -21,7 +23,7 @@ Category: Network Build-type: Simple stability: alpha -tested-with: GHC <= 7.6.1 +tested-with: GHC <= 7.6.3 -- Extra files to be distributed with the package, such as examples or @@ -31,8 +33,9 @@ example/Google/test.hs example/Weibo/test.hs example/Github/test.hs + example/Facebook/test.hs example/Keys.hs.sample - example/run-7.4.sh + example/run-7.6.sh example/run.sh Cabal-version: >=1.8 @@ -46,6 +49,7 @@ hs-source-dirs: src Exposed-modules: Network.OAuth.OAuth2.HttpClient + Network.OAuth.OAuth2.Internal Network.OAuth.OAuth2 Build-Depends: diff --git a/src/Network/OAuth/OAuth2.hs b/src/Network/OAuth/OAuth2.hs --- a/src/Network/OAuth/OAuth2.hs +++ b/src/Network/OAuth/OAuth2.hs @@ -1,159 +1,8 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} - --- | A simple OAuth2 Haskell binding. --- (This is supposed to be independent with http client.) - -module Network.OAuth.OAuth2 where - -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 --- -data OAuth2 = OAuth2 { oauthClientId :: BS.ByteString - , oauthClientSecret :: BS.ByteString - , oauthOAuthorizeEndpoint :: BS.ByteString - , oauthAccessTokenEndpoint :: BS.ByteString - , oauthCallback :: Maybe BS.ByteString - , oauthAccessToken :: Maybe BS.ByteString - -- ^ TODO: why not Maybe AccessToken??? - } deriving (Show, Eq) - --- | Simple Exception representation. -data OAuthException = OAuthException String - 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) - --- | Parse JSON data into {AccessToken} --- -instance FromJSON AccessToken where - parseJSON (Object o) = AccessToken - <$> o .: "access_token" - <*> o .:? "refresh_token" - parseJSON _ = mzero - --------------------------------------------------- --- Types Synonym --------------------------------------------------- - --- | 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 - --- | Access Code that is required for fetching Access Token -type AccessCode = 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 - -> 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 - -> 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) - , ("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 = 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 - -> OAuth2 -- ^ OAuth has Authorized Access Token - -> 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) +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 diff --git a/src/Network/OAuth/OAuth2/HttpClient.hs b/src/Network/OAuth/OAuth2/HttpClient.hs --- a/src/Network/OAuth/OAuth2/HttpClient.hs +++ b/src/Network/OAuth/OAuth2/HttpClient.hs @@ -2,127 +2,150 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} --- | A simple http client for request OAuth2 tokens and several utils. +-- | A simple http client to request OAuth2 tokens and several utils. module Network.OAuth.OAuth2.HttpClient where -import Control.Exception -import Control.Monad (liftM) -import Control.Monad.Trans.Resource (ResourceT) +import Control.Monad (liftM) +import Control.Monad.Trans.Resource (ResourceT) import Data.Aeson -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 qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.Maybe import Network.HTTP.Conduit -import Network.HTTP.Types (renderSimpleQuery) -import qualified Network.HTTP.Types as HT +import qualified Network.HTTP.Types as HT -import Network.OAuth.OAuth2 +import Network.OAuth.OAuth2.Internal -------------------------------------------------- --- Fetch AccessToken; RefreshAccessToken +-- * Retrieve access token -------------------------------------------------- -- | 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 = doJSONPostRequest (accessTokenUrl oa code) +fetchAccessToken :: OAuth2 -- ^ OAuth Data + -> BS.ByteString -- ^ Authentication code gained after authorization + -> IO (OAuth2Result AccessToken) -- ^ Access Token +fetchAccessToken oa code = doJSONPostRequest uri body + where (uri, body) = accessTokenUrl oa code -- | Request the "Refresh Token". --- -refreshAccessToken :: OAuth2 - -> BS.ByteString -- ^ refresh token gained after authorization - -> IO (Maybe AccessToken) -refreshAccessToken oa rtoken = doJSONPostRequest (refreshAccessTokenUrl oa rtoken) +fetchRefreshToken :: OAuth2 -- ^ OAuth context + -> BS.ByteString -- ^ refresh token gained after authorization + -> IO (OAuth2Result AccessToken) +fetchRefreshToken oa rtoken = doJSONPostRequest uri body + where (uri, body) = refreshAccessTokenUrl oa rtoken --------------------------------------------------- --- conduit http request --------------------------------------------------- - --- | 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. --- 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 + => URI -- ^ The URL + -> PostBody -- ^ request body + -> IO (OAuth2Result a) -- ^ Response as ByteString +doJSONPostRequest uri body = liftM parseResponseJSON (doSimplePostRequest uri body) --- | Conduct GET request. --- -doSimpleGetRequest :: URI -- ^ URL - -> IO BSL.ByteString -- ^ Response as ByteString -doSimpleGetRequest url = doGetRequest (bsToS url) [] >>= handleResponse +-- | Conduct post request. +doSimplePostRequest :: URI -- ^ URL + -> PostBody -- ^ Request body. + -> IO (OAuth2Result BSL.ByteString) -- ^ Response as ByteString +doSimplePostRequest url body = liftM handleResponse go + where go = do + req <- parseUrl $ BS.unpack url + let req' = updateRequestHeaders Nothing req + withManager $ httpLbs (urlEncodedBody body req') +-------------------------------------------------- +-- * AUTH requests +-------------------------------------------------- + -- | Conduct GET request and return response as JSON. --- -doJSONGetRequest :: FromJSON a - => URI -- ^ Full URL - -> IO (Maybe a) -- ^ Response as ByteString -doJSONGetRequest url = doGetRequest (bsToS url) [] - >>= liftM decode . handleResponse +authGetJSON :: FromJSON a + => AccessToken + -> URI -- ^ Full URL + -> IO (OAuth2Result a) -- ^ Response as JSON +authGetJSON t uri = liftM parseResponseJSON $ authGetBS t uri +-- | Conduct GET request. +authGetBS :: AccessToken + -> URI -- ^ URL + -> IO (OAuth2Result BSL.ByteString) -- ^ Response as ByteString +authGetBS token url = liftM handleResponse go + where go = do + req <- parseUrl $ BS.unpack $ url `appendAccessToken` token + authenticatedRequest token HT.GET req --- | Conduct GET request with given URL by append extra parameters provided. --- -doGetRequest :: String -- ^ URL - -> [(BS.ByteString, BS.ByteString)] -- ^ Extra Parameters - -> IO (Response BSL.ByteString) -- ^ Response -doGetRequest url pm = doGetRequestWithReq url pm id +-- | Conduct POST request and return response as JSON. +authPostJSON :: FromJSON a + => AccessToken + -> URI -- ^ Full URL + -> PostBody + -> IO (OAuth2Result a) -- ^ Response as JSON +authPostJSON t uri pb = liftM parseResponseJSON $ authPostBS t uri pb --- | TODO: can not be `Request m -> Request m`, why?? --- -doGetRequestWithReq :: String -- ^ URL - -> [(BS.ByteString, BS.ByteString)] -- ^ Extra Parameters - -> (Request (ResourceT IO) -> Request (ResourceT IO)) -- ^ update Request - -> IO (Response BSL.ByteString) -- ^ Response -doGetRequestWithReq url pm f = do - req <- parseUrl $ url ++ bsToS (renderSimpleQuery True pm) - let req' = (updateRequestHeaders .f) req - withManager $ httpLbs req' +-- | Conduct POST request. +authPostBS :: AccessToken + -> URI -- ^ URL + -> PostBody + -> IO (OAuth2Result BSL.ByteString) -- ^ Response as ByteString +authPostBS token url pb = liftM handleResponse go + where body = pb ++ accessTokenToParam token + go = do + req <- parseUrl $ BS.unpack url + authenticatedRequest token HT.POST $ urlEncodedBody body req --- | Conduct POST request with given URL with post body data. +-- |Sends a HTTP request including the Authorization header with the specified +-- access token. -- -doPostRequst :: String -- ^ URL - -> [(BS.ByteString, BS.ByteString)] -- ^ Data to Post Body - -> IO (Response BSL.ByteString) -- ^ Response -doPostRequst url body = doPostRequstWithReq url body id - -doPostRequstWithReq :: String -- ^ URL - -> [(BS.ByteString, BS.ByteString)] -- ^ Data to Post Body - -> (Request (ResourceT IO) -> Request (ResourceT IO)) - -> IO (Response BSL.ByteString) -- ^ Response -doPostRequstWithReq url body f = do - req <- parseUrl url - let req' = (updateRequestHeaders . f) req - withManager $ httpLbs (urlEncodedBody body req') +authenticatedRequest :: AccessToken -- ^ Authentication token to use + -> HT.StdMethod -- ^ Method to use + -> Request (ResourceT IO) -- ^ Request to perform + -> IO (Response BSL.ByteString) +authenticatedRequest token m r = withManager + $ httpLbs + $ updateRequestHeaders (Just token) + $ setMethod m r +-- { checkStatus = \_ _ _ -> Nothing } +-- | Sets the HTTP method to use +-- +setMethod :: HT.StdMethod -> Request m -> Request m +setMethod m req = req { method = HT.renderStdMethod m } -------------------------------------------------- --- Utils +-- * Utilities -------------------------------------------------- -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) +-- | Parses a @Response@ to to @OAuth2Result@ +-- +handleResponse :: Response BSL.ByteString -> OAuth2Result BSL.ByteString +handleResponse rsp = + if HT.statusCode (responseStatus rsp) == 200 + then Right $ responseBody rsp + else Left $ BSL.append "Gaining token failed: " (responseBody rsp) -updateRequestHeaders :: Request m -> Request m -updateRequestHeaders req = req { requestHeaders = [ (HT.hAccept, "application/json") ] } +-- | 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 -bsToS :: BS.ByteString -> String -bsToS = T.unpack . T.decodeUtf8 +-- | set several header values. +-- + userAgennt : hoauth2 +-- + accept : application/json +-- + authorization : Bearer xxxxx if AccessToken provided. +-- +updateRequestHeaders :: Maybe AccessToken -> Request m -> Request m +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 } diff --git a/src/Network/OAuth/OAuth2/Internal.hs b/src/Network/OAuth/OAuth2/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth/OAuth2/Internal.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# 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.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 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 + } deriving (Show) + +-- | Parse JSON data into {AccessToken} +-- +instance FromJSON AccessToken where + parseJSON (Object o) = AccessToken + <$> o .: "access_token" + <*> o .:? "refresh_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 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) +