hoauth2-2.3.0/0000755000000000000000000000000007346545000011257 5ustar0000000000000000hoauth2-2.3.0/LICENSE0000644000000000000000000000276707346545000012300 0ustar0000000000000000Copyright (c)2012-present, Haisheng Wu All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Haisheng Wu nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. hoauth2-2.3.0/README.org0000644000000000000000000000027507346545000012731 0ustar0000000000000000* Introduction A mixed Haskell binding of [OAuth2 spec](https://datatracker.ietf.org/doc/html/rfc6749) and a little bit [OIDC spec](https://openid.net/specs/openid-connect-core-1_0.html). hoauth2-2.3.0/Setup.hs0000644000000000000000000000005607346545000012714 0ustar0000000000000000import Distribution.Simple main = defaultMain hoauth2-2.3.0/hoauth2.cabal0000644000000000000000000000540007346545000013614 0ustar0000000000000000Cabal-version: 2.4 Name: hoauth2 -- http://wiki.haskell.org/Package_versioning_policy Version: 2.3.0 Synopsis: Haskell OAuth2 authentication client Description: Haskell OAuth2 authentication client. Tested with the following services: . * AzureAD: . * Google: . * Github: . * Facebook: . * Fitbit: . * StackExchange: . * DropBox: . * Weibo: . * Douban: Homepage: https://github.com/freizl/hoauth2 License: BSD-3-Clause License-file: LICENSE Author: Haisheng Wu Maintainer: Haisheng Wu Copyright: Haisheng Wu Category: Network Build-type: Simple Stability: Beta Tested-With: GHC <= 8.10.7 Extra-source-files: README.org Source-Repository head Type: git Location: git://github.com/freizl/hoauth2.git Library hs-source-dirs: src default-language: Haskell2010 Exposed-modules: Network.OAuth.OAuth2.HttpClient Network.OAuth.OAuth2.Internal Network.OAuth.OAuth2 Network.OAuth.OAuth2.TokenRequest 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, uri-bytestring >= 0.2.3 && < 0.4, uri-bytestring-aeson >= 0.1 && < 0.2, microlens >= 0.4.0 && < 0.5, exceptions >= 0.8.3 && < 0.11 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind -Wunused-packages hoauth2-2.3.0/src/Network/OAuth/0000755000000000000000000000000007346545000014517 5ustar0000000000000000hoauth2-2.3.0/src/Network/OAuth/OAuth2.hs0000644000000000000000000000170307346545000016156 0ustar0000000000000000------------------------------------------------------------ ------------------------------------------------------------ -- | -- Module : Network.OAuth.OAuth2 -- Description : OAuth2 client -- Copyright : (c) 2012 Haisheng Wu -- License : BSD-style (see the file LICENSE) -- Maintainer : Haisheng Wu -- Stability : Beta -- Portability : portable -- -- A lightweight oauth2 haskell binding. module Network.OAuth.OAuth2 ( module Network.OAuth.OAuth2.HttpClient, module Network.OAuth.OAuth2.AuthorizationRequest, module Network.OAuth.OAuth2.TokenRequest, module Network.OAuth.OAuth2.Internal, ) where {- 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(..)) hoauth2-2.3.0/src/Network/OAuth/OAuth2/0000755000000000000000000000000007346545000015621 5ustar0000000000000000hoauth2-2.3.0/src/Network/OAuth/OAuth2/AuthorizationRequest.hs0000644000000000000000000000311007346545000022361 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module Network.OAuth.OAuth2.AuthorizationRequest where 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} instance ToJSON Errors where 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 | UnauthorizedClient | AccessDenied | UnsupportedResponseType | InvalidScope | 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) ] hoauth2-2.3.0/src/Network/OAuth/OAuth2/HttpClient.hs0000644000000000000000000002104207346545000020232 0ustar0000000000000000{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- | A simple http client to request OAuth2 tokens and several utils. 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 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 -------------------------------------------------- -- * AUTH requests -- 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) => -- | 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 :: -- | 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 :: -- | 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 -- | Conduct POST request and return response as JSON. -- 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) 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 :: -- | 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 :: -- | 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 -------------------------------------------------- -- * 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 -- 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` -- + accept : `application/json` -- + authorization : 'Bearer' `xxxxx` if 'AccessToken' provided. updateRequestHeaders :: Maybe AccessToken -> Request -> Request updateRequestHeaders t req = 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} -- | 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)] hoauth2-2.3.0/src/Network/OAuth/OAuth2/Internal.hs0000644000000000000000000001525107346545000017735 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_HADDOCK -ignore-exports #-} -- | A simple OAuth2 Haskell binding. (This is supposed to be -- independent of the http client used.) module Network.OAuth.OAuth2.Internal where import Control.Applicative import Control.Arrow (second) import Control.Monad.Catch import Data.Aeson 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.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 URI.ByteString.QQ -------------------------------------------------- -- * Data Types -------------------------------------------------- -- | Query Parameter Representation data OAuth2 = OAuth2 { oauth2ClientId :: Text, oauth2ClientSecret :: Text, oauth2AuthorizeEndpoint :: URIRef Absolute, oauth2TokenEndpoint :: URIRef Absolute, oauth2RedirectUri :: URIRef Absolute } deriving (Show, Eq) 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) newtype RefreshToken = RefreshToken {rtoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON) newtype IdToken = IdToken {idtoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON) newtype ExchangeToken = ExchangeToken {extoken :: Text} deriving (Show, FromJSON, ToJSON) -- | The gained Access Token. Use @Data.Aeson.decode@ to -- decode string to @AccessToken@. The @refreshToken@ is -- special in some cases, -- e.g. data OAuth2Token = OAuth2Token { accessToken :: AccessToken, refreshToken :: Maybe RefreshToken, expiresIn :: Maybe Int, tokenType :: Maybe Text, idToken :: Maybe IdToken } deriving (Eq, Show, Generic) instance Binary OAuth2Token parseIntFlexible :: Value -> Parser Int parseIntFlexible (String s) = pure . read $ unpack s parseIntFlexible v = parseJSON v -- | Parse JSON data into 'OAuth2Token' instance FromJSON OAuth2Token where parseJSON = withObject "OAuth2Token" $ \v -> OAuth2Token <$> v .: "access_token" <*> v .:? "refresh_token" <*> explicitParseFieldMaybe parseIntFlexible v "expires_in" <*> v .:? "token_type" <*> v .:? "id_token" instance ToJSON OAuth2Token where toJSON = genericToJSON defaultOptions {fieldLabelModifier = camelTo2 '_'} toEncoding = genericToEncoding defaultOptions {fieldLabelModifier = camelTo2 '_'} data OAuth2Error a = OAuth2Error { error :: Either Text a, errorDescription :: Maybe Text, errorUri :: Maybe (URIRef Absolute) } deriving (Show, Eq, Generic) instance FromJSON err => FromJSON (OAuth2Error err) where parseJSON (Object a) = do err <- (a .: "error") >>= (\str -> Right <$> parseJSON str <|> Left <$> parseJSON str) desc <- a .:? "error_description" errorUri <- a .:? "error_uri" return $ OAuth2Error err desc errorUri parseJSON _ = fail "Expected an object" instance ToJSON err => ToJSON (OAuth2Error err) where toJSON = genericToJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True} toEncoding = genericToEncoding defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True} parseOAuth2Error :: FromJSON err => BSL.ByteString -> OAuth2Error err parseOAuth2Error string = either (mkDecodeOAuth2Error string) id (eitherDecode string) mkDecodeOAuth2Error :: BSL.ByteString -> String -> OAuth2Error err mkDecodeOAuth2Error response err = OAuth2Error (Left "Decode error") (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 -------------------------------------------------- -- | type synonym of post body content type PostBody = [(BS.ByteString, BS.ByteString)] type QueryParams = [(BS.ByteString, BS.ByteString)] -------------------------------------------------- -- * Utilies -------------------------------------------------- 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 auri = do ssl <- case view (uriSchemeL . schemeBSL) auri of "http" -> return False "https" -> return True 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 req = setQueryString query $ defaultRequest { secure = ssl, path = view pathL auri } 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 requestToUri req = URI ( Scheme ( if secure req then "https" else "http" ) ) (Just (Authority Nothing (Host $ host req) (Just $ Port $ port req))) (path req) (Query $ H.parseSimpleQuery $ queryString req) Nothing hostLens :: Lens' Request BS.ByteString hostLens f req = f (C.host req) <&> \h' -> req {C.host = h'} {-# INLINE hostLens #-} portLens :: Lens' Request Int portLens f req = f (C.port req) <&> \p' -> req {C.port = p'} {-# INLINE portLens #-} hoauth2-2.3.0/src/Network/OAuth/OAuth2/TokenRequest.hs0000644000000000000000000002116407346545000020612 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module Network.OAuth.OAuth2.TokenRequest where 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} instance ToJSON Errors where toEncoding = genericToEncoding defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True} -- | Token Error Responses https://tools.ietf.org/html/rfc6749#section-5.2 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}