diff --git a/example/StackExchange/test.hs b/example/StackExchange/test.hs --- a/example/StackExchange/test.hs +++ b/example/StackExchange/test.hs @@ -1,45 +1,41 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} -- | Github API: http://developer.github.com/v3/oauth/ module Main where -import Control.Applicative -import Control.Monad (mzero) -import Data.Aeson -import Data.Aeson.TH (defaultOptions, deriveJSON) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy.Char8 as BSL -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import Data.Aeson.TH (defaultOptions, deriveJSON) +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 Network.HTTP.Conduit import Network.OAuth.OAuth2 import Keys -data SiteInfo = SiteInfo { items :: [SiteItem] - , has_more :: Bool - , quota_max :: Integer +data SiteInfo = SiteInfo { items :: [SiteItem] + , has_more :: Bool + , quota_max :: Integer , quota_remaining :: Integer } deriving (Show, Eq) -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 +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 + , total_answers :: Integer + , total_accepted :: Integer + , total_unanswered :: Integer + , total_questions :: Integer + , api_revision :: Text } deriving (Show, Eq) $(deriveJSON defaultOptions ''SiteInfo) @@ -50,28 +46,13 @@ main = do print $ authorizationUrl stackexchangeKey putStrLn "visit the url and paste code here: " - code <- getLine + code <- fmap BS.pack getLine mgr <- newManager tlsManagerSettings - let (url, body) = accessTokenUrl stackexchangeKey (sToBS code) - token <- doSimplePostRequest mgr stackexchangeKey url (body) - print (token :: OAuth2Result BSL.ByteString) + token <- fetchAccessToken mgr stackexchangeKey code + print token case token of - Right at -> siteInfo mgr (getAccessToken at) >>= print + Right at -> siteInfo mgr at >>= print Left _ -> putStrLn "no access token found yet" - - - --- stackexchange access token api does not respond json but an string --- https://api.stackexchange.com/docs/authentication -getAccessToken :: BSL.ByteString -> AccessToken -getAccessToken str = let xs = BSL.split '&' str - ys = BSL.split '=' (xs !! 0) - in - AccessToken { accessToken = BSL.toStrict (ys !! 1) - , refreshToken = Nothing - , expiresIn = Nothing - , tokenType = Nothing - } -- | Test API: info siteInfo :: Manager -> AccessToken -> IO (OAuth2Result SiteInfo) diff --git a/hoauth2.cabal b/hoauth2.cabal --- a/hoauth2.cabal +++ b/hoauth2.cabal @@ -1,6 +1,6 @@ Name: hoauth2 -- http://wiki.haskell.org/Package_versioning_policy -Version: 0.5.4.0 +Version: 0.5.5.0 Synopsis: Haskell OAuth2 authentication client Description: @@ -58,12 +58,13 @@ Network.OAuth.OAuth2 Build-Depends: - base >= 4 && < 5, - aeson >= 0.9 && < 0.12, - text >= 0.11 && < 1.3, - bytestring >= 0.9 && < 0.11, - http-conduit >= 2.0 && < 2.2, - http-types >= 0.9 && < 0.10 + base >= 4 && < 5, + aeson >= 0.9 && < 0.12, + text >= 0.11 && < 1.3, + bytestring >= 0.9 && < 0.11, + http-conduit >= 2.2 && < 2.3, + http-types >= 0.9 && < 0.10, + unordered-containers >=0.2.5 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields @@ -82,7 +83,7 @@ default-language: Haskell2010 build-depends: base >= 4.5 && < 5, http-types >= 0.9 && < 0.10, - http-conduit >= 2.0 && < 2.2, + http-conduit >= 2.2 && < 2.3, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, hoauth2 @@ -105,7 +106,7 @@ default-language: Haskell2010 build-depends: base >= 4.5 && < 5, http-types >= 0.9 && < 0.10, - http-conduit >= 2.0 && < 2.2, + http-conduit >= 2.2 && < 2.3, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, aeson >= 0.9 && < 0.12, @@ -129,7 +130,7 @@ default-language: Haskell2010 build-depends: base >= 4.5 && < 5, http-types >= 0.9 && < 0.10, - http-conduit >= 2.0 && < 2.2, + http-conduit >= 2.2 && < 2.3, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, aeson >= 0.9 && < 0.12, @@ -152,7 +153,7 @@ default-language: Haskell2010 build-depends: base >= 4.5 && < 5, http-types >= 0.9 && < 0.10, - http-conduit >= 2.0 && < 2.2, + http-conduit >= 2.2 && < 2.3, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, aeson >= 0.9 && < 0.12, @@ -175,7 +176,7 @@ default-language: Haskell2010 build-depends: base >= 4.5 && < 5, http-types >= 0.9 && < 0.10, - http-conduit >= 2.0 && < 2.2, + http-conduit >= 2.2 && < 2.3, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, aeson >= 0.9 && < 0.12, @@ -200,7 +201,7 @@ aeson >= 0.9 && < 0.12, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, - http-conduit >= 2.0 && < 2.2, + http-conduit >= 2.2 && < 2.3, http-types >= 0.9 && < 0.10, wai >= 3.2 && < 3.3, warp >= 3.2 && < 3.3, @@ -225,7 +226,7 @@ default-language: Haskell2010 build-depends: base >= 4.5 && < 5, http-types >= 0.9 && < 0.10, - http-conduit >= 2.0 && < 2.2, + http-conduit >= 2.2 && < 2.3, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, aeson >= 0.9 && < 0.12, 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 @@ -8,6 +8,7 @@ fetchAccessToken, fetchRefreshToken, doJSONPostRequest, + doFlexiblePostRequest, doSimplePostRequest, -- * AUTH requests authGetJSON, @@ -19,6 +20,7 @@ -- * Utilities handleResponse, parseResponseJSON, + parseResponseFlexible, updateRequestHeaders, setMethod ) where @@ -27,10 +29,12 @@ import Data.Aeson import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.HashMap.Strict as HM (fromList) import Data.Maybe +import qualified Data.Text.Encoding as T import Network.HTTP.Conduit hiding (withManager) import qualified Network.HTTP.Types as HT - +import Network.HTTP.Types.URI (parseQuery) import Network.OAuth.OAuth2.Internal -------------------------------------------------- @@ -42,7 +46,7 @@ -> OAuth2 -- ^ OAuth Data -> BS.ByteString -- ^ Authentication code gained after authorization -> IO (OAuth2Result AccessToken) -- ^ Access Token -fetchAccessToken manager oa code = doJSONPostRequest manager oa uri body +fetchAccessToken manager oa code = doFlexiblePostRequest manager oa uri body where (uri, body) = accessTokenUrl oa code @@ -51,7 +55,7 @@ -> OAuth2 -- ^ OAuth context -> BS.ByteString -- ^ refresh token gained after authorization -> IO (OAuth2Result AccessToken) -fetchRefreshToken manager oa rtoken = doJSONPostRequest manager oa uri body +fetchRefreshToken manager oa rtoken = doFlexiblePostRequest manager oa uri body where (uri, body) = refreshAccessTokenUrl oa rtoken @@ -64,6 +68,15 @@ -> IO (OAuth2Result a) -- ^ Response as ByteString doJSONPostRequest manager oa uri body = liftM parseResponseJSON (doSimplePostRequest manager oa uri body) +-- | Conduct post request and return response as JSON or Query String. +doFlexiblePostRequest :: FromJSON a + => Manager -- ^ HTTP connection manager. + -> OAuth2 -- ^ OAuth options + -> URI -- ^ The URL + -> PostBody -- ^ request body + -> IO (OAuth2Result a) -- ^ Response as ByteString +doFlexiblePostRequest manager oa uri body = liftM parseResponseFlexible (doSimplePostRequest manager oa uri body) + -- | Conduct post request. doSimplePostRequest :: Manager -- ^ HTTP connection manager. -> OAuth2 -- ^ OAuth options @@ -159,6 +172,29 @@ parseResponseJSON (Right b) = case decode b of Nothing -> Left ("hoauth2.HttpClient.parseResponseJSON/Could not decode JSON: " `BSL.append` b) Just x -> Right x + +-- | Parses a @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String +parseResponseString :: FromJSON a + => OAuth2Result BSL.ByteString + -> OAuth2Result a +parseResponseString (Left b) = Left b +parseResponseString (Right b) = case parseQuery $ BSL.toStrict b of + [] -> Left errorMessage + a -> case fromJSON $ queryToValue a of + 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) + +-- | Try 'parseResponseJSON' and 'parseResponseString' +parseResponseFlexible :: FromJSON a + => OAuth2Result BSL.ByteString + -> OAuth2Result a +parseResponseFlexible r = case parseResponseJSON r of + Left _ -> parseResponseString r + x -> x -- | Set several header values: -- + userAgennt : `hoauth2`