diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c)2012-2017, Haisheng Wu +Copyright (c)2012-present, Haisheng Wu All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -13,6 +13,12 @@ - `make demo` - open +## Nix + +- assume `cabal-install` has been install (either globally or in nix store) +- `nix-shell` then could do `cabal v2-` build +- or `nix-build` + # Contribute Feel free send pull request or submit issue ticket. diff --git a/example/App.hs b/example/App.hs --- a/example/App.hs +++ b/example/App.hs @@ -23,7 +23,6 @@ import Prelude import Web.Scotty import Web.Scotty.Internal.Types - import IDP import Session import Types @@ -135,8 +134,4 @@ fetchUser :: (HasUserReq a) => a -> Manager -> AccessToken -> IO (Either Text LoginUser) fetchUser idp mgr token = do re <- userReq idp mgr token - return (first displayOAuth2Error re) - -displayOAuth2Error :: OAuth2Error Errors -> Text -displayOAuth2Error = TL.pack . show - + return (first bslToText re) diff --git a/example/IDP/AzureAD.hs b/example/IDP/AzureAD.hs --- a/example/IDP/AzureAD.hs +++ b/example/IDP/AzureAD.hs @@ -3,17 +3,17 @@ {-# LANGUAGE QuasiQuotes #-} module IDP.AzureAD where -import Data.Aeson -import Data.Bifunctor -import Data.Hashable -import Data.Text.Lazy (Text) -import GHC.Generics -import Keys -import Network.OAuth.OAuth2 -import Types -import URI.ByteString -import URI.ByteString.QQ -import Utils +import Data.Aeson +import Data.Bifunctor +import Data.Hashable +import Data.Text.Lazy (Text) +import GHC.Generics +import Keys +import Network.OAuth.OAuth2 +import Types +import URI.ByteString +import URI.ByteString.QQ +import Utils data AzureAD = AzureAD deriving (Show, Generic) diff --git a/example/IDP/Dropbox.hs b/example/IDP/Dropbox.hs --- a/example/IDP/Dropbox.hs +++ b/example/IDP/Dropbox.hs @@ -10,6 +10,7 @@ import GHC.Generics import Keys import Network.OAuth.OAuth2 +import qualified Data.ByteString.Lazy.Char8 as BSL import Types import URI.ByteString import URI.ByteString.QQ @@ -28,8 +29,9 @@ instance HasUserReq Dropbox where userReq _ mgr at = do - re <- parseResponseJSON <$> authPostBS3 mgr at userInfoUri - return (second toLoginUser re) + re <- authPostBS3 mgr at userInfoUri + return (re >>= (bimap BSL.pack toLoginUser . eitherDecode)) + instance HasAuthUri Dropbox where authUri _ = createCodeUri dropboxKey [ ("state", "Dropbox.test-state-123") diff --git a/example/IDP/StackExchange.hs b/example/IDP/StackExchange.hs --- a/example/IDP/StackExchange.hs +++ b/example/IDP/StackExchange.hs @@ -13,6 +13,7 @@ import Data.Hashable import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +import qualified Data.ByteString.Lazy.Char8 as BSL import GHC.Generics import Keys import Lens.Micro @@ -35,10 +36,9 @@ instance HasUserReq StackExchange where userReq _ mgr token = do - re <- parseResponseJSON - <$> authGetBS2 mgr token + re <- authGetBS2 mgr token (userInfoUri `appendStackExchangeAppKey` stackexchangeAppKey) - return (second toLoginUser re) + return (re >>= (bimap BSL.pack toLoginUser . eitherDecode)) instance HasAuthUri StackExchange where authUri _ = createCodeUri stackexchangeKey [ ("state", "StackExchange.test-state-123") @@ -72,4 +72,3 @@ appendStackExchangeAppKey :: URI -> ByteString -> URI appendStackExchangeAppKey useruri k = over (queryL . queryPairsL) (\query -> query ++ [("key", k)]) useruri - diff --git a/example/IDP/Weibo.hs b/example/IDP/Weibo.hs --- a/example/IDP/Weibo.hs +++ b/example/IDP/Weibo.hs @@ -8,6 +8,7 @@ import Data.Hashable import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +import qualified Data.ByteString.Lazy.Char8 as BSL import GHC.Generics import Keys import Network.OAuth.OAuth2 @@ -32,8 +33,8 @@ -- access token in query param only instance HasUserReq Weibo where userReq _ mgr at = do - re <- parseResponseJSON <$> authGetBS2 mgr at userInfoUri - return (second toLoginUser re) + re <- authGetBS2 mgr at userInfoUri + return (re >>= (bimap BSL.pack toLoginUser . eitherDecode)) instance HasAuthUri Weibo where authUri _ = createCodeUri weiboKey [ ("state", "Weibo.test-state-123") diff --git a/example/Session.hs b/example/Session.hs --- a/example/Session.hs +++ b/example/Session.hs @@ -29,7 +29,7 @@ -> IO (Maybe IDPData) lookupKey store idpKey = do m1 <- tryReadMVar store - return $ maybe Nothing (Map.lookup idpKey) m1 + return (Map.lookup idpKey =<< m1) insertIDPData :: CacheStore -> IDPData -> IO () insertIDPData store val = do diff --git a/example/Types.hs b/example/Types.hs --- a/example/Types.hs +++ b/example/Types.hs @@ -18,6 +18,7 @@ import Network.HTTP.Conduit import Network.OAuth.OAuth2 import qualified Network.OAuth.OAuth2.TokenRequest as TR +import qualified Data.ByteString.Lazy.Char8 as BSL import Text.Mustache import qualified Text.Mustache as M @@ -42,7 +43,7 @@ tokenReq :: a -> Manager -> ExchangeToken -> IO (OAuth2Result TR.Errors OAuth2Token) class (IDP a) => HasUserReq a where - userReq :: FromJSON b => a -> Manager -> AccessToken -> IO (OAuth2Result b LoginUser) + userReq :: a -> Manager -> AccessToken -> IO (Either BSL.ByteString LoginUser) -- Heterogenous collections -- https://wiki.haskell.org/Heterogenous_collections diff --git a/example/Utils.hs b/example/Utils.hs --- a/example/Utils.hs +++ b/example/Utils.hs @@ -5,6 +5,8 @@ import qualified Data.Text.Encoding as TE import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +import qualified Data.ByteString.Lazy.Char8 as BSL + import Network.OAuth.OAuth2 import URI.ByteString import Web.Scotty.Internal.Types @@ -12,6 +14,9 @@ tlToBS :: TL.Text -> ByteString tlToBS = TE.encodeUtf8 . TL.toStrict +bslToText :: BSL.ByteString -> Text +bslToText = TL.pack . BSL.unpack + paramValue :: Text -> [Param] -> [Text] paramValue key = fmap snd . filter (hasParam key) @@ -30,5 +35,3 @@ createCodeUri key params = TL.fromStrict $ TE.decodeUtf8 $ serializeURIRef' $ appendQueryParams params $ authorizationUrl key - - 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: 1.8.9 +Version: 1.9.0 Synopsis: Haskell OAuth2 authentication client @@ -33,7 +33,7 @@ Category: Network Build-type: Simple stability: Beta -tested-with: GHC <= 8.0.2 +tested-with: GHC <= 8.4.3 Extra-source-files: README.md example/Keys.hs.sample @@ -76,6 +76,7 @@ Network.OAuth.OAuth2.AuthorizationRequest Build-Depends: base >= 4 && < 5, + binary >= 0.8.3.0 && < 0.8.7, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, http-conduit >= 2.1 && < 2.4, 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,11 +8,7 @@ -- * Token management fetchAccessToken, fetchAccessToken2, - fetchRefreshToken, refreshAccessToken, - doJSONPostRequest, - doFlexiblePostRequest, - doSimplePostRequest, -- * AUTH requests authGetJSON, authGetBS, @@ -21,15 +17,10 @@ authPostBS, authPostBS2, authPostBS3, - authRequest, --- * Utilities - handleResponse, - parseResponseJSON, - parseResponseFlexible, - updateRequestHeaders, - setMethod + authRequest ) where +import Data.Bifunctor (first) import Data.Aeson import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL @@ -54,7 +45,7 @@ -> OAuth2 -- ^ OAuth Data -> ExchangeToken -- ^ OAuth 2 Tokens -> IO (OAuth2Result TR.Errors OAuth2Token) -- ^ Access Token -fetchAccessToken manager oa code = doFlexiblePostRequest manager oa uri body +fetchAccessToken manager oa code = doJSONPostRequest manager oa uri body where (uri, body) = accessTokenUrl oa code -- | Request OAuth2 Token @@ -69,42 +60,24 @@ let extraBody = [ ("client_id", T.encodeUtf8 $ oauthClientId oa) , ("client_secret", T.encodeUtf8 $ oauthClientSecret oa) ] - doFlexiblePostRequest mgr oa url (extraBody ++ body1) + doJSONPostRequest mgr oa url (extraBody ++ body1) -- | Request a new AccessToken with the Refresh Token. refreshAccessToken :: Manager -- ^ HTTP connection manager. -> OAuth2 -- ^ OAuth context -> RefreshToken -- ^ refresh token gained after authorization -> IO (OAuth2Result TR.Errors OAuth2Token) -refreshAccessToken manager oa token = doFlexiblePostRequest manager oa uri body +refreshAccessToken manager oa token = doJSONPostRequest manager oa uri body where (uri, body) = refreshAccessTokenUrl oa token -{-# DEPRECATED fetchRefreshToken "Use refreshAccessToken since this method will be removed in future release" #-} -fetchRefreshToken :: Manager -- ^ HTTP connection manager. - -> OAuth2 -- ^ OAuth context - -> RefreshToken -- ^ refresh token gained after authorization - -> IO (OAuth2Result TR.Errors OAuth2Token) -fetchRefreshToken = refreshAccessToken - - -- | Conduct post request and return response as JSON. -doJSONPostRequest :: FromJSON err => FromJSON a +doJSONPostRequest :: (FromJSON err, FromJSON a) => Manager -- ^ HTTP connection manager. -> OAuth2 -- ^ OAuth options -> URI -- ^ The URL -> PostBody -- ^ request body -> IO (OAuth2Result err a) -- ^ Response as JSON -doJSONPostRequest manager oa uri body = fmap parseResponseJSON (doSimplePostRequest manager oa uri body) - --- | Conduct post request and return response as JSON or Query String. -{-# DEPRECATED doFlexiblePostRequest "Use doJSONPostRequest since this function would be removed in future release." #-} -doFlexiblePostRequest :: FromJSON err => FromJSON a - => Manager -- ^ HTTP connection manager. - -> OAuth2 -- ^ OAuth options - -> URI -- ^ The URL - -> PostBody -- ^ request body - -> IO (OAuth2Result err a) -- ^ Response as ByteString -doFlexiblePostRequest manager oa uri body = fmap parseResponseFlexible (doSimplePostRequest manager oa uri body) +doJSONPostRequest manager oa uri body = fmap parseResponseFlexible (doSimplePostRequest manager oa uri body) -- | Conduct post request. doSimplePostRequest :: FromJSON err => Manager -- ^ HTTP connection manager. @@ -112,61 +85,102 @@ -> URI -- ^ URL -> PostBody -- ^ Request body. -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString -doSimplePostRequest manager oa url body = fmap handleResponse go +doSimplePostRequest manager oa url body = fmap handleOAuth2TokenResponse go where go = do req <- uriToRequest url let addBasicAuth = applyBasicAuth (T.encodeUtf8 $ oauthClientId oa) (T.encodeUtf8 $ oauthClientSecret oa) req' = (addBasicAuth . updateRequestHeaders Nothing) req httpLbs (urlEncodedBody body req') manager +-- | Parses a @Response@ to to @OAuth2Result@ +handleOAuth2TokenResponse :: FromJSON err => Response BSL.ByteString -> OAuth2Result err BSL.ByteString +handleOAuth2TokenResponse rsp = + if HT.statusIsSuccessful (responseStatus rsp) + then Right $ responseBody rsp + else Left $ parseOAuth2Error (responseBody rsp) + +-- | Try 'parseResponseJSON', if failed then parses the @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String. +parseResponseFlexible :: FromJSON err => FromJSON a + => OAuth2Result err BSL.ByteString + -> OAuth2Result err a +parseResponseFlexible r = case parseResponseJSON r of + Left _ -> parseResponseString r + x -> x + +parseResponseJSON :: (FromJSON err, FromJSON a) + => OAuth2Result err BSL.ByteString + -> OAuth2Result err a +parseResponseJSON (Left b) = Left b +parseResponseJSON (Right b) = case eitherDecode b of + Left e -> Left $ mkDecodeOAuth2Error b e + Right x -> Right x + +-- | Parses a @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String +parseResponseString :: (FromJSON err, FromJSON a) + => OAuth2Result err BSL.ByteString + -> OAuth2Result err 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 = parseOAuth2Error b + -------------------------------------------------- -- * AUTH requests -------------------------------------------------- -- | Conduct an authorized GET request and return response as JSON. -authGetJSON :: FromJSON err => FromJSON a +authGetJSON :: (FromJSON b) => Manager -- ^ HTTP connection manager. -> AccessToken -> URI - -> IO (OAuth2Result err a) -- ^ Response as JSON -authGetJSON manager t uri = parseResponseJSON <$> authGetBS manager t uri + -> IO (Either BSL.ByteString b) -- ^ Response as JSON +authGetJSON manager t uri = do + resp <- authGetBS manager t uri + return (resp >>= (first BSL.pack . eitherDecode)) -- | Conduct an authorized GET request. -authGetBS :: FromJSON err => Manager -- ^ HTTP connection manager. +authGetBS :: Manager -- ^ HTTP connection manager. -> AccessToken -> URI - -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString + -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString authGetBS manager token url = do 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 -authGetBS2 :: FromJSON err => Manager -- ^ HTTP connection manager. +authGetBS2 :: Manager -- ^ HTTP connection manager. -> AccessToken -> URI - -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString + -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString authGetBS2 manager token url = do req <- uriToRequest (url `appendAccessToken` token) - -- print $ queryString req authRequest req upReq manager where upReq = updateRequestHeaders Nothing . setMethod HT.GET -- | Conduct POST request and return response as JSON. -authPostJSON :: FromJSON err => FromJSON a +authPostJSON :: (FromJSON b) => Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> PostBody - -> IO (OAuth2Result err a) -- ^ Response as JSON -authPostJSON manager t uri pb = parseResponseJSON <$> authPostBS manager t uri pb + -> IO (Either BSL.ByteString b) -- ^ Response as JSON +authPostJSON manager t uri pb = do + resp <- authPostBS manager t uri pb + return (resp >>= (first BSL.pack . eitherDecode)) -- | Conduct POST request. -authPostBS :: FromJSON err => Manager -- ^ HTTP connection manager. +authPostBS :: Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> PostBody - -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString + -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString authPostBS manager token url pb = do req <- uriToRequest url authRequest req upReq manager @@ -175,11 +189,11 @@ upReq = upHeaders . upBody -- | Conduct POST request with access token in the request body rather header -authPostBS2 :: FromJSON err => Manager -- ^ HTTP connection manager. +authPostBS2 :: Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> PostBody - -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString + -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString authPostBS2 manager token url pb = do req <- uriToRequest url authRequest req upReq manager @@ -188,10 +202,10 @@ upReq = upHeaders . upBody -- | Conduct POST request with access token in the header and null in body -authPostBS3 :: FromJSON err => Manager -- ^ HTTP connection manager. +authPostBS3 :: Manager -- ^ HTTP connection manager. -> AccessToken -> URI - -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString + -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString authPostBS3 manager token url = do req <- uriToRequest url authRequest req upReq manager @@ -202,54 +216,22 @@ -- |Send an HTTP request including the Authorization header with the specified -- access token. -- -authRequest :: FromJSON err => Request -- ^ Request to perform +authRequest :: Request -- ^ Request to perform -> (Request -> Request) -- ^ Modify request before sending -> Manager -- ^ HTTP connection manager. - -> IO (OAuth2Result err BSL.ByteString) -authRequest req upReq manager = fmap handleResponse (httpLbs (upReq req) manager) + -> IO (Either BSL.ByteString BSL.ByteString) +authRequest req upReq manage = handleResponse <$> httpLbs (upReq req) manage -------------------------------------------------- -- * Utilities -------------------------------------------------- -- | Parses a @Response@ to to @OAuth2Result@ -handleResponse :: FromJSON err => Response BSL.ByteString -> OAuth2Result err BSL.ByteString +handleResponse :: Response BSL.ByteString -> Either BSL.ByteString BSL.ByteString handleResponse rsp = if HT.statusIsSuccessful (responseStatus rsp) then Right $ responseBody rsp - else Left $ parseOAuth2Error (responseBody rsp) - --- | Parses a @OAuth2Result BSL.ByteString@ into @FromJSON a => a@ -parseResponseJSON :: FromJSON err => FromJSON a - => OAuth2Result err BSL.ByteString - -> OAuth2Result err a -parseResponseJSON (Left b) = Left b -parseResponseJSON (Right b) = case eitherDecode b of - Left e -> Left $ mkDecodeOAuth2Error b e - Right x -> Right x - --- | Parses a @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String -parseResponseString :: FromJSON err => FromJSON a - => OAuth2Result err BSL.ByteString - -> OAuth2Result err 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 = parseOAuth2Error b - --- | Try 'parseResponseJSON', if failed then parses the @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String. -parseResponseFlexible :: FromJSON err => FromJSON a - => OAuth2Result err BSL.ByteString - -> OAuth2Result err a -parseResponseFlexible r = case parseResponseJSON r of - Left _ -> parseResponseString r - x -> x + else Left $ responseBody rsp -- | Set several header values: -- + userAgennt : `hoauth2` @@ -259,7 +241,7 @@ updateRequestHeaders t req = let extras = [ (HT.hUserAgent, "hoauth2") , (HT.hAccept, "application/json") ] - bearer = [(HT.hAuthorization, "Bearer " `BS.append` T.encodeUtf8 (fromJust (fmap atoken t))) | isJust t] + bearer = [(HT.hAuthorization, "Bearer " `BS.append` T.encodeUtf8 (atoken (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 --- a/src/Network/OAuth/OAuth2/Internal.hs +++ b/src/Network/OAuth/OAuth2/Internal.hs @@ -14,7 +14,8 @@ import Control.Arrow (second) import Control.Monad.Catch import Data.Aeson -import Data.Aeson.Types (explicitParseFieldMaybe, Parser) +import Data.Aeson.Types (Parser, explicitParseFieldMaybe) +import Data.Binary (Binary) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.Maybe @@ -42,9 +43,9 @@ , 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 AccessToken = AccessToken { atoken :: Text } deriving (Binary, Show, FromJSON, ToJSON) +newtype RefreshToken = RefreshToken { rtoken :: Text } deriving (Binary, Show, FromJSON, ToJSON) +newtype IdToken = IdToken { idtoken :: Text } deriving (Binary, Show, FromJSON, ToJSON) newtype ExchangeToken = ExchangeToken { extoken :: Text } deriving (Show, FromJSON, ToJSON) @@ -60,9 +61,11 @@ , idToken :: Maybe IdToken } deriving (Show, Generic) +instance Binary OAuth2Token + parseIntFlexible :: Value -> Parser Int parseIntFlexible (String s) = pure . read $ unpack s -parseIntFlexible v = parseJSON v +parseIntFlexible v = parseJSON v -- | Parse JSON data into 'OAuth2Token' instance FromJSON OAuth2Token where