hoauth2 2.2.0 → 2.3.0

raw patch · 6 files changed

+575/−363 lines, 6 filesdep +containersdep +data-defaultdep −hashabledep −unordered-containersPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, data-default

Dependencies removed: hashable, unordered-containers

API changes (from Hackage documentation)

Files

• hoauth2.cabal +4/−5
• src/Network/OAuth/OAuth2.hs +18/−9
• src/Network/OAuth/OAuth2/AuthorizationRequest.hs +35/−6
• src/Network/OAuth/OAuth2/HttpClient.hs +219/−246
• src/Network/OAuth/OAuth2/Internal.hs +44/−91
• src/Network/OAuth/OAuth2/TokenRequest.hs +255/−6

@@ -1,7 +1,7 @@ Cabal-version: 2.4 Name:                hoauth2 -- http://wiki.haskell.org/Package_versioning_policy-Version:             2.2.0+Version:             2.3.0  Synopsis:            Haskell OAuth2 authentication client @@ -52,20 +52,19 @@                    Network.OAuth.OAuth2.AuthorizationRequest    Build-Depends: base                 >= 4     && < 5,+                 data-default         >= 0.7   && < 0.8,                  binary               >= 0.8.3 && < 0.8.9,+                 containers           >= 0.6   && < 0.7,                  text                 >= 0.11  && < 1.3,                  bytestring           >= 0.9   && < 0.11,                  http-conduit         >= 2.1   && < 2.4,                  http-types           >= 0.11  && < 0.13,                  aeson                >= 2.0   && < 2.1,                  transformers         >= 0.5   && < 0.6,-                 unordered-containers >= 0.2.5 && < 0.3,                  uri-bytestring       >= 0.2.3 && < 0.4,                  uri-bytestring-aeson >= 0.1   && < 0.2,                  microlens            >= 0.4.0 && < 0.5,-                 hashable             >= 1.2.6 && < 1.5.0,                  exceptions           >= 0.8.3 && < 0.11    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields-               -fno-warn-unused-do-bind-+               -fno-warn-unused-do-bind -Wunused-packages

@@ -1,21 +1,30 @@ ------------------------------------------------------------++------------------------------------------------------------+ -- | -- Module      :  Network.OAuth.OAuth2 -- Description :  OAuth2 client -- Copyright   :  (c) 2012 Haisheng Wu -- License     :  BSD-style (see the file LICENSE) -- Maintainer  :  Haisheng Wu <freizl@gmail.com>--- Stability   :  alpha+-- Stability   :  Beta -- Portability :  portable -- -- A lightweight oauth2 haskell binding.-------------------------------------------------------------- module Network.OAuth.OAuth2-       (module Network.OAuth.OAuth2.HttpClient,-        module Network.OAuth.OAuth2.Internal-       )-       where+  ( module Network.OAuth.OAuth2.HttpClient,+    module Network.OAuth.OAuth2.AuthorizationRequest,+    module Network.OAuth.OAuth2.TokenRequest,+    module Network.OAuth.OAuth2.Internal,+  )+where -import           Network.OAuth.OAuth2.HttpClient-import           Network.OAuth.OAuth2.Internal+{-+  Hiding Errors data type from default.+  Shall qualified import given the naming conflicts.+-}+import Network.OAuth.OAuth2.AuthorizationRequest hiding (Errors(..))+import Network.OAuth.OAuth2.HttpClient+import Network.OAuth.OAuth2.Internal+import Network.OAuth.OAuth2.TokenRequest hiding (Errors(..))

@@ -1,19 +1,31 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}  module Network.OAuth.OAuth2.AuthorizationRequest where -import           Data.Aeson-import           GHC.Generics+import Data.Aeson+import qualified Data.Text.Encoding as T+import GHC.Generics+import Lens.Micro+import Network.OAuth.OAuth2.Internal+import URI.ByteString +--------------------------------------------------++-- * Errors++--------------------------------------------------+ instance FromJSON Errors where-  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }+  parseJSON = genericParseJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}+ instance ToJSON Errors where-  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }+  toEncoding = genericToEncoding defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}  -- | Authorization Code Grant Error Responses https://tools.ietf.org/html/rfc6749#section-4.1.2.1 -- Implicit Grant Error Responses https://tools.ietf.org/html/rfc6749#section-4.2.2.1-data Errors =-    InvalidRequest+data Errors+  = InvalidRequest   | UnauthorizedClient   | AccessDenied   | UnsupportedResponseType@@ -21,3 +33,20 @@   | ServerError   | TemporarilyUnavailable   deriving (Show, Eq, Generic)++--------------------------------------------------++-- * URLs++--------------------------------------------------++-- | Prepare the authorization URL.  Redirect to this URL+-- asking for user interactive authentication.+authorizationUrl :: OAuth2 -> URI+authorizationUrl oa = over (queryL . queryPairsL) (++ queryParts) (oauth2AuthorizeEndpoint oa)+  where+    queryParts =+      [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa),+        ("response_type", "code"),+        ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa)+      ]

@@ -1,281 +1,243 @@-{-# LANGUAGE ExplicitForAll    #-}-{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}  -- | A simple http client to request OAuth2 tokens and several utils.--module Network.OAuth.OAuth2.HttpClient (--- * Token management-  fetchAccessToken,-  fetchAccessToken2,-  refreshAccessToken,-  refreshAccessToken2,-  doSimplePostRequest,--- * AUTH requests-  authGetJSON,-  authGetBS,-  authGetBS2,-  authPostJSON,-  authPostBS,-  authPostBS2,-  authPostBS3,-  authRequest-) where+module Network.OAuth.OAuth2.HttpClient+  ( -- * AUTH requests+    authGetJSON,+    authGetBS,+    authGetBS2,+    authGetJSONInternal,+    authGetBSInternal,+    authPostJSON,+    authPostBS,+    authPostBS1,+    authPostBS2,+    authPostBS3,+    authPostJSONInternal,+    authPostBSInternal,+  )+where +import qualified Data.Set as Set import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except-import qualified Data.Aeson.KeyMap as KeyMap-import           qualified Data.Aeson.Key as Key-import           Data.Aeson-import qualified Data.ByteString.Char8             as BS-import qualified Data.ByteString.Lazy.Char8        as BSL-import           Data.Maybe-import qualified Data.Text.Encoding                as T-import           Network.HTTP.Conduit-import qualified Network.HTTP.Types                as HT-import           Network.HTTP.Types.URI            (parseQuery)-import           Network.OAuth.OAuth2.Internal-import qualified Network.OAuth.OAuth2.TokenRequest as TR-import           URI.ByteString+import Data.Aeson+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as BSL+import Data.Maybe+import qualified Data.Text.Encoding as T+import Lens.Micro+import Network.HTTP.Conduit+import qualified Network.HTTP.Types as HT+import Network.OAuth.OAuth2.Internal+import URI.ByteString  ----------------------------------------------------- * Token management--------------------------------------------------- --- | Fetch OAuth2 Token with authenticate in request header.------ OAuth2 spec allows `client_id` and `client_secret` to--- either be sent in the header (as basic authentication)--- OR as form/url params.--- The OAuth server can choose to implement only one, or both.--- Unfortunately, there is no way for the OAuth client (i.e. this library) to--- know which method to use. Please take a look at the documentation of the--- service that you are integrating with and either use `fetchAccessToken` or `fetchAccessToken2`-fetchAccessToken :: Manager                                   -- ^ HTTP connection manager-                   -> OAuth2                                  -- ^ OAuth Data-                   -> ExchangeToken                           -- ^ OAuth2 Code-                   -> ExceptT (OAuth2Error TR.Errors) IO OAuth2Token -- ^ Access Token-fetchAccessToken manager oa code = doJSONPostRequest manager oa uri body-                           where (uri, body) = accessTokenUrl oa code---- | Please read the docs of `fetchAccessToken`.----fetchAccessToken2 :: Manager                                   -- ^ HTTP connection manager-                   -> OAuth2                                  -- ^ OAuth Data-                   -> ExchangeToken                           -- ^ OAuth 2 Tokens-                   -> ExceptT (OAuth2Error TR.Errors) IO OAuth2Token -- ^ Access Token-fetchAccessToken2 mgr oa code = do-  let (url, body1) = accessTokenUrl oa code-  let extraBody = [-        ("client_id", T.encodeUtf8 $ oauth2ClientId oa),-        ("client_secret", T.encodeUtf8 $ oauth2ClientSecret oa)-        ]-  doJSONPostRequest mgr oa url (extraBody ++ body1)---- | Fetch a new AccessToken with the Refresh Token with authentication in request header.--- OAuth2 spec allows `client_id` and `client_secret` to--- either be sent in the header (as basic authentication)--- OR as form/url params.--- The OAuth server can choose to implement only one, or both.--- Unfortunately, there is no way for the OAuth client (i.e. this library) to--- know which method to use. Please take a look at the documentation of the--- service that you are integrating with and either use `refreshAccessToken` or `refreshAccessToken2`-refreshAccessToken :: Manager                         -- ^ HTTP connection manager.-                     -> OAuth2                       -- ^ OAuth context-                     -> RefreshToken                 -- ^ refresh token gained after authorization-                     -> ExceptT (OAuth2Error TR.Errors) IO OAuth2Token-refreshAccessToken manager oa token = doJSONPostRequest manager oa uri body-                              where (uri, body) = refreshAccessTokenUrl oa token---- | Please read the docs of `refreshAccessToken`.----refreshAccessToken2 :: Manager                         -- ^ HTTP connection manager.-                     -> OAuth2                       -- ^ OAuth context-                     -> RefreshToken                 -- ^ refresh token gained after authorization-                     -> ExceptT (OAuth2Error TR.Errors) IO OAuth2Token-refreshAccessToken2 manager oa token = do-  let (uri, body) = refreshAccessTokenUrl oa token-  let extraBody = [-        ("client_id", T.encodeUtf8 $ oauth2ClientId oa),-        ("client_secret", T.encodeUtf8 $ oauth2ClientSecret oa)-        ]-  doJSONPostRequest manager oa uri (extraBody ++ body)---- | Conduct post request and return response as JSON.-doJSONPostRequest :: (FromJSON err, FromJSON a)-                  => Manager                             -- ^ HTTP connection manager.-                  -> OAuth2                              -- ^ OAuth options-                  -> URI                                 -- ^ The URL-                  -> PostBody                            -- ^ request body-                  -> ExceptT (OAuth2Error err) IO a -- ^ Response as JSON-doJSONPostRequest manager oa uri body = do-  resp <- doSimplePostRequest manager oa uri body-  case parseResponseFlexible resp of-    Right obj -> return obj-    Left e -> throwE e---- | Conduct post request.-doSimplePostRequest :: FromJSON err => Manager                 -- ^ HTTP connection manager.-                       -> OAuth2                               -- ^ OAuth options-                       -> URI                                  -- ^ URL-                       -> PostBody                             -- ^ Request body.-                       -> ExceptT  (OAuth2Error err) IO  BSL.ByteString -- ^ Response as ByteString-doSimplePostRequest manager oa url body =-  ExceptT $ fmap handleOAuth2TokenResponse go-  where-    addBasicAuth = applyBasicAuth (T.encodeUtf8 $ oauth2ClientId oa) (T.encodeUtf8 $ oauth2ClientSecret oa)-    go = do-          req <- uriToRequest url-          let req' = (addBasicAuth . updateRequestHeaders Nothing) req-          httpLbs (urlEncodedBody body req') manager---- | Parses a @Response@ to to @OAuth2Result@-handleOAuth2TokenResponse :: FromJSON err => Response BSL.ByteString -> Either (OAuth2Error 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)-                         => BSL.ByteString-                         -> Either (OAuth2Error err) a-parseResponseFlexible r = case eitherDecode r of-                           Left _   -> parseResponseString r-                           Right x  -> Right x---- | Parses a @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String-parseResponseString :: (FromJSON err, FromJSON a)-              => BSL.ByteString-              -> Either (OAuth2Error err) a-parseResponseString 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 . KeyMap.fromList . map paramToPair-    paramToPair (k, mv) = (Key.fromText $T.decodeUtf8 k, maybe Null (String . T.decodeUtf8) mv)-    errorMessage = parseOAuth2Error b---------------------------------------------------- -- * AUTH requests--- Making request with Access Token injected into header or request body.++-- Making request with Access Token appended to Header, Request body or query string. -- --------------------------------------------------  -- | Conduct an authorized GET request and return response as JSON. --   Inject Access Token to Authorization Header.----authGetJSON :: (FromJSON b)-                 => Manager                 -- ^ HTTP connection manager.-                 -> AccessToken-                 -> URI-                 -> ExceptT BSL.ByteString IO b -- ^ Response as JSON-authGetJSON manager t uri = do-  resp <- authGetBS manager t uri-  case eitherDecode resp of-    Right obj -> return obj-    Left e -> throwE $ BSL.pack e+authGetJSON ::+  (FromJSON b) =>+  -- | HTTP connection manager.+  Manager ->+  AccessToken ->+  URI ->+  -- | Response as JSON+  ExceptT BSL.ByteString IO b+authGetJSON = authGetJSONInternal (Set.fromList [AuthInRequestHeader])+{-# DEPRECATED authGetJSON "use authGetJSONInternal" #-} +-- | Conduct an authorized GET request and return response as JSON.+--   Allow to specify how to append AccessToken.+authGetJSONInternal ::+  (FromJSON b) =>+  Set.Set APIAuthenticationMethod ->+  -- | HTTP connection manager.+  Manager ->+  AccessToken ->+  URI ->+  -- | Response as JSON+  ExceptT BSL.ByteString IO b+authGetJSONInternal authTypes manager t uri = do+  resp <- authGetBSInternal authTypes manager t uri+  either (throwE . BSL.pack) return (eitherDecode resp)+ -- | Conduct an authorized GET request. --   Inject Access Token to Authorization Header.----authGetBS :: Manager                 -- ^ HTTP connection manager.-             -> AccessToken-             -> URI-             -> ExceptT BSL.ByteString IO 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+authGetBS ::+  -- | HTTP connection manager.+  Manager ->+  AccessToken ->+  URI ->+  -- | Response as ByteString+  ExceptT BSL.ByteString IO BSL.ByteString+authGetBS = authGetBSInternal $ Set.fromList [AuthInRequestHeader]  -- | Same to 'authGetBS' but set access token to query parameter rather than header----authGetBS2 :: Manager                -- ^ HTTP connection manager.-             -> AccessToken-             -> URI-             -> ExceptT BSL.ByteString IO BSL.ByteString -- ^ Response as ByteString-authGetBS2 manager token url = do-  req <- liftIO $ uriToRequest (url `appendAccessToken` token)+authGetBS2 ::+  -- | HTTP connection manager.+  Manager ->+  AccessToken ->+  URI ->+  -- | Response as ByteString+  ExceptT BSL.ByteString IO BSL.ByteString+authGetBS2 = authGetBSInternal $ Set.fromList [AuthInRequestQuery]+{-# DEPRECATED authGetBS2 "use authGetBSInternal" #-}++-- | Conduct an authorized GET request and return response as ByteString.+--   Allow to specify how to append AccessToken.+authGetBSInternal ::+  -- |+  Set.Set APIAuthenticationMethod ->+  -- | HTTP connection manager.+  Manager ->+  AccessToken ->+  URI ->+  -- | Response as ByteString+  ExceptT BSL.ByteString IO BSL.ByteString+authGetBSInternal authTypes manager token url = do+  let appendToUrl = AuthInRequestQuery `Set.member` authTypes+  let appendToHeader = AuthInRequestHeader `Set.member` authTypes+  let uri = if appendToUrl then url `appendAccessToken` token else url+  let upReq = updateRequestHeaders (if appendToHeader then Just token else Nothing) . setMethod HT.GET+  req <- liftIO $ uriToRequest uri   authRequest req upReq manager-  where upReq = updateRequestHeaders Nothing . setMethod HT.GET  -- | Conduct POST request and return response as JSON.---   Inject Access Token to Authorization Header and request body.----authPostJSON :: (FromJSON b)-                 => Manager                 -- ^ HTTP connection manager.-                 -> AccessToken-                 -> URI-                 -> PostBody-                 -> ExceptT BSL.ByteString IO b -- ^ Response as JSON-authPostJSON manager t uri pb = do-  resp <- authPostBS manager t uri pb-  case eitherDecode resp of-    Right obj -> return obj-    Left e -> throwE $ BSL.pack e+--   Inject Access Token to Authorization Header.+authPostJSON ::+  (FromJSON b) =>+  -- | HTTP connection manager.+  Manager ->+  AccessToken ->+  URI ->+  PostBody ->+  -- | Response as JSON+  ExceptT BSL.ByteString IO b+authPostJSON = authPostJSONInternal $ Set.fromList [AuthInRequestHeader]+{-# DEPRECATED authPostJSON "use authPostJSONInternal" #-} +-- | Conduct POST request and return response as JSON.+--   Allow to specify how to append AccessToken.+authPostJSONInternal ::+  FromJSON a =>+  Set.Set APIAuthenticationMethod ->+  -- | HTTP connection manager.+  Manager ->+  AccessToken ->+  URI ->+  PostBody ->+  -- | Response as ByteString+  ExceptT BSL.ByteString IO a+authPostJSONInternal authTypes manager token url body = do+  resp <- authPostBSInternal authTypes manager token url body+  either (throwE . BSL.pack) return (eitherDecode resp)+ -- | Conduct POST request.---   Inject Access Token to http header (Authorization) and request body.----authPostBS :: Manager                -- ^ HTTP connection manager.-             -> AccessToken-             -> URI-             -> PostBody-             -> ExceptT BSL.ByteString IO BSL.ByteString -- ^ Response as ByteString-authPostBS manager token url pb = do-  req <- uriToRequest url-  authRequest req upReq manager-  where upBody = urlEncodedBody (pb ++ accessTokenToParam token)-        upHeaders = updateRequestHeaders (Just token) . setMethod HT.POST-        upReq = upHeaders . upBody+--   Inject Access Token to http header (Authorization)+authPostBS ::+  -- | HTTP connection manager.+  Manager ->+  AccessToken ->+  URI ->+  PostBody ->+  -- | Response as ByteString+  ExceptT BSL.ByteString IO BSL.ByteString+authPostBS = authPostBSInternal $ Set.fromList [AuthInRequestHeader] +-- | Conduct POST request.+--   Inject Access Token to both http header (Authorization) and request body.+authPostBS1 ::+  -- | HTTP connection manager.+  Manager ->+  AccessToken ->+  URI ->+  PostBody ->+  -- | Response as ByteString+  ExceptT BSL.ByteString IO BSL.ByteString+authPostBS1 = authPostBSInternal $ Set.fromList [AuthInRequestBody, AuthInRequestHeader]+{-# DEPRECATED authPostBS1 "use authPostBSInternal" #-}+ -- | Conduct POST request with access token only in the request body but header.----authPostBS2 :: Manager               -- ^ HTTP connection manager.-             -> AccessToken-             -> URI-             -> PostBody-             -> ExceptT BSL.ByteString IO BSL.ByteString -- ^ Response as ByteString-authPostBS2 manager token url pb = do-  req <- uriToRequest url-  authRequest req upReq manager-  where upBody = urlEncodedBody (pb ++ accessTokenToParam token)-        upHeaders = updateRequestHeaders Nothing . setMethod HT.POST-        upReq = upHeaders . upBody+authPostBS2 ::+  -- | HTTP connection manager.+  Manager ->+  AccessToken ->+  URI ->+  PostBody ->+  -- | Response as ByteString+  ExceptT BSL.ByteString IO BSL.ByteString+authPostBS2 = authPostBSInternal $ Set.fromList [AuthInRequestBody]+{-# DEPRECATED authPostBS2 "use authPostBSInternal" #-}  -- | Conduct POST request with access token only in the header and not in body-authPostBS3 :: Manager               -- ^ HTTP connection manager.-             -> AccessToken-             -> URI-             -> ExceptT BSL.ByteString IO BSL.ByteString -- ^ Response as ByteString-authPostBS3 manager token url = do+authPostBS3 ::+  -- | HTTP connection manager.+  Manager ->+  AccessToken ->+  URI ->+  PostBody ->+  -- | Response as ByteString+  ExceptT BSL.ByteString IO BSL.ByteString+authPostBS3 = authPostBSInternal $ Set.fromList [AuthInRequestHeader]+{-# DEPRECATED authPostBS3 "use authPostBSInternal" #-}++-- | Conduct POST request and return response as ByteString.+--   Allow to specify how to append AccessToken.+authPostBSInternal ::+  Set.Set APIAuthenticationMethod ->+  -- | HTTP connection manager.+  Manager ->+  AccessToken ->+  URI ->+  PostBody ->+  -- | Response as ByteString+  ExceptT BSL.ByteString IO BSL.ByteString+authPostBSInternal authTypes manager token url body = do+  let appendToBody = AuthInRequestBody `Set.member` authTypes+  let appendToHeader = AuthInRequestHeader `Set.member` authTypes+  let reqBody = if appendToBody then body ++ accessTokenToParam token else body+  -- TODO: urlEncodedBody send request as 'application/x-www-form-urlencoded'+  -- seems shall go with application/json which is more common?+  let upBody = if null reqBody then id else urlEncodedBody reqBody+  let upHeaders = updateRequestHeaders (if appendToHeader then Just token else Nothing) . setMethod HT.POST+  let upReq = upHeaders . upBody+   req <- uriToRequest url   authRequest req upReq manager-  where upBody req = req { requestBody = "null" }-        upHeaders = updateRequestHeaders (Just token) . setMethod HT.POST-        upReq = upHeaders . upBody --- |Send an HTTP request including the Authorization header with the specified---  access token.----authRequest :: Request          -- ^ Request to perform-               -> (Request -> Request)          -- ^ Modify request before sending-               -> Manager                       -- ^ HTTP connection manager.-               -> ExceptT BSL.ByteString IO BSL.ByteString-authRequest req upReq manage = ExceptT $ handleResponse <$> httpLbs (upReq req) manage- --------------------------------------------------+ -- * Utilities+ -------------------------------------------------- +-- | Send an HTTP request.+authRequest ::+  -- | Request to perform+  Request ->+  -- | Modify request before sending+  (Request -> Request) ->+  -- | HTTP connection manager.+  Manager ->+  ExceptT BSL.ByteString IO BSL.ByteString+authRequest req upReq manage = ExceptT $ handleResponse <$> httpLbs (upReq req) manage+ -- | Parses a @Response@ to to @OAuth2Result@ handleResponse :: Response BSL.ByteString -> Either BSL.ByteString BSL.ByteString handleResponse rsp =-    if HT.statusIsSuccessful (responseStatus rsp)-        then Right $ responseBody rsp-        else Left $ responseBody rsp+  if HT.statusIsSuccessful (responseStatus rsp)+    then Right $ responseBody rsp+    else -- TODO: better to surface up entire resp so that client can decide what to do when error happens.+      Left $ responseBody rsp  -- | Set several header values: --   + userAgennt    : `hoauth2`@@ -283,13 +245,24 @@ --   + authorization : 'Bearer' `xxxxx` if 'AccessToken' provided. updateRequestHeaders :: Maybe AccessToken -> Request -> Request updateRequestHeaders t req =-  let extras = [ (HT.hUserAgent, "hoauth2")-               , (HT.hAccept, "application/json") ]-      bearer = [(HT.hAuthorization, "Bearer " `BS.append` T.encodeUtf8 (atoken (fromJust t))) | isJust t]-      headers = bearer ++ extras ++ requestHeaders req-  in-  req { requestHeaders = headers }+  let bearer = [(HT.hAuthorization, "Bearer " `BS.append` T.encodeUtf8 (atoken (fromJust t))) | isJust t]+      headers = bearer ++ defaultRequestHeaders ++ requestHeaders req+   in req {requestHeaders = headers}  -- | Set the HTTP method to use. setMethod :: HT.StdMethod -> Request -> Request-setMethod m req = req { method = HT.renderStdMethod m }+setMethod m req = req {method = HT.renderStdMethod m}++-- | For `GET` method API.+appendAccessToken ::+  -- | Base URI+  URIRef a ->+  -- | Authorized Access Token+  AccessToken ->+  -- | Combined Result+  URIRef a+appendAccessToken uri t = over (queryL . queryPairsL) (\query -> query ++ accessTokenToParam t) uri++-- | Create 'QueryParams' with given access token value.+accessTokenToParam :: AccessToken -> [(BS.ByteString, BS.ByteString)]+accessTokenToParam t = [("access_token", T.encodeUtf8 $ atoken t)]

@@ -1,7 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_HADDOCK -ignore-exports #-} @@ -17,17 +17,19 @@ import Data.Binary (Binary) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL+import Data.Default import Data.Maybe import Data.Text (Text, pack, unpack) import Data.Text.Encoding+import GHC.Generics import Lens.Micro import Lens.Micro.Extras import Network.HTTP.Conduit as C import qualified Network.HTTP.Types as H+import qualified Network.HTTP.Types as HT import URI.ByteString import URI.ByteString.Aeson ()-import Data.Hashable-import GHC.Generics+import URI.ByteString.QQ  -------------------------------------------------- @@ -41,17 +43,19 @@     oauth2ClientSecret :: Text,     oauth2AuthorizeEndpoint :: URIRef Absolute,     oauth2TokenEndpoint :: URIRef Absolute,-    oauth2RedirectUri :: Maybe ( URIRef Absolute )+    oauth2RedirectUri :: URIRef Absolute   }   deriving (Show, Eq) -instance Hashable OAuth2 where-  hashWithSalt salt OAuth2{..} = salt-    `hashWithSalt` hash oauth2ClientId-    `hashWithSalt` hash oauth2ClientSecret-    `hashWithSalt` hash (show oauth2AuthorizeEndpoint)-    `hashWithSalt` hash (show oauth2TokenEndpoint)-    `hashWithSalt` hash (show oauth2RedirectUri)+instance Default OAuth2 where+  def =+    OAuth2+      { oauth2ClientId = "",+        oauth2ClientSecret = "",+        oauth2AuthorizeEndpoint = [uri|https://www.example.com/|],+        oauth2TokenEndpoint = [uri|https://www.example.com/|],+        oauth2RedirectUri = [uri|https://www.example.com/|]+      }  newtype AccessToken = AccessToken {atoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON) @@ -106,8 +110,8 @@     do       err <- (a .: "error") >>= (\str -> Right <$> parseJSON str <|> Left <$> parseJSON str)       desc <- a .:? "error_description"-      uri <- a .:? "error_uri"-      return $ OAuth2Error err desc uri+      errorUri <- a .:? "error_uri"+      return $ OAuth2Error err desc errorUri   parseJSON _ = fail "Expected an object"  instance ToJSON err => ToJSON (OAuth2Error err) where@@ -125,6 +129,20 @@     (Just $ pack $ "Error: " <> err <> "\n Original Response:\n" <> show (decodeUtf8 $ BSL.toStrict response))     Nothing +data APIAuthenticationMethod+  = -- | Provides in Authorization header+    AuthInRequestHeader+  | -- | Provides in request body+    AuthInRequestBody+  | -- | Provides in request query parameter+    AuthInRequestQuery+  deriving (Eq, Ord)++data ClientAuthenticationMethod+  = ClientSecretBasic+  | ClientSecretPost+  deriving (Eq, Ord)+ --------------------------------------------------  -- * Types Synonym@@ -138,92 +156,27 @@  -------------------------------------------------- --- * URLs+-- * Utilies  -------------------------------------------------- --- | Prepare the authorization URL.  Redirect to this URL--- asking for user interactive authentication.-authorizationUrl :: OAuth2 -> URI-authorizationUrl oa = over (queryL . queryPairsL) (++ queryParts) (oauth2AuthorizeEndpoint oa)-  where-    queryParts =-      catMaybes-        [ Just ("client_id", encodeUtf8 $ oauth2ClientId oa),-          Just ("response_type", "code"),-          fmap (("redirect_uri",) . serializeURIRef') (oauth2RedirectUri oa)-        ]---- | Prepare the URL and the request body query for fetching an access token.-accessTokenUrl ::-  OAuth2 ->-  -- | access code gained via authorization URL-  ExchangeToken ->-  -- | access token request URL plus the request body.-  (URI, PostBody)-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 ->-  -- | access code gained via authorization URL-  ExchangeToken ->-  -- | Grant Type-  Maybe Text ->-  -- | access token request URL plus the request body.-  (URI, PostBody)-accessTokenUrl' oa code gt = (uri, body)-  where-    uri = oauth2TokenEndpoint oa-    body =-      catMaybes-        [ Just ("code", encodeUtf8 $ extoken code),-          ("redirect_uri",) . serializeURIRef' <$> oauth2RedirectUri 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 ->-  -- | refresh token gained via authorization URL-  RefreshToken ->-  -- | refresh token request URL plus the request body.-  (URI, PostBody)-refreshAccessTokenUrl oa token = (uri, body)-  where-    uri = oauth2TokenEndpoint oa-    body =-      [ ("grant_type", "refresh_token"),-        ("refresh_token", encodeUtf8 $ rtoken token)-      ]---- | For `GET` method API.-appendAccessToken ::-  -- | Base URI-  URIRef a ->-  -- | Authorized Access Token-  AccessToken ->-  -- | Combined Result-  URIRef a-appendAccessToken uri t = over (queryL . queryPairsL) (\query -> query ++ accessTokenToParam t) uri---- | Create 'QueryParams' with given access token value.-accessTokenToParam :: AccessToken -> [(BS.ByteString, BS.ByteString)]-accessTokenToParam t = [("access_token", encodeUtf8 $ atoken t)]+defaultRequestHeaders :: [(HT.HeaderName, BS.ByteString)]+defaultRequestHeaders =+  [ (HT.hUserAgent, "hoauth2"),+    (HT.hAccept, "application/json")+  ]  appendQueryParams :: [(BS.ByteString, BS.ByteString)] -> URIRef a -> URIRef a appendQueryParams params =   over (queryL . queryPairsL) (params ++)  uriToRequest :: MonadThrow m => URI -> m Request-uriToRequest uri = do-  ssl <- case view (uriSchemeL . schemeBSL) uri of+uriToRequest auri = do+  ssl <- case view (uriSchemeL . schemeBSL) auri 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)+    s -> throwM $ InvalidUrlException (show auri) ("Invalid scheme: " ++ show s)+  let query = fmap (second Just) (view (queryL . queryPairsL) auri)       hostL = authorityL . _Just . authorityHostL . hostBSL       portL = authorityL . _Just . authorityPortL . _Just . portNumberL       defaultPort = (if ssl then 443 else 80) :: Int@@ -232,10 +185,10 @@         setQueryString query $           defaultRequest             { secure = ssl,-              path = view pathL uri+              path = view pathL auri             }-      req2 = (over hostLens . maybe id const . preview hostL) uri req-      req3 = (over portLens . (const . fromMaybe defaultPort) . preview portL) uri req2+      req2 = (over hostLens . maybe id const . preview hostL) auri req+      req3 = (over portLens . (const . fromMaybe defaultPort) . preview portL) auri req2   return req3  requestToUri :: Request -> URI

@@ -1,21 +1,270 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}  module Network.OAuth.OAuth2.TokenRequest where -import           Data.Aeson-import           GHC.Generics+import Control.Monad.Trans.Except+import Data.Aeson+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.ByteString.Lazy.Char8 as BSL+import qualified Data.Text.Encoding as T+import GHC.Generics+import Network.HTTP.Conduit+import qualified Network.HTTP.Types as HT+import Network.HTTP.Types.URI (parseQuery)+import Network.OAuth.OAuth2.Internal+import URI.ByteString +--------------------------------------------------++-- * Token Request Errors++--------------------------------------------------+ instance FromJSON Errors where-  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }+  parseJSON = genericParseJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}+ instance ToJSON Errors where-  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }+  toEncoding = genericToEncoding defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}  -- | Token Error Responses https://tools.ietf.org/html/rfc6749#section-5.2-data Errors =-    InvalidRequest+data Errors+  = InvalidRequest   | InvalidClient   | InvalidGrant   | UnauthorizedClient   | UnsupportedGrantType   | InvalidScope   deriving (Show, Eq, Generic)++--------------------------------------------------++-- * URL++--------------------------------------------------++-- | Prepare the URL and the request body query for fetching an access token.+accessTokenUrl ::+  OAuth2 ->+  -- | access code gained via authorization URL+  ExchangeToken ->+  -- | access token request URL plus the request body.+  (URI, PostBody)+accessTokenUrl oa code =+  let uri = oauth2TokenEndpoint oa+      body =+        [ ("code", T.encodeUtf8 $ extoken code),+          ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa),+          ("grant_type", "authorization_code")+        ]+   in (uri, body)++-- | Using a Refresh Token.  Obtain a new access token by+-- sending a refresh token to the Authorization server.+refreshAccessTokenUrl ::+  OAuth2 ->+  -- | refresh token gained via authorization URL+  RefreshToken ->+  -- | refresh token request URL plus the request body.+  (URI, PostBody)+refreshAccessTokenUrl oa token = (uri, body)+  where+    uri = oauth2TokenEndpoint oa+    body =+      [ ("grant_type", "refresh_token"),+        ("refresh_token", T.encodeUtf8 $ rtoken token)+      ]++clientSecretPost :: OAuth2 -> PostBody+clientSecretPost oa =+  [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa),+    ("client_secret", T.encodeUtf8 $ oauth2ClientSecret oa)+  ]++--------------------------------------------------++-- * Token management++--------------------------------------------------++-- | Fetch OAuth2 Token with authenticate in request header.+--+-- OAuth2 spec allows `client_id` and `client_secret` to+-- either be sent in the header (as basic authentication)+-- OR as form/url params.+-- The OAuth server can choose to implement only one, or both.+-- Unfortunately, there is no way for the OAuth client (i.e. this library) to+-- know which method to use.+-- Please take a look at the documentation of the+-- service that you are integrating with and either use `fetchAccessToken` or `fetchAccessToken2`+fetchAccessToken ::+  -- | HTTP connection manager+  Manager ->+  -- | OAuth Data+  OAuth2 ->+  -- | OAuth2 Code+  ExchangeToken ->+  -- | Access Token+  ExceptT (OAuth2Error Errors) IO OAuth2Token+fetchAccessToken = fetchAccessTokenInternal ClientSecretBasic++fetchAccessToken2 ::+  -- | HTTP connection manager+  Manager ->+  -- | OAuth Data+  OAuth2 ->+  -- | OAuth 2 Tokens+  ExchangeToken ->+  -- | Access Token+  ExceptT (OAuth2Error Errors) IO OAuth2Token+fetchAccessToken2 = fetchAccessTokenInternal ClientSecretPost+{-# DEPRECATED fetchAccessToken2 "renamed to fetchAccessTokenInternal" #-}++fetchAccessTokenInternal ::+  ClientAuthenticationMethod ->+  -- | HTTP connection manager+  Manager ->+  -- | OAuth Data+  OAuth2 ->+  -- | OAuth 2 Tokens+  ExchangeToken ->+  -- | Access Token+  ExceptT (OAuth2Error Errors) IO OAuth2Token+fetchAccessTokenInternal authMethod manager oa code = do+  let (uri, body) = accessTokenUrl oa code+  let extraBody = if authMethod == ClientSecretPost then clientSecretPost oa else []+  doJSONPostRequest manager oa uri (body ++ extraBody)++-- doJSONPostRequest append client secret to header which is needed for both+-- client_secret_post and client_secret_basic++-- | Fetch a new AccessToken with the Refresh Token with authentication in request header.+--+-- OAuth2 spec allows `client_id` and `client_secret` to+-- either be sent in the header (as basic authentication)+-- OR as form/url params.+-- The OAuth server can choose to implement only one, or both.+-- Unfortunately, there is no way for the OAuth client (i.e. this library) to+-- know which method to use. Please take a look at the documentation of the+-- service that you are integrating with and either use `refreshAccessToken` or `refreshAccessToken2`+refreshAccessToken ::+  -- | HTTP connection manager.+  Manager ->+  -- | OAuth context+  OAuth2 ->+  -- | refresh token gained after authorization+  RefreshToken ->+  ExceptT (OAuth2Error Errors) IO OAuth2Token+refreshAccessToken = refreshAccessTokenInternal ClientSecretBasic++refreshAccessToken2 ::+  -- | HTTP connection manager.+  Manager ->+  -- | OAuth context+  OAuth2 ->+  -- | refresh token gained after authorization+  RefreshToken ->+  ExceptT (OAuth2Error Errors) IO OAuth2Token+refreshAccessToken2 = refreshAccessTokenInternal ClientSecretPost+{-# DEPRECATED refreshAccessToken2 "renamed to fetchAccessTokenInternal" #-}++refreshAccessTokenInternal ::+  ClientAuthenticationMethod ->+  -- | HTTP connection manager.+  Manager ->+  -- | OAuth context+  OAuth2 ->+  -- | refresh token gained after authorization+  RefreshToken ->+  ExceptT (OAuth2Error Errors) IO OAuth2Token+refreshAccessTokenInternal authMethod manager oa token = do+  let (uri, body) = refreshAccessTokenUrl oa token+  let extraBody = if authMethod == ClientSecretPost then clientSecretPost oa else []+  doJSONPostRequest manager oa uri (body ++ extraBody)++--------------------------------------------------++-- * Utilies++--------------------------------------------------++-- | Conduct post request and return response as JSON.+doJSONPostRequest ::+  (FromJSON err, FromJSON a) =>+  -- | HTTP connection manager.+  Manager ->+  -- | OAuth options+  OAuth2 ->+  -- | The URL+  URI ->+  -- | request body+  PostBody ->+  -- | Response as JSON+  ExceptT (OAuth2Error err) IO a+doJSONPostRequest manager oa uri body = do+  resp <- doSimplePostRequest manager oa uri body+  case parseResponseFlexible resp of+    Right obj -> return obj+    Left e -> throwE e++-- | Conduct post request.+doSimplePostRequest ::+  FromJSON err =>+  -- | HTTP connection manager.+  Manager ->+  -- | OAuth options+  OAuth2 ->+  -- | URL+  URI ->+  -- | Request body.+  PostBody ->+  -- | Response as ByteString+  ExceptT (OAuth2Error err) IO BSL.ByteString+doSimplePostRequest manager oa url body =+  ExceptT $ fmap handleOAuth2TokenResponse go+  where+    addBasicAuth = applyBasicAuth (T.encodeUtf8 $ oauth2ClientId oa) (T.encodeUtf8 $ oauth2ClientSecret oa)+    go = do+      req <- uriToRequest url+      let req' = (addBasicAuth . addDefaultRequestHeaders) req+      httpLbs (urlEncodedBody body req') manager++-- | Parses a @Response@ to to @OAuth2Result@+handleOAuth2TokenResponse :: FromJSON err => Response BSL.ByteString -> Either (OAuth2Error 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) =>+  BSL.ByteString ->+  Either (OAuth2Error err) a+parseResponseFlexible r = case eitherDecode r of+  Left _ -> parseResponseString r+  Right x -> Right x++-- | Parses a @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String+parseResponseString ::+  (FromJSON err, FromJSON a) =>+  BSL.ByteString ->+  Either (OAuth2Error err) a+parseResponseString 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 . KeyMap.fromList . map paramToPair+    paramToPair (k, mv) = (Key.fromText $ T.decodeUtf8 k, maybe Null (String . T.decodeUtf8) mv)+    errorMessage = parseOAuth2Error b++-- | Set several header values:+--   + userAgennt    : `hoauth2`+--   + accept        : `application/json`+addDefaultRequestHeaders :: Request -> Request+addDefaultRequestHeaders req =+  let headers = defaultRequestHeaders ++ requestHeaders req+   in req {requestHeaders = headers}