hoauth2 1.8.9 → 1.9.0

raw patch · 13 files changed

+120/−127 lines, 13 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• README.md +6/−0
• example/App.hs +1/−6
• example/IDP/AzureAD.hs +11/−11
• example/IDP/Dropbox.hs +4/−2
• example/IDP/StackExchange.hs +3/−4
• example/IDP/Weibo.hs +3/−2
• example/Session.hs +1/−1
• example/Types.hs +2/−1
• example/Utils.hs +5/−2
• hoauth2.cabal +3/−2
• src/Network/OAuth/OAuth2/HttpClient.hs +72/−90
• src/Network/OAuth/OAuth2/Internal.hs +8/−5

@@ -1,4 +1,4 @@-Copyright (c)2012-2017, Haisheng Wu+Copyright (c)2012-present, Haisheng Wu  All rights reserved. 

@@ -13,6 +13,12 @@ - `make demo` - open <http://localhost:9988> +## 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.

@@ -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)

@@ -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) 

@@ -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")

@@ -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-

@@ -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")

@@ -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

@@ -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

@@ -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--

@@ -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,

@@ -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 }

@@ -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