diff --git a/example/Douban/test.hs b/example/Douban/test.hs --- a/example/Douban/test.hs +++ b/example/Douban/test.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {- @@ -11,29 +12,37 @@ module Main where -import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 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.Text.Lazy.Encoding as TL +import qualified Data.Text.Lazy.IO as TL import Network.HTTP.Conduit +import URI.ByteString +import URI.ByteString.QQ import Network.OAuth.OAuth2 -import Keys +import Keys (doubanKey) main :: IO () main = do - print $ authorizationUrl doubanKey + BS.putStrLn $ serializeURIRef' $ authorizationUrl doubanKey putStrLn "visit the url and paste code here: " - code <- getLine + code <- fmap (ExchangeToken . T.pack) getLine mgr <- newManager tlsManagerSettings - token <- fetchAccessToken mgr doubanKey (sToBS code) + let (url, body) = accessTokenUrl doubanKey code + let extraBody = [ ("client_id", T.encodeUtf8 $ oauthClientId doubanKey) + , ("client_secret", T.encodeUtf8 $ oauthClientSecret doubanKey) + ] + + token <- doJSONPostRequest mgr doubanKey url (extraBody ++ body) print token case token of Right r -> do - -- TODO: display Chinese character. (Text UTF-8 encodeing does not work, why?) - uid <- authGetBS mgr r "https://api.douban.com/v2/user/~me" - print uid + uid <- authGetBS mgr (accessToken r) [uri|https://api.douban.com/v2/user/~me|] + TL.putStrLn $ either TL.decodeUtf8 TL.decodeUtf8 uid Left l -> BSL.putStrLn l sToBS :: String -> BS.ByteString diff --git a/example/Dropbox/test.hs b/example/Dropbox/test.hs --- a/example/Dropbox/test.hs +++ b/example/Dropbox/test.hs @@ -1,17 +1,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} module Main where -import Control.Monad (liftM) -import Data.Aeson.TH (defaultOptions, deriveJSON) -import qualified Network.HTTP.Types as HT -import qualified Data.ByteString.Char8 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 qualified Data.Text as T import Network.HTTP.Conduit +import qualified Network.HTTP.Types as HT +import URI.ByteString import Network.OAuth.OAuth2 @@ -20,15 +17,15 @@ main :: IO () main = do - print $ authorizationUrl dropboxKey + BS.putStrLn $ serializeURIRef' $ authorizationUrl dropboxKey putStrLn "visit the url and paste code here: " - code <- fmap BS.pack getLine + code <- getLine mgr <- newManager tlsManagerSettings - token <- fetchAccessToken mgr dropboxKey code + token <- fetchAccessToken mgr dropboxKey (ExchangeToken (T.pack code)) print token case token of - Right at -> getSpaceUsage mgr at >>= print - Left _ -> putStrLn "no access token found yet" + Right at -> getSpaceUsage mgr (accessToken at) >>= print + Left _ -> putStrLn "no access token found yet" getSpaceUsage :: Manager -> AccessToken -> IO (OAuth2Result BSL.ByteString) getSpaceUsage mgr token = do diff --git a/example/Facebook/test.hs b/example/Facebook/test.hs --- a/example/Facebook/test.hs +++ b/example/Facebook/test.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {- Facebook example -} @@ -11,11 +12,14 @@ 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 qualified Data.Text as T +import qualified Data.Text.Encoding as T import Network.HTTP.Conduit import Prelude hiding (id) +import URI.ByteString +import URI.ByteString.QQ -------------------------------------------------- @@ -30,17 +34,21 @@ main :: IO () main = do - print $ authorizationUrl facebookKey `appendQueryParam` facebookScope + print $ serializeURIRef' $ appendQueryParams facebookScope $ authorizationUrl facebookKey putStrLn "visit the url and paste code here: " - code <- fmap BS.pack getLine + code <- getLine mgr <- newManager tlsManagerSettings - let (url, body) = accessTokenUrl facebookKey code - resp <- doJSONPostRequest mgr facebookKey url (body ++ [("state", "test")]) - case (resp :: OAuth2Result AccessToken) of + let (url, body) = accessTokenUrl facebookKey $ ExchangeToken $ T.pack code + let extraBody = [ ("state", "test") + , ("client_id", T.encodeUtf8 $ oauthClientId facebookKey) + , ("client_secret", T.encodeUtf8 $ oauthClientSecret facebookKey) + ] + resp <- doJSONPostRequest mgr facebookKey url (body ++ extraBody) + case (resp :: OAuth2Result OAuth2Token) of Right token -> do print token - --userinfo mgr token >>= print - userinfo' mgr token >>= print + userinfo mgr (accessToken token) >>= print + userinfo' mgr (accessToken token) >>= print Left l -> print l -------------------------------------------------- @@ -52,7 +60,7 @@ -- | 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 mgr token = authGetBS mgr token [uri|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" +userinfo' mgr token = authGetJSON mgr token [uri|https://graph.facebook.com/me?fields=id,name,email|] diff --git a/example/Fitbit/test.hs b/example/Fitbit/test.hs --- a/example/Fitbit/test.hs +++ b/example/Fitbit/test.hs @@ -1,9 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Main where -import Control.Applicative import Control.Monad (mzero) import Data.Aeson import qualified Data.ByteString as B @@ -12,10 +12,13 @@ import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Network.HTTP.Conduit hiding (Request, queryString) import Network.HTTP.Types (Query, status200) import Network.Wai import Network.Wai.Handler.Warp (run) +import URI.ByteString (serializeURIRef') +import URI.ByteString.QQ import Keys (fitbitKey) import Network.OAuth.OAuth2 @@ -47,7 +50,7 @@ main :: IO () main = do - print $ authorizationUrl fitbitKey `appendQueryParam` [("state", state), ("scope", "profile")] + print $ serializeURIRef' $ appendQueryParams [("state", state), ("scope", "profile")] $ authorizationUrl fitbitKey putStrLn "visit the url to continue" run 9988 application @@ -67,39 +70,39 @@ mgr <- newManager tlsManagerSettings token <- getApiToken mgr $ getApiCode request print token - user <- getApiUser mgr token + user <- getApiUser mgr (accessToken token) print user return $ encode user -getApiCode :: Request -> B.ByteString +getApiCode :: Request -> ExchangeToken getApiCode request = case M.lookup "code" queryMap of - Just code -> code - Nothing -> error "request doesn't include code" + Just code -> ExchangeToken $ T.decodeUtf8 code + Nothing -> error "request doesn't include code" where queryMap = convertQueryToMap $ queryString request -getApiToken :: Manager -> B.ByteString -> IO (AccessToken) +getApiToken :: Manager -> ExchangeToken -> IO OAuth2Token getApiToken mgr code = do result <- doJSONPostRequest mgr fitbitKey url $ body ++ [("state", state)] case result of Right token -> return token - Left e -> error $ lazyBSToString e + Left e -> error $ lazyBSToString e where (url, body) = accessTokenUrl fitbitKey code -getApiUser :: Manager -> AccessToken -> IO (FitbitUser) +getApiUser :: Manager -> AccessToken -> IO FitbitUser getApiUser mgr token = do - result <- authGetJSON mgr token "https://api.fitbit.com/1/user/-/profile.json" + result <- authGetJSON mgr token [uri|https://api.fitbit.com/1/user/-/profile.json|] case result of Right user -> return user - Left e -> error $ lazyBSToString e + 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, Just v) = (k, v) normalize (k, Nothing) = (k, B.empty) lazyBSToString :: BL.ByteString -> String diff --git a/example/Github/test.hs b/example/Github/test.hs --- a/example/Github/test.hs +++ b/example/Github/test.hs @@ -1,11 +1,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} -- | Github API: http://developer.github.com/v3/oauth/ module Main where -import Control.Applicative import Control.Monad (mzero) import Data.Aeson import qualified Data.ByteString as BS @@ -13,6 +13,8 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import Network.HTTP.Conduit +import URI.ByteString +import URI.ByteString.QQ import Network.OAuth.OAuth2 @@ -22,22 +24,22 @@ main :: IO () main = do let state = "testGithubApi" - print $ authorizationUrl githubKey `appendQueryParam` [("state", state)] + print $ serializeURIRef' $ appendQueryParams [("state", state)] $ authorizationUrl githubKey putStrLn "visit the url and paste code here: " code <- getLine mgr <- newManager tlsManagerSettings - let (url, body) = accessTokenUrl githubKey (sToBS code) + let (url, body) = accessTokenUrl githubKey $ ExchangeToken $ T.pack code token <- doJSONPostRequest mgr githubKey url (body ++ [("state", state)]) - print (token :: OAuth2Result AccessToken) + print (token :: OAuth2Result OAuth2Token) case token of - Right at -> userInfo mgr at >>= print - Left _ -> putStrLn "no access token found yet" + Right at -> userInfo mgr (accessToken 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" +userInfo mgr token = authGetJSON mgr token [uri|https://api.github.com/user|] data GithubUser = GithubUser { gid :: Integer , gname :: Text diff --git a/example/Google/test.hs b/example/Google/test.hs --- a/example/Google/test.hs +++ b/example/Google/test.hs @@ -1,5 +1,6 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} {- @@ -13,44 +14,55 @@ 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 Data.Aeson +import Data.Aeson.Types import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Internal as BL import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics import Network.HTTP.Conduit import Prelude hiding (id) import System.Environment (getArgs) +import URI.ByteString +import URI.ByteString.QQ +import Keys (googleKey) +import Network.OAuth.OAuth2 + -------------------------------------------------- -data Token = Token { issued_to :: Text - , audience :: Text - , user_id :: Maybe Text - , scope :: Text - , expires_in :: Integer - , access_type :: Text - } deriving (Show) +data Token = Token { issuedTo :: Text + , audience :: Text + , userId :: Maybe Text + , scope :: Text + , expiresIn :: Integer + , accessType :: Text + } deriving (Show, Generic) -$(deriveJSON defaultOptions ''Token) +data User = User { id :: Text + , name :: Text + , givenName :: Text + , familyName :: Text + , link :: Text + , picture :: Text + , gender :: Text + , locale :: Text + } deriving (Show, Generic) -data User = User { id :: Text - , name :: Text - , given_name :: Text - , family_name :: Text - , link :: Text - , picture :: Text - , gender :: Text - , locale :: Text - } deriving (Show) +instance FromJSON Token where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } -$(deriveJSON defaultOptions ''User) +instance ToJSON Token where + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelTo2 '_' } +instance FromJSON User where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } + +instance ToJSON User where + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelTo2 '_' } + -------------------------------------------------- main :: IO () @@ -59,15 +71,15 @@ mgr <- newManager tlsManagerSettings case xs of ["offline"] -> offlineCase mgr - _ -> normalCase mgr + _ -> normalCase mgr offlineCase :: Manager -> IO () offlineCase mgr = do - BS.putStrLn $ authorizationUrl googleKey `appendQueryParam` (googleScopeEmail ++ googleAccessOffline) + BS.putStrLn $ serializeURIRef' $ appendQueryParams (googleScopeEmail ++ googleAccessOffline) $ authorizationUrl googleKey putStrLn "visit the url and paste code here: " - code <- fmap BS.pack getLine - (Right token) <- fetchAccessToken mgr googleKey code - f token + code <- getLine + (Right token) <- fetchAccessToken mgr googleKey $ ExchangeToken $ T.pack code + f (accessToken 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 @@ -86,19 +98,19 @@ normalCase :: Manager -> IO () normalCase mgr = do - BS.putStrLn $ authorizationUrl googleKey `appendQueryParam` googleScopeUserInfo + BS.putStrLn $ serializeURIRef' $ appendQueryParams googleScopeUserInfo (authorizationUrl googleKey) putStrLn "visit the url and paste code here: " - code <- fmap BS.pack getLine + code <- fmap (ExchangeToken . T.pack) getLine (Right token) <- fetchAccessToken mgr googleKey code putStr "AccessToken: " >> print token -- get response in ByteString - validateToken mgr token >>= print + validateToken mgr (accessToken token) >>= print -- get response in JSON - (validateToken' mgr token :: IO (OAuth2Result Token)) >>= print + (validateToken' mgr (accessToken token):: IO (OAuth2Result Token)) >>= print -- get response in ByteString - userinfo mgr token >>= print + userinfo mgr (accessToken token) >>= print -- get response in JSON - (userinfo' mgr token :: IO (OAuth2Result User)) >>= print + (userinfo' mgr (accessToken token) :: IO (OAuth2Result User)) >>= print -------------------------------------------------- -- Google API @@ -122,13 +134,13 @@ -> IO (OAuth2Result BL.ByteString) validateToken mgr token = authGetBS' mgr token url - where url = "https://www.googleapis.com/oauth2/v1/tokeninfo" + where url = [uri|https://www.googleapis.com/oauth2/v1/tokeninfo|] validateToken' :: FromJSON a => Manager -> AccessToken -> IO (OAuth2Result a) -validateToken' mgr token = liftM parseResponseJSON $ validateToken mgr token +validateToken' mgr token = parseResponseJSON <$> validateToken mgr token -- | fetch user email. -- for more information, please check the playround site. @@ -136,10 +148,10 @@ userinfo :: Manager -> AccessToken -> IO (OAuth2Result BL.ByteString) -userinfo mgr token = authGetBS mgr token "https://www.googleapis.com/oauth2/v2/userinfo" +userinfo mgr token = authGetBS mgr token [uri|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" +userinfo' mgr token = authGetJSON mgr token [uri|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 @@ -1,70 +1,72 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Keys where import Network.OAuth.OAuth2 +import URI.ByteString.QQ 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" + , oauthCallback = Just [uri|http://127.0.0.1:9988/oauthCallback|] + , oauthOAuthorizeEndpoint = [uri|https://api.weibo.com/oauth2/authorize|] + , oauthAccessTokenEndpoint = [uri|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 [uri|http://127.0.0.1:9988/githubCallback|] + , oauthOAuthorizeEndpoint = [uri|https://github.com/login/oauth/authorize|] + , oauthAccessTokenEndpoint = [uri|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" + , oauthCallback = Just [uri|http://127.0.0.1:9988/googleCallback|] + , oauthOAuthorizeEndpoint = [uri|https://accounts.google.com/o/oauth2/auth|] + , oauthAccessTokenEndpoint = [uri|https://www.googleapis.com/oauth2/v3/token|] } facebookKey :: OAuth2 facebookKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx" , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxx" - , oauthCallback = Just "http://t.haskellcn.org/cb" - , oauthOAuthorizeEndpoint = "https://www.facebook.com/dialog/oauth" - , oauthAccessTokenEndpoint = "https://graph.facebook.com/v2.3/oauth/access_token" + , oauthCallback = Just [uri|http://t.haskellcn.org/cb|] + , oauthOAuthorizeEndpoint = [uri|https://www.facebook.com/dialog/oauth|] + , oauthAccessTokenEndpoint = [uri|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" + , oauthCallback = Just [uri|http://localhost:9999/oauthCallback|] + , oauthOAuthorizeEndpoint = [uri|https://www.douban.com/service/auth2/auth|] + , oauthAccessTokenEndpoint = [uri|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" + , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|] + , oauthOAuthorizeEndpoint = [uri|https://www.fitbit.com/oauth2/authorize|] + , oauthAccessTokenEndpoint = [uri|https://api.fitbit.com/oauth2/token|] } stackexchangeKey :: OAuth2 stackexchangeKey = OAuth2 { oauthClientId = "xx" , oauthClientSecret = "xxxxxxxxxxxxxxx" - , oauthCallback = Just "http://c.haskellcn.org/cb" - , oauthOAuthorizeEndpoint = "https://stackexchange.com/oauth" - , oauthAccessTokenEndpoint = "https://stackexchange.com/oauth/access_token" + , oauthCallback = Just [uri|http://c.haskellcn.org/cb|] + , oauthOAuthorizeEndpoint = [uri|https://stackexchange.com/oauth|] + , oauthAccessTokenEndpoint = [uri|https://stackexchange.com/oauth/access_token|] } dropboxKey :: OAuth2 dropboxKey = OAuth2 { oauthClientId = "xxx" , oauthClientSecret = "xxx" - , oauthCallback = Just "http://localhost:9988/oauth2/callback" - , oauthOAuthorizeEndpoint = "https://www.dropbox.com/1/oauth2/authorize" - , oauthAccessTokenEndpoint = "https://api.dropboxapi.com/oauth2/token" + , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|] + , oauthOAuthorizeEndpoint = [uri|https://www.dropbox.com/1/oauth2/authorize|] + , oauthAccessTokenEndpoint = [uri|https://api.dropboxapi.com/oauth2/token|] } diff --git a/example/StackExchange/test.hs b/example/StackExchange/test.hs --- a/example/StackExchange/test.hs +++ b/example/StackExchange/test.hs @@ -1,62 +1,85 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} --- | Github API: http://developer.github.com/v3/oauth/ +-- | https://api.stackexchange.com/docs/authentication module Main where -import Data.Aeson.TH (defaultOptions, deriveJSON) +import Data.Aeson +import Data.Aeson.Types import qualified Data.ByteString.Char8 as BS import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T +import GHC.Generics import Network.HTTP.Conduit +import URI.ByteString +import URI.ByteString.QQ +import Keys (stackexchangeKey) import Network.OAuth.OAuth2 -import Keys +data SiteInfo = SiteInfo { items :: [SiteItem] + , hasMore :: Bool + , quotaMax :: Integer + , quotaRemaining :: Integer + } deriving (Show, Eq, Generic) -data SiteInfo = SiteInfo { items :: [SiteItem] - , has_more :: Bool - , quota_max :: Integer - , quota_remaining :: Integer - } deriving (Show, Eq) +data SiteItem = SiteItem { newActiveUsers :: Integer + , totalUsers :: Integer + , badgesPerMinute :: Double + , totalBadges :: Integer + , totalVotes :: Integer + , totalComments :: Integer + , answersPerMinute :: Double + , questionsPerMinute :: Double + , totalAnswers :: Integer + , totalAccepted :: Integer + , totalUnanswered :: Integer + , totalQuestions :: Integer + , apiRevision :: Text + } deriving (Show, Eq, Generic) -data SiteItem = SiteItem { new_active_users :: Integer - , total_users :: Integer - , badges_per_minute :: Double - , total_badges :: Integer - , total_votes :: Integer - , total_comments :: Integer - , answers_per_minute :: Double - , questions_per_minute :: Double - , total_answers :: Integer - , total_accepted :: Integer - , total_unanswered :: Integer - , total_questions :: Integer - , api_revision :: Text - } deriving (Show, Eq) +instance FromJSON SiteInfo where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } -$(deriveJSON defaultOptions ''SiteInfo) -$(deriveJSON defaultOptions ''SiteItem) +instance ToJSON SiteInfo where + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelTo2 '_' } +instance FromJSON SiteItem where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } +instance ToJSON SiteItem where + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelTo2 '_' } + + main :: IO () main = do - print $ authorizationUrl stackexchangeKey + BS.putStrLn $ serializeURIRef' $ authorizationUrl stackexchangeKey putStrLn "visit the url and paste code here: " - code <- fmap BS.pack getLine + code <- fmap (ExchangeToken . T.pack) getLine mgr <- newManager tlsManagerSettings - token <- fetchAccessToken mgr stackexchangeKey code + let (url, body) = accessTokenUrl stackexchangeKey code + let extraBody = [ ("state", "test") + , ("client_id", T.encodeUtf8 $ oauthClientId stackexchangeKey) + , ("client_secret", T.encodeUtf8 $ oauthClientSecret stackexchangeKey) + ] + + -- NOTE: stackexchange doesn't really comply with standard, its access token response looks like + -- `access_token=...&expires=1234`. + -- the `doFlexiblePostRequest` is able to convert it to OAuth2Token type + -- but the `expires` is lost given standard naming is `expires_in` + token <- doFlexiblePostRequest mgr stackexchangeKey url (extraBody ++ body) print token case token of - Right at -> siteInfo mgr at >>= print - Left _ -> putStrLn "no access token found yet" + Right at -> siteInfo mgr (accessToken at) >>= print + Left _ -> putStrLn "no access token found yet" -- | Test API: info siteInfo :: Manager -> AccessToken -> IO (OAuth2Result SiteInfo) -siteInfo mgr token = authGetJSON mgr token "https://api.stackexchange.com/2.2/info?site=stackoverflow" +siteInfo mgr token = authGetJSON mgr token [uri|https://api.stackexchange.com/2.2/info?site=stackoverflow|] sToBS :: String -> BS.ByteString sToBS = T.encodeUtf8 . T.pack 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,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {- @@ -26,20 +27,22 @@ import qualified Data.Text.Encoding as T import Network.HTTP.Conduit import Network.OAuth.OAuth2 +import URI.ByteString +import URI.ByteString.QQ import Keys main :: IO () main = do - print $ authorizationUrl weiboKey + print $ serializeURIRef' $ authorizationUrl weiboKey putStrLn "visit the url and paste code here: " code <- getLine mgr <- newManager tlsManagerSettings - token <- fetchAccessToken mgr weiboKey (sToBS code) + token <- fetchAccessToken mgr weiboKey (ExchangeToken $ T.pack code) print token case token of Right r -> do - uid <- authGetBS' mgr r "https://api.weibo.com/2/account/get_uid.json" + uid <- authGetBS' mgr (accessToken r) [uri|https://api.weibo.com/2/account/get_uid.json|] print uid Left l -> BSL.putStrLn l diff --git a/hoauth2.cabal b/hoauth2.cabal --- a/hoauth2.cabal +++ b/hoauth2.cabal @@ -1,23 +1,27 @@ Name: hoauth2 -- http://wiki.haskell.org/Package_versioning_policy -Version: 0.5.9 +Version: 1.0.0 Synopsis: Haskell OAuth2 authentication client -Description: - Haskell OAuth2 authentication client. Tested with the following services: - . - * Google web: - . - * Github: - . - * Facebook: - . - * Fitbit: - . - * Weibo: - . - * Douban: +Description: Haskell OAuth2 authentication client. Tested with the following services: + . + * Google: + . + * Github: + . + * Facebook: + . + * Fitbit: + . + * StackExchange: + . + * DropBox: + . + * Weibo: + . + * Douban: + Homepage: https://github.com/freizl/hoauth2 License: BSD3 License-file: LICENSE @@ -29,15 +33,14 @@ stability: Beta tested-with: GHC <= 7.10.2 -Extra-source-files: - README.md - example/Google/test.hs - example/Weibo/test.hs - example/Github/test.hs - example/Facebook/test.hs - example/Fitbit/test.hs - example/Douban/test.hs - example/Keys.hs.sample +Extra-source-files: README.md + example/Keys.hs.sample + example/Google/test.hs + example/Weibo/test.hs + example/Github/test.hs + example/Facebook/test.hs + example/Fitbit/test.hs + example/Douban/test.hs Cabal-version: >=1.10 @@ -50,22 +53,23 @@ 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, - text >= 0.11 && < 1.3, - bytestring >= 0.9 && < 0.11, - http-conduit >= 2.1 && < 2.3, - http-types >= 0.9 && < 0.10, - aeson >= 0.11 && < 1.2, - unordered-containers >= 0.2.5 + 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 >= 1.0 && < 1.1, + text >= 0.11 && < 1.3, + bytestring >= 0.9 && < 0.11, + http-conduit >= 2.1 && < 2.3, + http-types >= 0.9 && < 0.10, + aeson >= 0.11 && < 1.2, + unordered-containers >= 0.2.5, + uri-bytestring >= 0.2.3.1 && < 0.3, + microlens >= 0.4.0 && < 0.5, + exceptions >= 0.8.3 && < 0.9 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields @@ -87,6 +91,7 @@ http-conduit >= 2.1 && < 2.3, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, + uri-bytestring >= 0.2.3.1 && < 0.3, aeson >= 0.11 && < 1.2, hoauth2 @@ -111,6 +116,7 @@ http-conduit >= 2.1 && < 2.3, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, + uri-bytestring >= 0.2.3.1 && < 0.3, aeson >= 0.11 && < 1.2, hoauth2 @@ -135,6 +141,7 @@ http-conduit >= 2.1 && < 2.3, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, + uri-bytestring >= 0.2.3.1 && < 0.3, aeson >= 0.11 && < 1.2, hoauth2 @@ -158,6 +165,7 @@ http-conduit >= 2.1 && < 2.3, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, + uri-bytestring >= 0.2.3.1 && < 0.3, aeson >= 0.11 && < 1.2, hoauth2 @@ -181,6 +189,7 @@ http-conduit >= 2.1 && < 2.3, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, + uri-bytestring >= 0.2.3.1 && < 0.3, aeson >= 0.11 && < 1.2, hoauth2 @@ -202,6 +211,7 @@ build-depends: base >= 4.5 && < 5, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, + uri-bytestring >= 0.2.3.1 && < 0.3, http-conduit >= 2.1 && < 2.3, http-types >= 0.9 && < 0.10, wai >= 3.2 && < 3.3, @@ -231,6 +241,7 @@ http-conduit >= 2.1 && < 2.3, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, + uri-bytestring >= 0.2.3.1 && < 0.3, aeson >= 0.11 && < 1.2, hoauth2 @@ -254,6 +265,7 @@ http-conduit >= 2.1 && < 2.3, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, + uri-bytestring >= 0.2.3.1 && < 0.3, aeson >= 0.11 && < 1.2, hoauth2 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 @@ -26,7 +26,6 @@ setMethod ) where -import Control.Monad (liftM) import Data.Aeson import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL @@ -37,16 +36,17 @@ import qualified Network.HTTP.Types as HT import Network.HTTP.Types.URI (parseQuery) import Network.OAuth.OAuth2.Internal +import URI.ByteString -------------------------------------------------- -- * Token management -------------------------------------------------- --- | Request (via POST method) "Access Token". +-- | Request (via POST method) "OAuth2 Token". fetchAccessToken :: Manager -- ^ HTTP connection manager -> OAuth2 -- ^ OAuth Data - -> BS.ByteString -- ^ Authentication code gained after authorization - -> IO (OAuth2Result AccessToken) -- ^ Access Token + -> ExchangeToken -- ^ OAuth 2 Tokens + -> IO (OAuth2Result OAuth2Token) -- ^ Access Token fetchAccessToken manager oa code = doFlexiblePostRequest manager oa uri body where (uri, body) = accessTokenUrl oa code @@ -54,10 +54,10 @@ -- | Request the "Refresh Token". fetchRefreshToken :: Manager -- ^ HTTP connection manager. -> OAuth2 -- ^ OAuth context - -> BS.ByteString -- ^ refresh token gained after authorization + -> RefreshToken -- ^ refresh token gained after authorization -> IO (OAuth2Result AccessToken) -fetchRefreshToken manager oa rtoken = doFlexiblePostRequest manager oa uri body - where (uri, body) = refreshAccessTokenUrl oa rtoken +fetchRefreshToken manager oa token = doFlexiblePostRequest manager oa uri body + where (uri, body) = refreshAccessTokenUrl oa token -- | Conduct post request and return response as JSON. @@ -67,7 +67,7 @@ -> URI -- ^ The URL -> PostBody -- ^ request body -> IO (OAuth2Result a) -- ^ Response as ByteString -doJSONPostRequest manager oa uri body = liftM parseResponseJSON (doSimplePostRequest manager oa uri body) +doJSONPostRequest manager oa uri body = fmap parseResponseJSON (doSimplePostRequest manager oa uri body) -- | Conduct post request and return response as JSON or Query String. doFlexiblePostRequest :: FromJSON a @@ -76,7 +76,7 @@ -> URI -- ^ The URL -> PostBody -- ^ request body -> IO (OAuth2Result a) -- ^ Response as ByteString -doFlexiblePostRequest manager oa uri body = liftM parseResponseFlexible (doSimplePostRequest manager oa uri body) +doFlexiblePostRequest manager oa uri body = fmap parseResponseFlexible (doSimplePostRequest manager oa uri body) -- | Conduct post request. doSimplePostRequest :: Manager -- ^ HTTP connection manager. @@ -84,10 +84,10 @@ -> URI -- ^ URL -> PostBody -- ^ Request body. -> IO (OAuth2Result BSL.ByteString) -- ^ Response as ByteString -doSimplePostRequest manager oa url body = liftM handleResponse go +doSimplePostRequest manager oa url body = fmap handleResponse go where go = do - req <- parseUrl $ BS.unpack url - let addBasicAuth = applyBasicAuth (oauthClientId oa) (oauthClientSecret oa) + req <- uriToRequest url + let addBasicAuth = applyBasicAuth (T.encodeUtf8 $ oauthClientId oa) (T.encodeUtf8 $ oauthClientSecret oa) req' = (addBasicAuth . updateRequestHeaders Nothing) req httpLbs (urlEncodedBody body req') manager @@ -101,7 +101,7 @@ -> AccessToken -> URI -- ^ Full URL -> IO (OAuth2Result a) -- ^ Response as JSON -authGetJSON manager t uri = liftM parseResponseJSON $ authGetBS manager t uri +authGetJSON manager t uri = parseResponseJSON <$> authGetBS manager t uri -- | Conduct GET request. authGetBS :: Manager -- ^ HTTP connection manager. @@ -109,17 +109,17 @@ -> URI -- ^ URL -> IO (OAuth2Result BSL.ByteString) -- ^ Response as ByteString authGetBS manager token url = do - req <- parseUrl $ BS.unpack url + req <- uriToRequest 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. +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 + req <- uriToRequest (url `appendAccessToken` token) authRequest req upReq manager where upReq = updateRequestHeaders Nothing . setMethod HT.GET @@ -130,7 +130,7 @@ -> URI -- ^ Full URL -> PostBody -> IO (OAuth2Result a) -- ^ Response as JSON -authPostJSON manager t uri pb = liftM parseResponseJSON $ authPostBS manager t uri pb +authPostJSON manager t uri pb = parseResponseJSON <$> authPostBS manager t uri pb -- | Conduct POST request. authPostBS :: Manager -- ^ HTTP connection manager. @@ -139,20 +139,20 @@ -> PostBody -> IO (OAuth2Result BSL.ByteString) -- ^ Response as ByteString authPostBS manager token url pb = do - req <- parseUrl $ BS.unpack url + req <- uriToRequest url authRequest req upReq manager where upBody = urlEncodedBody (pb ++ accessTokenToParam token) upHeaders = updateRequestHeaders (Just token) . setMethod HT.POST upReq = upHeaders . upBody -- | Conduct POST request with access token in the request body rather header -authPostBS' :: Manager -- ^ HTTP connection manager. +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 + req <- uriToRequest url authRequest req upReq manager where upBody = urlEncodedBody (pb ++ accessTokenToParam token) upHeaders = updateRequestHeaders Nothing . setMethod HT.POST @@ -163,9 +163,9 @@ -- authRequest :: Request -- ^ Request to perform -> (Request -> Request) -- ^ Modify request before sending - -> Manager -- ^ HTTP connection manager. + -> Manager -- ^ HTTP connection manager. -> IO (OAuth2Result BSL.ByteString) -authRequest req upReq manager = liftM handleResponse (httpLbs (upReq req) manager) +authRequest req upReq manager = fmap handleResponse (httpLbs (upReq req) manager) -------------------------------------------------- -- * Utilities @@ -183,9 +183,16 @@ => OAuth2Result BSL.ByteString -> OAuth2Result a parseResponseJSON (Left b) = Left b -parseResponseJSON (Right b) = case decode b of - Nothing -> Left ("hoauth2.HttpClient.parseResponseJSON/Could not decode JSON: " `BSL.append` b) - Just x -> Right x +parseResponseJSON (Right b) = case eitherDecode b of + Left msg -> Left ("hoauth2.HttpClient.parseResponseJSON/Could not decode JSON: " + `BSL.append` + b + `BSL.append` + ", with error: " + `BSL.append` + BSL.pack msg + ) + Right x -> Right x -- | Parses a @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String parseResponseString :: FromJSON a @@ -195,12 +202,12 @@ parseResponseString (Right b) = case parseQuery $ BSL.toStrict b of [] -> Left errorMessage a -> case fromJSON $ queryToValue a of - Error _ -> Left errorMessage + Error _ -> Left errorMessage Success x -> Right x where queryToValue = Object . HM.fromList . map paramToPair paramToPair (k, mv) = (T.decodeUtf8 k, maybe Null (String . T.decodeUtf8) mv) - errorMessage = "hoauth2.HttpClient.parseResponseJSON/Could not decode JSON or URL: " `BSL.append` b + errorMessage = "hoauth2.HttpClient.parseResponseString/Could not decode URL: " `BSL.append` b -- | Try 'parseResponseJSON' and 'parseResponseString' parseResponseFlexible :: FromJSON a @@ -208,7 +215,7 @@ -> OAuth2Result a parseResponseFlexible r = case parseResponseJSON r of Left _ -> parseResponseString r - x -> x + x -> x -- | Set several header values: -- + userAgennt : `hoauth2` @@ -218,7 +225,7 @@ updateRequestHeaders t req = let extras = [ (HT.hUserAgent, "hoauth2") , (HT.hAccept, "application/json") ] - bearer = [(HT.hAuthorization, "Bearer " `BS.append` accessToken (fromJust t)) | isJust t] + bearer = [(HT.hAuthorization, "Bearer " `BS.append` T.encodeUtf8 (fromJust (fmap atoken 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 --- a/src/Network/OAuth/OAuth2/Internal.hs +++ b/src/Network/OAuth/OAuth2/Internal.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_HADDOCK -ignore-exports #-} @@ -7,14 +10,21 @@ module Network.OAuth.OAuth2.Internal where -import Control.Applicative ((<$>), (<*>)) -import Control.Monad (mzero) +import Control.Arrow (second) +import Control.Monad.Catch import Data.Aeson +import Data.Aeson.Types import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.Maybe +import Data.Text (Text) import Data.Text.Encoding -import Network.HTTP.Types (renderSimpleQuery) +import GHC.Generics +import Lens.Micro +import Lens.Micro.Extras +import Network.HTTP.Conduit as C +import qualified Network.HTTP.Types as H +import URI.ByteString -------------------------------------------------- -- * Data Types @@ -22,35 +32,36 @@ -- | Query Parameter Representation data OAuth2 = OAuth2 { - oauthClientId :: BS.ByteString - , oauthClientSecret :: BS.ByteString - , oauthOAuthorizeEndpoint :: BS.ByteString - , oauthAccessTokenEndpoint :: BS.ByteString - , oauthCallback :: Maybe BS.ByteString + oauthClientId :: Text + , oauthClientSecret :: Text + , oauthOAuthorizeEndpoint :: URI + , oauthAccessTokenEndpoint :: URI + , oauthCallback :: Maybe URI } deriving (Show, Eq) +newtype AccessToken = AccessToken { atoken :: Text } deriving (Show, FromJSON, ToJSON) +newtype RefreshToken = RefreshToken { rtoken :: Text } deriving (Show, FromJSON, ToJSON) +newtype IdToken = IdToken { idtoken :: Text } deriving (Show, FromJSON, ToJSON) +newtype ExchangeToken = ExchangeToken { extoken :: Text } deriving (Show, FromJSON, ToJSON) + -- | The gained Access Token. Use @Data.Aeson.decode@ to -- decode string to @AccessToken@. The @refreshToken@ is -- special in some cases, -- e.g. -data AccessToken = AccessToken { - accessToken :: BS.ByteString - , refreshToken :: Maybe BS.ByteString +data OAuth2Token = OAuth2Token { + accessToken :: AccessToken + , refreshToken :: Maybe RefreshToken , expiresIn :: Maybe Int - , tokenType :: Maybe BS.ByteString - , idToken :: Maybe BS.ByteString - } deriving (Show) + , tokenType :: Maybe Text + , idToken :: Maybe IdToken + } deriving (Show, Generic) --- | Parse JSON data into 'AccessToken' -instance FromJSON AccessToken where - parseJSON (Object o) = AccessToken <$> at <*> rt <*> ei <*> tt <*> id_ where - at = fmap encodeUtf8 $ o .: "access_token" - rt = fmap (fmap encodeUtf8) $ o .:? "refresh_token" - ei = o .:? "expires_in" - tt = fmap (fmap encodeUtf8) $ o .:? "token_type" - id_ = fmap (fmap encodeUtf8) $ o .:? "id_token" - parseJSON _ = mzero +-- | Parse JSON data into 'OAuth2Token' +instance FromJSON OAuth2Token where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } +instance ToJSON OAuth2Token where + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelTo2 '_' } -------------------------------------------------- -- * Types Synonym @@ -59,15 +70,10 @@ -- | 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 - +type QueryParams = [(BS.ByteString, BS.ByteString)] -------------------------------------------------- -- * URLs @@ -76,63 +82,90 @@ -- | 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)] - +authorizationUrl oa = over (queryL . queryPairsL) (++ queryParts) (oauthOAuthorizeEndpoint oa) + where queryParts = catMaybes [ Just ("client_id", encodeUtf8 $ oauthClientId oa) + , Just ("response_type", "code") + , fmap (("redirect_uri",) . serializeURIRef') (oauthCallback oa) ] -- | Prepare the URL and the request body query for fetching an access token. accessTokenUrl :: OAuth2 - -> BS.ByteString -- ^ access code gained via authorization URL - -> (URI, PostBody) -- ^ access token request URL plus the request body. + -> ExchangeToken -- ^ access code gained via authorization URL + -> (URI, PostBody) -- ^ access token request URL plus the request body. accessTokenUrl oa code = accessTokenUrl' oa code (Just "authorization_code") -- | Prepare the URL and the request body query for fetching an access token, with -- optional grant type. accessTokenUrl' :: OAuth2 - -> BS.ByteString -- ^ access code gained via authorization URL - -> Maybe BS.ByteString -- ^ Grant Type - -> (URI, PostBody) -- ^ access token request URL plus the request body. + -> ExchangeToken -- ^ access code gained via authorization URL + -> Maybe Text -- ^ Grant Type + -> (URI, PostBody) -- ^ access token request URL plus the request body. accessTokenUrl' oa code gt = (uri, body) where uri = oauthAccessTokenEndpoint oa - body = transform' [ ("code", Just code) - , ("redirect_uri", oauthCallback oa) - , ("grant_type", gt) - ] + body = catMaybes [ Just ("code", encodeUtf8 $ extoken code) + , (("redirect_uri",) . serializeURIRef') <$> oauthCallback oa + , fmap (("grant_type",) . encodeUtf8) 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 + -> RefreshToken -- ^ refresh token gained via authorization URL -> (URI, PostBody) -- ^ refresh token request URL plus the request body. -refreshAccessTokenUrl oa rtoken = (uri, body) +refreshAccessTokenUrl oa token = (uri, body) where uri = oauthAccessTokenEndpoint oa - body = transform' [ ("grant_type", Just "refresh_token") - , ("refresh_token", Just rtoken) - ] - --------------------------------------------------- --- * UTILs --------------------------------------------------- - --- | Append query parameters using `"?"` or `"&"`. -appendQueryParam :: URI -> QueryParams -> URI -appendQueryParam uri q = if "?" `BS.isInfixOf` uri - then uri `BS.append` "&" `BS.append` renderSimpleQuery False q - else uri `BS.append` renderSimpleQuery True q + body = [ ("grant_type", "refresh_token") + , ("refresh_token", encodeUtf8 $ rtoken token) + ] -- | For `GET` method API. -appendAccessToken :: URI -- ^ Base URI - -> AccessToken -- ^ Authorized Access Token - -> URI -- ^ Combined Result -appendAccessToken uri t = appendQueryParam uri (accessTokenToParam t) +appendAccessToken :: URIRef a -- ^ Base URI + -> AccessToken -- ^ Authorized Access Token + -> URIRef a -- ^ Combined Result +appendAccessToken uri t = over (queryL . queryPairsL) (\query -> query ++ accessTokenToParam t) uri -- | Create 'QueryParams' with given access token value. -accessTokenToParam :: AccessToken -> QueryParams -accessTokenToParam at = [("access_token", accessToken at)] +accessTokenToParam :: AccessToken -> [(BS.ByteString, BS.ByteString)] +accessTokenToParam t = [("access_token", encodeUtf8 $ atoken t)] +appendQueryParams :: [(BS.ByteString, BS.ByteString)] -> URIRef a -> URIRef a +appendQueryParams params = + over (queryL . queryPairsL) (params ++ ) --- | Lift value in the 'Maybe' and abandon 'Nothing'. -transform' :: [(a, Maybe b)] -> [(a, b)] -transform' = map (\(a, Just b) -> (a, b)) . filter (isJust . snd) +uriToRequest :: MonadThrow m => URI -> m Request +uriToRequest uri = do + ssl <- case view (uriSchemeL . schemeBSL) uri of + "http" -> return False + "https" -> return True + s -> throwM $ InvalidUrlException (show uri) ("Invalid scheme: " ++ show s) + let + query = fmap (second Just) (view (queryL . queryPairsL) uri) + hostL = authorityL . _Just . authorityHostL . hostBSL + portL = authorityL . _Just . authorityPortL . _Just . portNumberL + defaultPort = (if ssl then 443 else 80) :: Int + + req = setQueryString query $ defaultRequest { + secure = ssl, + path = view pathL uri + } + req2 = (over hostLens . maybe id const . preview hostL) uri req + req3 = (over portLens . maybe (const defaultPort) const . preview portL) uri req2 + return req3 + +requestToUri :: Request -> URI +requestToUri req = + URI + (Scheme (if secure req + then "https" + else "http")) + (Just (Authority Nothing (Host $ host req) (Just $ Port $ port req))) + (path req) + (Query $ H.parseSimpleQuery $ queryString req) + Nothing + +hostLens :: Lens' Request BS.ByteString +hostLens f req = f (C.host req) <&> \h' -> req { C.host = h' } +{-# INLINE hostLens #-} + +portLens :: Lens' Request Int +portLens f req = f (C.port req) <&> \p' -> req { C.port = p' } +{-# INLINE portLens #-}