diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,21 @@ -Copyright (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: +MIT License - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. +Copyright (c) 2022 Haisheng Wu - * 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. +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: - * 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. +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. -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. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.org b/README.org --- a/README.org +++ b/README.org @@ -1,3 +1,8 @@ * 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). +Lightweight Haskell binding for + +- [The OAuth 2.0 Authorization Framework](https://datatracker.ietf.org/doc/html/rfc6749) + - If the provider does implement [OIDC spec](https://openid.net/specs/openid-connect-core-1_0.html), + ID Token would also be included in token response (see `OAuth2Token`). +- [The OAuth 2.0 Authorization Framework: Bearer Token Usage](https://www.rfc-editor.org/rfc/rfc6750) diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/hoauth2.cabal b/hoauth2.cabal --- a/hoauth2.cabal +++ b/hoauth2.cabal @@ -1,70 +1,75 @@ -Cabal-version: 2.4 -Name: hoauth2 --- http://wiki.haskell.org/Package_versioning_policy -Version: 2.5.0 - -Synopsis: Haskell OAuth2 authentication client +cabal-version: 2.4 +name: hoauth2 -Description: Haskell OAuth2 authentication client. Tested with the following services: - . - * AzureAD: - . - * Google: - . - * Github: - . - * Facebook: - . - * Fitbit: - . - * StackExchange: - . - * DropBox: - . - * Weibo: - . - * Douban: +-- http://wiki.haskell.org/Package_versioning_policy +version: 2.6.0 +synopsis: Haskell OAuth2 authentication client +description: + Haskell OAuth2 authentication client. + . + Tutorial + . + Demo application -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 +homepage: https://github.com/freizl/hoauth2 +license: MIT +license-file: LICENSE +author: Haisheng Wu +maintainer: Haisheng Wu +copyright: Haisheng Wu +category: Network +build-type: Simple +stability: Beta +tested-with: GHC <=9.2.2 +extra-source-files: README.org -Extra-source-files: README.org +source-repository head + type: git + location: git://github.com/freizl/hoauth2.git -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 + Network.OAuth.OAuth2.AuthorizationRequest + Network.OAuth.OAuth2.HttpClient + Network.OAuth.OAuth2.Internal + Network.OAuth.OAuth2.TokenRequest + Network.OAuth2.Experiment + Network.OAuth2.Experiment.Pkce + Network.OAuth2.Experiment.Types + Network.OAuth2.Experiment.Utils -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 + default-extensions: + DataKinds + DeriveGeneric + GeneralizedNewtypeDeriving + ImportQualifiedPost + OverloadedStrings + RecordWildCards + TypeApplications + TypeFamilies - Build-Depends: base >= 4 && < 5, - data-default >= 0.7 && < 0.8, - binary >= 0.8 && < 0.9, - containers >= 0.6 && < 0.7, - text >= 0.11 && < 1.3, - bytestring >= 0.9 && < 0.12, - http-conduit >= 2.1 && < 2.4, - http-types >= 0.11 && < 0.13, - aeson >= 2.0 && < 2.2, - 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 + build-depends: + , aeson >=2.0 && <2.2 + , base >=4 && <5 + , base64 ^>=0.4 + , binary ^>=0.8 + , bytestring >=0.9 && <0.12 + , containers ^>=0.6 + , cryptonite ^>=0.30 + , data-default ^>=0.7 + , exceptions >=0.8.3 && <0.11 + , http-conduit >=2.1 && <2.4 + , http-types >=0.11 && <0.13 + , memory ^>=0.17 + , microlens ^>=0.4.0 + , text >=0.11 && <1.3 + , transformers ^>=0.5 + , uri-bytestring >=0.2.3 && <0.4 + , uri-bytestring-aeson ^>=0.1 - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields - -fno-warn-unused-do-bind -Wunused-packages + ghc-options: + -Wall -Wtabs -Wno-unused-do-bind -Wunused-packages -Wpartial-fields + -Wwarnings-deprecations diff --git a/src/Network/OAuth/OAuth2.hs b/src/Network/OAuth/OAuth2.hs --- a/src/Network/OAuth/OAuth2.hs +++ b/src/Network/OAuth/OAuth2.hs @@ -1,17 +1,6 @@ ------------------------------------------------------------- - ------------------------------------------------------------- - --- | --- 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. +-- See Readme for more details -- --- A lightweight oauth2 haskell binding. module Network.OAuth.OAuth2 ( module Network.OAuth.OAuth2.HttpClient, module Network.OAuth.OAuth2.AuthorizationRequest, @@ -22,7 +11,7 @@ {- Hiding Errors data type from default. - Shall qualified import given the naming conflicts. + Shall qualified import given the naming collision. -} import Network.OAuth.OAuth2.AuthorizationRequest hiding (Errors(..)) import Network.OAuth.OAuth2.HttpClient diff --git a/src/Network/OAuth/OAuth2/AuthorizationRequest.hs b/src/Network/OAuth/OAuth2/AuthorizationRequest.hs --- a/src/Network/OAuth/OAuth2/AuthorizationRequest.hs +++ b/src/Network/OAuth/OAuth2/AuthorizationRequest.hs @@ -1,12 +1,16 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +-- | Bindings Authorization part of The OAuth 2.0 Authorization Framework +-- RFC6749 module Network.OAuth.OAuth2.AuthorizationRequest where import Data.Aeson +import Data.Function (on) +import qualified Data.List as List import qualified Data.Text.Encoding as T -import GHC.Generics -import Lens.Micro +import GHC.Generics (Generic) +import Lens.Micro (over) import Network.OAuth.OAuth2.Internal import URI.ByteString @@ -23,7 +27,11 @@ 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 +-- I found hard time to figure a way to test the authorization error flow +-- When anything wrong in @/authorize@ request (redirect to OAuth2 provider), +-- it will end-up at the Provider page hence no way for this library to parse error response. +-- In other words, @/authorize@ ends up with 4xx or 5xx. +-- Revisit this whenever find a case OAuth2 provider redirects back to Relying party with errors. data Errors = InvalidRequest | UnauthorizedClient @@ -40,13 +48,21 @@ -------------------------------------------------- +-- | See 'authorizationUrlWithParams' +authorizationUrl :: OAuth2 -> URI +authorizationUrl = authorizationUrlWithParams [] + -- | Prepare the authorization URL. Redirect to this URL -- asking for user interactive authentication. -authorizationUrl :: OAuth2 -> URI -authorizationUrl oa = over (queryL . queryPairsL) (++ queryParts) (oauth2AuthorizeEndpoint oa) +-- +-- @since 2.6.0 +authorizationUrlWithParams :: QueryParams -> OAuth2 -> URI +authorizationUrlWithParams qs oa = over (queryL . queryPairsL) (++ queryParts) (oauth2AuthorizeEndpoint oa) where queryParts = - [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa), - ("response_type", "code"), - ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa) - ] + List.nubBy ((==) `on` fst) $ + qs + ++ [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa), + ("response_type", "code"), + ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa) + ] diff --git a/src/Network/OAuth/OAuth2/HttpClient.hs b/src/Network/OAuth/OAuth2/HttpClient.hs --- a/src/Network/OAuth/OAuth2/HttpClient.hs +++ b/src/Network/OAuth/OAuth2/HttpClient.hs @@ -2,37 +2,43 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} --- | A simple http client to request OAuth2 tokens and several utils. +-- | Bindings for The OAuth 2.0 Authorization Framework: Bearer Token Usage +-- RFC6750 module Network.OAuth.OAuth2.HttpClient ( -- * AUTH requests authGetJSON, authGetBS, authGetBS2, + authGetJSONWithAuthMethod, authGetJSONInternal, + authGetBSWithAuthMethod, authGetBSInternal, authPostJSON, authPostBS, - authPostBS1, authPostBS2, authPostBS3, + authPostJSONWithAuthMethod, authPostJSONInternal, + authPostBSWithAuthMethod, authPostBSInternal, + + -- * Types + APIAuthenticationMethod (..), ) where -import qualified Data.Set as Set -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Except -import Data.Aeson +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Except (ExceptT (..), throwE) +import Data.Aeson (FromJSON, eitherDecode) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL -import Data.Maybe +import Data.Maybe (fromJust, isJust) import qualified Data.Text.Encoding as T -import Lens.Micro +import Lens.Micro (over) import Network.HTTP.Conduit import qualified Network.HTTP.Types as HT import Network.OAuth.OAuth2.Internal -import URI.ByteString +import URI.ByteString (URI, URIRef, queryL, queryPairsL) -------------------------------------------------- @@ -45,67 +51,97 @@ -- | Conduct an authorized GET request and return response as JSON. -- Inject Access Token to Authorization Header. authGetJSON :: - (FromJSON b) => + (FromJSON a, MonadIO m) => -- | HTTP connection manager. Manager -> AccessToken -> URI -> -- | Response as JSON - ExceptT BSL.ByteString IO b -authGetJSON = authGetJSONInternal (Set.fromList [AuthInRequestHeader]) -{-# DEPRECATED authGetJSON "use authGetJSONInternal" #-} + ExceptT BSL.ByteString m a +authGetJSON = authGetJSONWithAuthMethod AuthInRequestHeader +authGetJSONInternal :: + (FromJSON a, MonadIO m) => + APIAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + -- | Response as JSON + ExceptT BSL.ByteString m a +authGetJSONInternal = authGetJSONWithAuthMethod +{-# DEPRECATED authGetJSONInternal "use authGetJSONWithAuthMethod" #-} + -- | Conduct an authorized GET request and return response as JSON. -- Allow to specify how to append AccessToken. -authGetJSONInternal :: - (FromJSON b) => - Set.Set APIAuthenticationMethod -> +-- +-- @since 2.6.0 +authGetJSONWithAuthMethod :: + (MonadIO m, FromJSON a) => + 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 + ExceptT BSL.ByteString m a +authGetJSONWithAuthMethod authTypes manager t uri = do + resp <- authGetBSWithAuthMethod authTypes manager t uri either (throwE . BSL.pack) return (eitherDecode resp) -- | Conduct an authorized GET request. -- Inject Access Token to Authorization Header. authGetBS :: + (MonadIO m) => -- | HTTP connection manager. Manager -> AccessToken -> URI -> -- | Response as ByteString - ExceptT BSL.ByteString IO BSL.ByteString -authGetBS = authGetBSInternal $ Set.fromList [AuthInRequestHeader] + ExceptT BSL.ByteString m BSL.ByteString +authGetBS = authGetBSWithAuthMethod AuthInRequestHeader -- | Same to 'authGetBS' but set access token to query parameter rather than header authGetBS2 :: + (MonadIO m) => -- | HTTP connection manager. Manager -> AccessToken -> URI -> -- | Response as ByteString - ExceptT BSL.ByteString IO BSL.ByteString -authGetBS2 = authGetBSInternal $ Set.fromList [AuthInRequestQuery] -{-# DEPRECATED authGetBS2 "use authGetBSInternal" #-} + ExceptT BSL.ByteString m BSL.ByteString +authGetBS2 = authGetBSWithAuthMethod AuthInRequestQuery +{-# DEPRECATED authGetBS2 "use authGetBSWithAuthMethod" #-} +authGetBSInternal :: + (MonadIO m) => + APIAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + -- | Response as ByteString + ExceptT BSL.ByteString m BSL.ByteString +authGetBSInternal = authGetBSWithAuthMethod +{-# DEPRECATED authGetBSInternal "use authGetBSWithAuthMethod" #-} + -- | Conduct an authorized GET request and return response as ByteString. -- Allow to specify how to append AccessToken. -authGetBSInternal :: - -- | - Set.Set APIAuthenticationMethod -> +-- +-- @since 2.6.0 +authGetBSWithAuthMethod :: + (MonadIO m) => + -- | Specify the way that how to append the 'AccessToken' in the request + 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 + ExceptT BSL.ByteString m BSL.ByteString +authGetBSWithAuthMethod authTypes manager token url = do + let appendToUrl = AuthInRequestQuery == authTypes + let appendToHeader = AuthInRequestHeader == 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 @@ -114,96 +150,116 @@ -- | Conduct POST request and return response as JSON. -- Inject Access Token to Authorization Header. authPostJSON :: - (FromJSON b) => + (FromJSON a, MonadIO m) => -- | HTTP connection manager. Manager -> AccessToken -> URI -> PostBody -> -- | Response as JSON - ExceptT BSL.ByteString IO b -authPostJSON = authPostJSONInternal $ Set.fromList [AuthInRequestHeader] -{-# DEPRECATED authPostJSON "use authPostJSONInternal" #-} + ExceptT BSL.ByteString m a +authPostJSON = authPostJSONWithAuthMethod AuthInRequestHeader --- | Conduct POST request and return response as JSON. --- Allow to specify how to append AccessToken. authPostJSONInternal :: - FromJSON a => - Set.Set APIAuthenticationMethod -> + (FromJSON a, MonadIO m) => + 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) + ExceptT BSL.ByteString m a +authPostJSONInternal = authPostJSONWithAuthMethod +{-# DEPRECATED authPostJSONInternal "use 'authPostJSONWithAuthMethod'" #-} --- | Conduct POST request. --- Inject Access Token to http header (Authorization) -authPostBS :: +-- | Conduct POST request and return response as JSON. +-- Allow to specify how to append AccessToken. +-- +-- @since 2.6.0 +authPostJSONWithAuthMethod :: + (FromJSON a, MonadIO m) => + APIAuthenticationMethod -> -- | HTTP connection manager. Manager -> AccessToken -> URI -> PostBody -> -- | Response as ByteString - ExceptT BSL.ByteString IO BSL.ByteString -authPostBS = authPostBSInternal $ Set.fromList [AuthInRequestHeader] + ExceptT BSL.ByteString m a +authPostJSONWithAuthMethod authTypes manager token url body = do + resp <- authPostBSWithAuthMethod authTypes manager token url body + either (throwE . BSL.pack) return (eitherDecode resp) -- | Conduct POST request. --- Inject Access Token to both http header (Authorization) and request body. -authPostBS1 :: +-- Inject Access Token to http header (Authorization) +authPostBS :: + (MonadIO m) => -- | 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" #-} + ExceptT BSL.ByteString m BSL.ByteString +authPostBS = authPostBSWithAuthMethod AuthInRequestHeader -- | Conduct POST request with access token only in the request body but header. authPostBS2 :: + (MonadIO m) => -- | 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" #-} + ExceptT BSL.ByteString m BSL.ByteString +authPostBS2 = authPostBSWithAuthMethod AuthInRequestBody +{-# DEPRECATED authPostBS2 "use 'authPostBSWithAuthMethod'" #-} -- | Conduct POST request with access token only in the header and not in body authPostBS3 :: + (MonadIO m) => -- | 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" #-} + ExceptT BSL.ByteString m BSL.ByteString +authPostBS3 = authPostBSWithAuthMethod AuthInRequestHeader +{-# DEPRECATED authPostBS3 "use 'authPostBSWithAuthMethod'" #-} +authPostBSInternal :: + (MonadIO m) => + APIAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + PostBody -> + -- | Response as ByteString + ExceptT BSL.ByteString m BSL.ByteString +authPostBSInternal = authPostBSWithAuthMethod +{-# DEPRECATED authPostBSInternal "use 'authPostBSWithAuthMethod'" #-} + -- | Conduct POST request and return response as ByteString. -- Allow to specify how to append AccessToken. -authPostBSInternal :: - Set.Set APIAuthenticationMethod -> +-- +-- @since 2.6.0 +authPostBSWithAuthMethod :: + (MonadIO m) => + 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 + ExceptT BSL.ByteString m BSL.ByteString +authPostBSWithAuthMethod authTypes manager token url body = do + let appendToBody = AuthInRequestBody == authTypes + let appendToHeader = AuthInRequestHeader == 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? @@ -211,27 +267,44 @@ let upHeaders = updateRequestHeaders (if appendToHeader then Just token else Nothing) . setMethod HT.POST let upReq = upHeaders . upBody - req <- uriToRequest url + req <- liftIO $ uriToRequest url authRequest req upReq manager -------------------------------------------------- +-- * Types + +-------------------------------------------------- + +-- | https://www.rfc-editor.org/rfc/rfc6750#section-2 +data APIAuthenticationMethod + = -- | Provides in Authorization header + AuthInRequestHeader + | -- | Provides in request body + AuthInRequestBody + | -- | Provides in request query parameter + AuthInRequestQuery + deriving (Eq, Ord) + +-------------------------------------------------- + -- * Utilities -------------------------------------------------- -- | Send an HTTP request. authRequest :: + (MonadIO m) => -- | Request to perform Request -> -- | Modify request before sending (Request -> Request) -> -- | HTTP connection manager. Manager -> - ExceptT BSL.ByteString IO BSL.ByteString + ExceptT BSL.ByteString m BSL.ByteString authRequest req upReq manage = ExceptT $ handleResponse <$> httpLbs (upReq req) manage --- | Parses a @Response@ to to @OAuth2Result@ +-- | Get response body out of a @Response@ handleResponse :: Response BSL.ByteString -> Either BSL.ByteString BSL.ByteString handleResponse rsp = if HT.statusIsSuccessful (responseStatus rsp) diff --git a/src/Network/OAuth/OAuth2/Internal.hs b/src/Network/OAuth/OAuth2/Internal.hs --- a/src/Network/OAuth/OAuth2/Internal.hs +++ b/src/Network/OAuth/OAuth2/Internal.hs @@ -3,10 +3,7 @@ {-# 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 @@ -63,36 +60,41 @@ newtype IdToken = IdToken {idtoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON) +-- | Authorization Code 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. +-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.4 data OAuth2Token = OAuth2Token { accessToken :: AccessToken, + -- | Exists when @offline_access@ scope is in the 'authorizeUrl' and the provider supports Refresh Access Token. refreshToken :: Maybe RefreshToken, expiresIn :: Maybe Int, + -- | See https://www.rfc-editor.org/rfc/rfc6749#section-5.1. It's required per spec. But OAuth2 provider implementation are vary. Maybe will remove 'Maybe' in future release. tokenType :: Maybe Text, + -- | Exists when @openid@ scope is in the 'authorizeUrl' and the provider supports OpenID. 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" + <$> v + .: "access_token" + <*> v + .:? "refresh_token" <*> explicitParseFieldMaybe parseIntFlexible v "expires_in" - <*> v .:? "token_type" - <*> v .:? "id_token" + <*> v + .:? "token_type" + <*> v + .:? "id_token" + where + parseIntFlexible :: Value -> Parser Int + parseIntFlexible (String s) = pure . read $ unpack s + parseIntFlexible v = parseJSON v instance ToJSON OAuth2Token where toJSON = genericToJSON defaultOptions {fieldLabelModifier = camelTo2 '_'} @@ -129,15 +131,18 @@ (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) - +-- | https://www.rfc-editor.org/rfc/rfc6749#section-2.3 +-- According to spec: +-- +-- The client MUST NOT use more than one authentication method in each request. +-- +-- Which means use Authorization header or Post body. +-- +-- However, in reality, I always have to include authentication in the header. +-- +-- In other words, 'ClientSecrectBasic' is always assured. 'ClientSecretPost' is optional. +-- +-- Maybe consider an alternative implementation that boolean kind of data type is good enough. data ClientAuthenticationMethod = ClientSecretBasic | ClientSecretPost diff --git a/src/Network/OAuth/OAuth2/TokenRequest.hs b/src/Network/OAuth/OAuth2/TokenRequest.hs --- a/src/Network/OAuth/OAuth2/TokenRequest.hs +++ b/src/Network/OAuth/OAuth2/TokenRequest.hs @@ -1,20 +1,23 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +-- | Bindings Access Token and Refresh Token part of The OAuth 2.0 Authorization Framework +-- RFC6749 module Network.OAuth.OAuth2.TokenRequest where -import Control.Monad.Trans.Except +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Except (ExceptT (..), throwE) 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 GHC.Generics (Generic) 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 +import URI.ByteString (URI, serializeURIRef') -------------------------------------------------- @@ -60,13 +63,12 @@ ] in (uri, body) --- | Using a Refresh Token. Obtain a new access token by --- sending a refresh token to the Authorization server. +-- | Obtain a new access token by sending a Refresh Token to the Authorization server. refreshAccessTokenUrl :: OAuth2 -> - -- | refresh token gained via authorization URL + -- | Refresh Token gained via authorization URL RefreshToken -> - -- | refresh token request URL plus the request body. + -- | Refresh Token request URL plus the request body. (URI, PostBody) refreshAccessTokenUrl oa token = (uri, body) where @@ -76,29 +78,15 @@ ("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` +-- | Exchange @code@ for an Access Token with authenticate in request header. fetchAccessToken :: + (MonadIO m) => -- | HTTP connection manager Manager -> -- | OAuth Data @@ -106,79 +94,124 @@ -- | OAuth2 Code ExchangeToken -> -- | Access Token - ExceptT (OAuth2Error Errors) IO OAuth2Token -fetchAccessToken = fetchAccessTokenInternal ClientSecretBasic + ExceptT (OAuth2Error Errors) m OAuth2Token +fetchAccessToken = fetchAccessTokenWithAuthMethod ClientSecretBasic fetchAccessToken2 :: + (MonadIO m) => -- | HTTP connection manager Manager -> -- | OAuth Data OAuth2 -> - -- | OAuth 2 Tokens + -- | Authorization Code ExchangeToken -> -- | Access Token - ExceptT (OAuth2Error Errors) IO OAuth2Token -fetchAccessToken2 = fetchAccessTokenInternal ClientSecretPost -{-# DEPRECATED fetchAccessToken2 "renamed to fetchAccessTokenInternal" #-} + ExceptT (OAuth2Error Errors) m OAuth2Token +fetchAccessToken2 = fetchAccessTokenWithAuthMethod ClientSecretPost +{-# DEPRECATED fetchAccessToken2 "use 'fetchAccessTokenWithAuthMethod'" #-} fetchAccessTokenInternal :: + (MonadIO m) => ClientAuthenticationMethod -> -- | HTTP connection manager Manager -> -- | OAuth Data OAuth2 -> - -- | OAuth 2 Tokens + -- | Authorization Code ExchangeToken -> -- | Access Token - ExceptT (OAuth2Error Errors) IO OAuth2Token -fetchAccessTokenInternal authMethod manager oa code = do + ExceptT (OAuth2Error Errors) m OAuth2Token +fetchAccessTokenInternal = fetchAccessTokenWithAuthMethod +{-# DEPRECATED fetchAccessTokenInternal "use 'fetchAccessTokenWithAuthMethod'" #-} + +-- | Exchange @code@ for an Access Token +-- +-- OAuth2 spec allows credential (`client_id`, `client_secret`) to be sent +-- either in the header (a.k.a 'ClientSecretBasic'). +-- or as form/url params (a.k.a 'ClientSecretPost'). +-- +-- The OAuth provider can choose to implement only one, or both. +-- Look for API document from the OAuth provider you're dealing with. +-- If you're uncertain, try 'fetchAccessToken' which sends credential +-- in authorization http header, which is common case. +-- +-- @since 2.6.0 +fetchAccessTokenWithAuthMethod :: + (MonadIO m) => + ClientAuthenticationMethod -> + -- | HTTP connection manager + Manager -> + -- | OAuth Data + OAuth2 -> + -- | Authorization Code + ExchangeToken -> + -- | Access Token + ExceptT (OAuth2Error Errors) m OAuth2Token +fetchAccessTokenWithAuthMethod 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` +-- | Fetch a new AccessToken using the Refresh Token with authentication in request header. refreshAccessToken :: + (MonadIO m) => -- | HTTP connection manager. Manager -> -- | OAuth context OAuth2 -> - -- | refresh token gained after authorization + -- | Refresh Token gained after authorization RefreshToken -> - ExceptT (OAuth2Error Errors) IO OAuth2Token -refreshAccessToken = refreshAccessTokenInternal ClientSecretBasic + ExceptT (OAuth2Error Errors) m OAuth2Token +refreshAccessToken = refreshAccessTokenWithAuthMethod ClientSecretBasic refreshAccessToken2 :: + (MonadIO m) => -- | HTTP connection manager. Manager -> -- | OAuth context OAuth2 -> - -- | refresh token gained after authorization + -- | Refresh Token gained after authorization RefreshToken -> - ExceptT (OAuth2Error Errors) IO OAuth2Token -refreshAccessToken2 = refreshAccessTokenInternal ClientSecretPost -{-# DEPRECATED refreshAccessToken2 "renamed to fetchAccessTokenInternal" #-} + ExceptT (OAuth2Error Errors) m OAuth2Token +refreshAccessToken2 = refreshAccessTokenWithAuthMethod ClientSecretPost +{-# DEPRECATED refreshAccessToken2 "use 'refreshAccessTokenWithAuthMethod'" #-} refreshAccessTokenInternal :: + (MonadIO m) => ClientAuthenticationMethod -> -- | HTTP connection manager. Manager -> -- | OAuth context OAuth2 -> - -- | refresh token gained after authorization + -- | Refresh Token gained after authorization RefreshToken -> - ExceptT (OAuth2Error Errors) IO OAuth2Token -refreshAccessTokenInternal authMethod manager oa token = do + ExceptT (OAuth2Error Errors) m OAuth2Token +refreshAccessTokenInternal = refreshAccessTokenWithAuthMethod +{-# DEPRECATED refreshAccessTokenInternal "use 'refreshAccessTokenWithAuthMethod'" #-} + +-- | Fetch a new AccessToken using the Refresh Token. +-- +-- OAuth2 spec allows credential (`client_id`, `client_secret`) to be sent +-- either in the header (a.k.a 'ClientSecretBasic'). +-- or as form/url params (a.k.a 'ClientSecretPost'). +-- +-- The OAuth provider can choose to implement only one, or both. +-- Look for API document from the OAuth provider you're dealing with. +-- If you're uncertain, try 'refreshAccessToken' which sends credential +-- in authorization http header, which is common case. +-- +-- @since 2.6.0 +refreshAccessTokenWithAuthMethod :: + (MonadIO m) => + ClientAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + -- | OAuth context + OAuth2 -> + -- | Refresh Token gained after authorization + RefreshToken -> + ExceptT (OAuth2Error Errors) m OAuth2Token +refreshAccessTokenWithAuthMethod 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) @@ -191,7 +224,7 @@ -- | Conduct post request and return response as JSON. doJSONPostRequest :: - (FromJSON err, FromJSON a) => + (MonadIO m, FromJSON err, FromJSON a) => -- | HTTP connection manager. Manager -> -- | OAuth options @@ -201,7 +234,7 @@ -- | request body PostBody -> -- | Response as JSON - ExceptT (OAuth2Error err) IO a + ExceptT (OAuth2Error err) m a doJSONPostRequest manager oa uri body = do resp <- doSimplePostRequest manager oa uri body case parseResponseFlexible resp of @@ -210,7 +243,7 @@ -- | Conduct post request. doSimplePostRequest :: - FromJSON err => + (MonadIO m, FromJSON err) => -- | HTTP connection manager. Manager -> -- | OAuth options @@ -220,9 +253,9 @@ -- | Request body. PostBody -> -- | Response as ByteString - ExceptT (OAuth2Error err) IO BSL.ByteString + ExceptT (OAuth2Error err) m BSL.ByteString doSimplePostRequest manager oa url body = - ExceptT $ fmap handleOAuth2TokenResponse go + ExceptT . liftIO $ fmap handleOAuth2TokenResponse go where addBasicAuth = applyBasicAuth (T.encodeUtf8 $ oauth2ClientId oa) (T.encodeUtf8 $ oauth2ClientSecret oa) go = do @@ -230,14 +263,14 @@ let req' = (addBasicAuth . addDefaultRequestHeaders) req httpLbs (urlEncodedBody body req') manager --- | Parses a @Response@ to to @OAuth2Result@ +-- | Gets response body from a @Response@ if 200 otherwise assume 'OAuth2Error' 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. +-- | Try to parses response as JSON, if failed, try to parse as like query string. parseResponseFlexible :: (FromJSON err, FromJSON a) => BSL.ByteString -> @@ -246,7 +279,7 @@ Left _ -> parseResponseString r Right x -> Right x --- | Parses a @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String +-- | Parses the response that contains not JSON but a Query String parseResponseString :: (FromJSON err, FromJSON a) => BSL.ByteString -> @@ -268,3 +301,10 @@ addDefaultRequestHeaders req = let headers = defaultRequestHeaders ++ requestHeaders req in req {requestHeaders = headers} + +-- | Add Credential (client_id, client_secret) to the request post body. +clientSecretPost :: OAuth2 -> PostBody +clientSecretPost oa = + [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa), + ("client_secret", T.encodeUtf8 $ oauth2ClientSecret oa) + ] diff --git a/src/Network/OAuth2/Experiment.hs b/src/Network/OAuth2/Experiment.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module contains a new way of doing OAuth2 authorization and authentication +-- in order to obtain Access Token and maybe Refresh Token base on rfc6749. +-- +-- This module will become default in future release. (TBD but likely 3.0). +-- +-- The key concept/change is to introduce the 'GrantTypeFlow', which determines the entire work flow per spec. +-- Each work flow will have slight different request parameters, which often time you'll see +-- different configuration when creating OAuth2 application in the IdP developer application page. +-- +-- Here are supported flows +-- +-- 1. Authorization Code. This flow requires authorize call to obtain an authorize code, +-- then exchange the code for tokens. +-- +-- 2. Resource Owner Password. This flow only requires to hit token endpoint with, of course, +-- username and password, to obtain tokens. +-- +-- 3. Client Credentials. This flow also only requires to hit token endpoint but with different parameters. +-- Client credentials flow does not involve an end user hence you won't be able to hit userinfo endpoint +-- with access token obtained. +-- +-- 5. PKCE (rfc7636). This is enhancement on top of authorization code flow. +-- +-- Implicit flow is not supported because it is more for SPA (single page app) +-- and more or less obsolete by Authorization Code flow with PKCE. +-- +-- Here is quick sample for how to use vocabularies from this new module. +-- +-- Firstly, initialize your IdP (use google as example) and the application. +-- +-- @ +-- data Google = Google deriving (Eq, Show) +-- googleIdp = Idp Google +-- Idp +-- { idpFetchUserInfo = authGetJSON @(IdpUserInfo Google), +-- idpAuthorizeEndpoint = [uri|https:\/\/accounts.google.com\/o\/oauth2\/v2\/auth|], +-- idpTokenEndpoint = [uri|https:\/\/oauth2.googleapis.com\/token|], +-- idpUserInfoEndpoint = [uri|https:\/\/www.googleapis.com\/oauth2\/v2\/userinfo|] +-- } +-- +-- fooApp :: IdpApplication 'AuthorizationCode Google +-- fooApp = +-- AuthorizationCodeIdpApplication +-- { idpAppClientId = "xxxxx", +-- idpAppClientSecret = "xxxxx", +-- idpAppScope = +-- Set.fromList +-- [ \"https:\/\/www.googleapis.com\/auth\/userinfo.email\", +-- \"https:\/\/www.googleapis.com\/auth\/userinfo.profile\" +-- ], +-- idpAppAuthorizeState = \"CHANGE_ME\", +-- idpAppAuthorizeExtraParams = Map.empty, +-- idpAppRedirectUri = [uri|http:\/\/localhost\/oauth2\/callback|], +-- idpAppName = "default-google-App", +-- idpAppTokenRequestAuthenticationMethod = ClientSecretBasic, +-- idp = googleIdp +-- } +-- @ +-- +-- Secondly, construct the authorize URL. +-- +-- @ +-- authorizeUrl = mkAuthorizeRequest fooApp +-- @ +-- +-- Thirdly, after a successful redirect with authorize code, +-- you could exchange for access token +-- +-- @ +-- mgr <- liftIO $ newManager tlsManagerSettings +-- tokenResp <- conduitTokenRequest fooApp mgr authorizeCode +-- @ +-- +-- Lastly, you probably like to fetch user info +-- +-- @ +-- conduitUserInfoRequest fooApp mgr (accessToken tokenResp) +-- @ +-- +-- Also you could find example from @hoauth2-providers-tutorials@ module. +-- +module Network.OAuth2.Experiment + ( module Network.OAuth2.Experiment.Types, + module Network.OAuth2.Experiment.Pkce + ) +where + +import Network.OAuth2.Experiment.Pkce +import Network.OAuth2.Experiment.Types diff --git a/src/Network/OAuth2/Experiment/Pkce.hs b/src/Network/OAuth2/Experiment/Pkce.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Pkce.hs @@ -0,0 +1,82 @@ +module Network.OAuth2.Experiment.Pkce + ( mkPkceParam, + CodeChallenge (..), + CodeVerifier (..), + CodeChallengeMethod (..), + PkceRequestParam (..), + ) +where + +import Control.Monad.IO.Class +import Crypto.Hash qualified as H +import Crypto.Random qualified as Crypto +import Data.ByteArray qualified as ByteArray +import Data.ByteString qualified as BS +import Data.ByteString.Base64.URL qualified as B64 +import Data.Text (Text) +import Data.Text.Encoding qualified as T +import Data.Word + +newtype CodeChallenge = CodeChallenge {unCodeChallenge :: Text} + +newtype CodeVerifier = CodeVerifier {unCodeVerifier :: Text} deriving (Show) + +data CodeChallengeMethod = S256 + deriving (Show) + +data PkceRequestParam = PkceRequestParam + { codeVerifier :: CodeVerifier, + codeChallenge :: CodeChallenge, + -- | spec says optional but really it shall be s256 or can be omitted? + -- https://datatracker.ietf.org/doc/html/rfc7636#section-4.3 + codeChallengeMethod :: CodeChallengeMethod + } + +mkPkceParam :: MonadIO m => m PkceRequestParam +mkPkceParam = do + codeV <- genCodeVerifier + pure + PkceRequestParam + { codeVerifier = CodeVerifier (T.decodeUtf8 codeV), + codeChallenge = CodeChallenge (encodeCodeVerifier codeV), + codeChallengeMethod = S256 + } + +encodeCodeVerifier :: BS.ByteString -> Text +encodeCodeVerifier = B64.encodeBase64Unpadded . BS.pack . ByteArray.unpack . hashSHA256 + +genCodeVerifier :: MonadIO m => m BS.ByteString +genCodeVerifier = liftIO $ getBytesInternal BS.empty + +cvMaxLen :: Int +cvMaxLen = 128 + +-- The default 'getRandomBytes' generates bytes out of unreverved characters scope. +-- code-verifier = 43*128unreserved +-- unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" +-- ALPHA = %x41-5A / %x61-7A +-- DIGIT = %x30-39 +getBytesInternal :: BS.ByteString -> IO BS.ByteString +getBytesInternal ba + | BS.length ba >= cvMaxLen = pure (BS.take cvMaxLen ba) + | otherwise = do + bs <- Crypto.getRandomBytes cvMaxLen + let bsUnreserved = ba `BS.append` BS.filter isUnreversed bs + getBytesInternal bsUnreserved + +hashSHA256 :: BS.ByteString -> H.Digest H.SHA256 +hashSHA256 = H.hash + +isUnreversed :: Word8 -> Bool +isUnreversed w = w `BS.elem` unreverseBS + +{- +a-z: 97-122 +A-Z: 65-90 +-: 45 +.: 46 +_: 95 +~: 126 +-} +unreverseBS :: BS.ByteString +unreverseBS = BS.pack $ [97 .. 122] ++ [65 .. 90] ++ [45, 46, 95, 126] diff --git a/src/Network/OAuth2/Experiment/Types.hs b/src/Network/OAuth2/Experiment/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Types.hs @@ -0,0 +1,693 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Network.OAuth2.Experiment.Types where + +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Except (ExceptT) +import Data.Aeson (FromJSON) +import Data.Bifunctor +import Data.ByteString.Lazy.Char8 qualified as BSL +import Data.Default (Default (def)) +import Data.Kind +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Data.String +import Data.Text.Encoding qualified as T +import Data.Text.Lazy (Text) +import Data.Text.Lazy qualified as TL +import Network.HTTP.Conduit (Manager) +import Network.OAuth.OAuth2 hiding (RefreshToken) +import Network.OAuth.OAuth2 qualified as OAuth2 +import Network.OAuth.OAuth2.TokenRequest qualified as TR +import Network.OAuth2.Experiment.Pkce +import Network.OAuth2.Experiment.Utils +import URI.ByteString hiding (UserInfo) + +{- NOTE + 1. shall I lift the constrain of all 'a :: GrantTypeFlow' so that user has max customization/flexibility? +-} + +------------------------------------------------------------------------------- + +-- * Grant Type + +------------------------------------------------------------------------------- + +data GrantTypeFlow = AuthorizationCode | ResourceOwnerPassword | ClientCredentials + +------------------------------------------------------------------------------- + +-- * Response Type value + +------------------------------------------------------------------------------- + +class ToResponseTypeValue (a :: GrantTypeFlow) where + toResponseTypeValue :: IsString b => b + +instance ToResponseTypeValue 'AuthorizationCode where + -- https://www.rfc-editor.org/rfc/rfc6749#section-3.1.1 + -- Only support "authorization code" flow + toResponseTypeValue :: IsString b => b + toResponseTypeValue = "code" + +toResponseTypeParam :: forall a b req. (ToResponseTypeValue a, IsString b) => req a -> Map b b +toResponseTypeParam _ = Map.singleton "response_type" (toResponseTypeValue @a) + +------------------------------------------------------------------------------- + +-- * Grant Type value + +------------------------------------------------------------------------------- + +-- | Grant type query parameter has association with 'GrantTypeFlow' but not completely strict. +-- +-- e.g. Both 'AuthorizationCode' and 'ResourceOwnerPassword' flow could support refresh token flow. +data GrantTypeValue = GTAuthorizationCode | GTPassword | GTClientCredentials | GTRefreshToken + deriving (Eq, Show) + +------------------------------------------------------------------------------- + +-- * Scope + +------------------------------------------------------------------------------- + +-- TODO: following data type is not ideal as Idp would have lots of 'Custom Text' +-- +-- @ +-- data Scope = OPENID | PROFILE | EMAIL | OFFLINE_ACCESS | Custom Text +-- @ +-- +-- Would be nice to define Enum for standard Scope, plus allow user to define their own define (per Idp) and plugin somehow. +newtype Scope = Scope {unScope :: Text} + deriving (Show, Eq, Ord) + +instance IsString Scope where + fromString :: String -> Scope + fromString = Scope . TL.pack + +------------------------------------------------------------------------------- + +-- * Credentials + +------------------------------------------------------------------------------- +newtype ClientId = ClientId {unClientId :: Text} + deriving (Show, Eq, IsString) + +newtype ClientSecret = ClientSecret {unClientSecret :: Text} + deriving (Eq, IsString) + +-- | In order to reuse some methods from legacy "Network.OAuth.OAuth2". +-- Will be removed when Experiment module becomes default. +toOAuth2Key :: ClientId -> ClientSecret -> OAuth2 +toOAuth2Key cid csecret = + def + { oauth2ClientId = TL.toStrict $ unClientId cid, + oauth2ClientSecret = TL.toStrict $ unClientSecret csecret + } + +newtype RedirectUri = RedirectUri {unRedirectUri :: URI} + deriving (Eq) + +newtype AuthorizeState = AuthorizeState {unAuthorizeState :: Text} + deriving (Eq) + +instance IsString AuthorizeState where + fromString :: String -> AuthorizeState + fromString = AuthorizeState . TL.pack + +newtype Username = Username {unUsername :: Text} + deriving (Eq) + +instance IsString Username where + fromString :: String -> Username + fromString = Username . TL.pack + +newtype Password = Password {unPassword :: Text} + deriving (Eq) + +instance IsString Password where + fromString :: String -> Password + fromString = Password . TL.pack + +------------------------------------------------------------------------------- + +-- * Query parameters + +------------------------------------------------------------------------------- +class ToQueryParam a where + toQueryParam :: a -> Map Text Text + +instance ToQueryParam a => ToQueryParam (Maybe a) where + toQueryParam :: ToQueryParam a => Maybe a -> Map Text Text + toQueryParam Nothing = Map.empty + toQueryParam (Just a) = toQueryParam a + +instance ToQueryParam GrantTypeValue where + toQueryParam :: GrantTypeValue -> Map Text Text + toQueryParam x = Map.singleton "grant_type" (val x) + where + val :: GrantTypeValue -> Text + val GTAuthorizationCode = "authorization_code" + val GTPassword = "password" + val GTClientCredentials = "client_credentials" + val GTRefreshToken = "refresh_token" + +instance ToQueryParam ClientId where + toQueryParam :: ClientId -> Map Text Text + toQueryParam (ClientId i) = Map.singleton "client_id" i + +instance ToQueryParam ClientSecret where + toQueryParam :: ClientSecret -> Map Text Text + toQueryParam (ClientSecret x) = Map.singleton "client_secret" x + +instance ToQueryParam Username where + toQueryParam :: Username -> Map Text Text + toQueryParam (Username x) = Map.singleton "username" x + +instance ToQueryParam Password where + toQueryParam :: Password -> Map Text Text + toQueryParam (Password x) = Map.singleton "password" x + +instance ToQueryParam AuthorizeState where + toQueryParam :: AuthorizeState -> Map Text Text + toQueryParam (AuthorizeState x) = Map.singleton "state" x + +instance ToQueryParam RedirectUri where + toQueryParam (RedirectUri uri) = Map.singleton "redirect_uri" (bs8ToLazyText $ serializeURIRef' uri) + +instance ToQueryParam (Set Scope) where + toQueryParam :: Set Scope -> Map Text Text + toQueryParam = toScopeParam . Set.map unScope + where + toScopeParam :: (IsString a) => Set Text -> Map a Text + toScopeParam scope = Map.singleton "scope" (TL.intercalate " " $ Set.toList scope) + +instance ToQueryParam CodeVerifier where + toQueryParam :: CodeVerifier -> Map Text Text + toQueryParam (CodeVerifier x) = Map.singleton "code_verifier" (TL.fromStrict x) + +instance ToQueryParam CodeChallenge where + toQueryParam :: CodeChallenge -> Map Text Text + toQueryParam (CodeChallenge x) = Map.singleton "code_challenge" (TL.fromStrict x) + +instance ToQueryParam CodeChallengeMethod where + toQueryParam :: CodeChallengeMethod -> Map Text Text + toQueryParam x = Map.singleton "code_challenge_method" (TL.pack $ show x) + +instance ToQueryParam ExchangeToken where + toQueryParam :: ExchangeToken -> Map Text Text + toQueryParam (ExchangeToken x) = Map.singleton "code" (TL.fromStrict x) + +instance ToQueryParam OAuth2.RefreshToken where + toQueryParam :: OAuth2.RefreshToken -> Map Text Text + toQueryParam (OAuth2.RefreshToken x) = Map.singleton "refresh_token" (TL.fromStrict x) + +------------------------------------------------------------------------------- + +-- * Authorization and Token Requests types + +------------------------------------------------------------------------------- + +class HasIdpAppName (a :: GrantTypeFlow) where + getIdpAppName :: IdpApplication a i -> Text + +class HasAuthorizeRequest (a :: GrantTypeFlow) where + data AuthorizationRequest a + type MkAuthorizationRequestResponse a + mkAuthorizeRequestParameter :: IdpApplication a i -> AuthorizationRequest a + mkAuthorizeRequest :: IdpApplication a i -> MkAuthorizationRequestResponse a + +class HasTokenRequest (a :: GrantTypeFlow) where + -- | Each GrantTypeFlow has slightly different request parameter to /token endpoint. + data TokenRequest a + + -- | Only 'AuthorizationCode flow (but not resource owner password nor client credentials) will use 'ExchangeToken' in the token request + -- create type family to be explicit on it. + -- with 'type instance WithExchangeToken a b = b' implies no exchange token + -- v.s. 'type instance WithExchangeToken a b = ExchangeToken -> b' implies needing an exchange token + type WithExchangeToken a b + + mkTokenRequest :: + IdpApplication a i -> + WithExchangeToken a (TokenRequest a) + + conduitTokenRequest :: + (MonadIO m) => + IdpApplication a i -> + Manager -> + WithExchangeToken a (ExceptT (OAuth2Error TR.Errors) m OAuth2Token) + +class HasPkceAuthorizeRequest (a :: GrantTypeFlow) where + mkPkceAuthorizeRequest :: MonadIO m => IdpApplication a i -> m (TL.Text, CodeVerifier) + +class HasPkceTokenRequest (b :: GrantTypeFlow) where + conduitPkceTokenRequest :: + (MonadIO m) => + IdpApplication b i -> + Manager -> + (ExchangeToken, CodeVerifier) -> + ExceptT (OAuth2Error TR.Errors) m OAuth2Token + +class HasRefreshTokenRequest (a :: GrantTypeFlow) where + -- | https://www.rfc-editor.org/rfc/rfc6749#page-47 + data RefreshTokenRequest a + + mkRefreshTokenRequest :: IdpApplication a i -> OAuth2.RefreshToken -> RefreshTokenRequest a + conduitRefreshTokenRequest :: + (MonadIO m) => + IdpApplication a i -> + Manager -> + OAuth2.RefreshToken -> + ExceptT (OAuth2Error TR.Errors) m OAuth2Token + +------------------------------------------------------------------------------- + +-- * User Info types + +------------------------------------------------------------------------------- + +type family IdpUserInfo a + +class HasUserInfoRequest (a :: GrantTypeFlow) where + conduitUserInfoRequest :: + FromJSON (IdpUserInfo i) => + IdpApplication a i -> + Manager -> + AccessToken -> + ExceptT BSL.ByteString IO (IdpUserInfo i) + +------------------------------------------------------------------------------- + +-- * Idp App + +------------------------------------------------------------------------------- + +-- | Shall IdpApplication has a field of 'Idp a'?? +data Idp a = Idp + { idpUserInfoEndpoint :: URI, + -- NOTE: maybe worth data type to distinguish authorize and token endpoint + -- as I made mistake at passing to Authorize and Token Request + idpAuthorizeEndpoint :: URI, + idpTokenEndpoint :: URI, + idpFetchUserInfo :: + forall m. + (FromJSON (IdpUserInfo a), MonadIO m) => + Manager -> + AccessToken -> + URI -> + ExceptT BSL.ByteString m (IdpUserInfo a) + } + +------------------------------------------------------------------------------- + +-- * Idp App Config + +------------------------------------------------------------------------------- + +data family IdpApplication (a :: GrantTypeFlow) (i :: Type) + +------------------------------------------------------------------------------- + +-- * Authorization Code flow + +------------------------------------------------------------------------------- + +-- | An Application that supports "Authorization code" flow +data instance IdpApplication 'AuthorizationCode i = AuthorizationCodeIdpApplication + { idpAppName :: Text, + idpAppClientId :: ClientId, + idpAppClientSecret :: ClientSecret, + idpAppScope :: Set Scope, + idpAppRedirectUri :: URI, + idpAppAuthorizeState :: AuthorizeState, + -- | Though technically one key can have multiple value in query, but who actually does it?! + idpAppAuthorizeExtraParams :: Map Text Text, + idpAppTokenRequestAuthenticationMethod :: ClientAuthenticationMethod, + idp :: Idp i + } + +-- NOTE: maybe add function for parase authorization response +-- though seems overkill. https://github.com/freizl/hoauth2/issues/149 +-- parseAuthorizationResponse :: String -> AuthorizationResponse +-- parseAuthorizationResponse :: ( String, String ) -> AuthorizationResponse + +instance HasIdpAppName 'AuthorizationCode where + getIdpAppName :: IdpApplication 'AuthorizationCode i -> Text + getIdpAppName AuthorizationCodeIdpApplication {..} = idpAppName + +instance HasAuthorizeRequest 'AuthorizationCode where + -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.1.1 + data AuthorizationRequest 'AuthorizationCode = AuthorizationCodeAuthorizationRequest + { scope :: Set Scope, + state :: AuthorizeState, + clientId :: ClientId, + redirectUri :: Maybe RedirectUri + } + type MkAuthorizationRequestResponse 'AuthorizationCode = Text + + mkAuthorizeRequestParameter :: IdpApplication 'AuthorizationCode i -> AuthorizationRequest 'AuthorizationCode + mkAuthorizeRequestParameter AuthorizationCodeIdpApplication {..} = + AuthorizationCodeAuthorizationRequest + { scope = if null idpAppScope then Set.empty else idpAppScope, + state = idpAppAuthorizeState, + clientId = idpAppClientId, + redirectUri = Just (RedirectUri idpAppRedirectUri) + } + + mkAuthorizeRequest :: IdpApplication 'AuthorizationCode i -> Text + mkAuthorizeRequest idpAppConfig@AuthorizationCodeIdpApplication {..} = + let req = mkAuthorizeRequestParameter idpAppConfig + allParams = + map (bimap tlToBS tlToBS) $ + Map.toList $ + Map.unions [idpAppAuthorizeExtraParams, toQueryParam req] + in TL.fromStrict $ + T.decodeUtf8 $ + serializeURIRef' $ + appendQueryParams allParams $ + idpAuthorizeEndpoint idp + +instance HasTokenRequest 'AuthorizationCode where + -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3 + data TokenRequest 'AuthorizationCode = AuthorizationCodeTokenRequest + { code :: ExchangeToken, + clientId :: ClientId, + grantType :: GrantTypeValue, + redirectUri :: RedirectUri + } + type WithExchangeToken 'AuthorizationCode a = ExchangeToken -> a + + mkTokenRequest :: + IdpApplication 'AuthorizationCode i -> + ExchangeToken -> + TokenRequest 'AuthorizationCode + mkTokenRequest AuthorizationCodeIdpApplication {..} authCode = + AuthorizationCodeTokenRequest + { code = authCode, + clientId = idpAppClientId, + grantType = GTAuthorizationCode, + redirectUri = RedirectUri idpAppRedirectUri + } + conduitTokenRequest :: + forall m i. + (MonadIO m) => + IdpApplication 'AuthorizationCode i -> + Manager -> + ExchangeToken -> + ExceptT (OAuth2Error TR.Errors) m OAuth2Token + conduitTokenRequest idpAppConfig@AuthorizationCodeIdpApplication {..} mgr exchangeToken = + let req = mkTokenRequest idpAppConfig exchangeToken + key = toOAuth2Key idpAppClientId idpAppClientSecret + body = + mapsToParams + [ toQueryParam req, + toQueryParam + ( if idpAppTokenRequestAuthenticationMethod == ClientSecretPost + then Just idpAppClientSecret + else Nothing + ) + ] + in doJSONPostRequest mgr key (idpTokenEndpoint idp) body + +instance HasPkceAuthorizeRequest 'AuthorizationCode where + mkPkceAuthorizeRequest :: MonadIO m => IdpApplication 'AuthorizationCode i -> m (Text, CodeVerifier) + mkPkceAuthorizeRequest idpAppConfig@AuthorizationCodeIdpApplication {..} = do + PkceRequestParam {..} <- mkPkceParam + let req = mkAuthorizeRequestParameter idpAppConfig + let allParams = + mapsToParams + [ idpAppAuthorizeExtraParams, + toQueryParam req, + toQueryParam codeChallenge, + toQueryParam codeChallengeMethod + ] + + let url = + TL.fromStrict $ + T.decodeUtf8 $ + serializeURIRef' $ + appendQueryParams allParams $ + idpAuthorizeEndpoint idp + pure (url, codeVerifier) + +instance HasPkceTokenRequest 'AuthorizationCode where + conduitPkceTokenRequest :: + MonadIO m => + IdpApplication 'AuthorizationCode i -> + Manager -> + (ExchangeToken, CodeVerifier) -> + ExceptT (OAuth2Error TR.Errors) m OAuth2Token + conduitPkceTokenRequest idpAppConfig@AuthorizationCodeIdpApplication {..} mgr (exchangeToken, codeVerifier) = + let req = mkTokenRequest idpAppConfig exchangeToken + key = toOAuth2Key idpAppClientId idpAppClientSecret + body = + mapsToParams + [ toQueryParam req, + toQueryParam codeVerifier, + toQueryParam (if idpAppTokenRequestAuthenticationMethod == ClientSecretPost then Just idpAppClientSecret else Nothing) + ] + in doJSONPostRequest mgr key (idpTokenEndpoint idp) body + +instance HasRefreshTokenRequest 'AuthorizationCode where + data RefreshTokenRequest 'AuthorizationCode = AuthorizationCodeTokenRefreshRequest + { refreshToken :: OAuth2.RefreshToken, + grantType :: GrantTypeValue, + scope :: Set Scope + } + + mkRefreshTokenRequest :: IdpApplication 'AuthorizationCode i -> OAuth2.RefreshToken -> RefreshTokenRequest 'AuthorizationCode + mkRefreshTokenRequest AuthorizationCodeIdpApplication {..} rt = + AuthorizationCodeTokenRefreshRequest + { scope = idpAppScope, + grantType = GTRefreshToken, + refreshToken = rt + } + conduitRefreshTokenRequest :: + (MonadIO m) => + IdpApplication 'AuthorizationCode i -> + Manager -> + OAuth2.RefreshToken -> + ExceptT (OAuth2Error TR.Errors) m OAuth2Token + conduitRefreshTokenRequest idpAppConfig@AuthorizationCodeIdpApplication {..} mgr rt = + let req = mkRefreshTokenRequest idpAppConfig rt + key = toOAuth2Key idpAppClientId idpAppClientSecret + body = + mapsToParams + [ toQueryParam req, + toQueryParam (if idpAppTokenRequestAuthenticationMethod == ClientSecretPost then Just idpAppClientSecret else Nothing) + ] + in doJSONPostRequest mgr key (idpTokenEndpoint idp) body + +instance HasUserInfoRequest 'AuthorizationCode where + conduitUserInfoRequest :: + FromJSON (IdpUserInfo i) => + IdpApplication 'AuthorizationCode i -> + Manager -> + AccessToken -> + ExceptT BSL.ByteString IO (IdpUserInfo i) + conduitUserInfoRequest AuthorizationCodeIdpApplication {..} mgr at = do + idpFetchUserInfo idp mgr at (idpUserInfoEndpoint idp) + +instance ToQueryParam (AuthorizationRequest 'AuthorizationCode) where + toQueryParam :: AuthorizationRequest 'AuthorizationCode -> Map Text Text + toQueryParam req@AuthorizationCodeAuthorizationRequest {..} = + Map.unions + [ toResponseTypeParam req, + toQueryParam scope, + toQueryParam clientId, + toQueryParam state, + toQueryParam redirectUri + ] + +instance ToQueryParam (TokenRequest 'AuthorizationCode) where + toQueryParam :: TokenRequest 'AuthorizationCode -> Map Text Text + toQueryParam AuthorizationCodeTokenRequest {..} = + Map.unions + [ toQueryParam grantType, + toQueryParam code, + toQueryParam redirectUri + ] + +instance ToQueryParam (RefreshTokenRequest 'AuthorizationCode) where + toQueryParam :: RefreshTokenRequest 'AuthorizationCode -> Map Text Text + toQueryParam AuthorizationCodeTokenRefreshRequest {..} = + Map.unions + [ toQueryParam grantType, + toQueryParam scope, + toQueryParam refreshToken + ] + +------------------------------------------------------------------------------- + +-- * Password flow + +------------------------------------------------------------------------------- + +-- https://www.rfc-editor.org/rfc/rfc6749#section-4.3.1 +-- 4.3.1. Authorization Request and Response (Password grant type) +-- The method through which the client obtains the resource owner +-- credentials is beyond the scope of this specification. The client +-- MUST discard the credentials once an access token has been obtained. +-- +-- Hence no AuhorizationRequest instance + +data instance IdpApplication 'ResourceOwnerPassword i = ResourceOwnerPasswordIDPAppConfig + { idpAppClientId :: ClientId, + idpAppClientSecret :: ClientSecret, + idpAppName :: Text, + idpAppScope :: Set Scope, + idpAppUserName :: Username, + idpAppPassword :: Password, + -- | Any parameter that required by your Idp and not mentioned in the OAuth2 spec + idpAppTokenRequestExtraParams :: Map Text Text, + idp :: Idp i + } + +instance HasIdpAppName 'ResourceOwnerPassword where + getIdpAppName :: IdpApplication 'ResourceOwnerPassword i -> Text + getIdpAppName ResourceOwnerPasswordIDPAppConfig {..} = idpAppName + +instance HasUserInfoRequest 'ResourceOwnerPassword where + conduitUserInfoRequest ResourceOwnerPasswordIDPAppConfig {..} mgr at = do + idpFetchUserInfo idp mgr at (idpUserInfoEndpoint idp) + +instance HasTokenRequest 'ResourceOwnerPassword where + -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.3.2 + data TokenRequest 'ResourceOwnerPassword = PasswordTokenRequest + { scope :: Set Scope, + username :: Username, + password :: Password, + grantType :: GrantTypeValue + } + type WithExchangeToken 'ResourceOwnerPassword a = a + + mkTokenRequest :: IdpApplication 'ResourceOwnerPassword i -> TokenRequest 'ResourceOwnerPassword + mkTokenRequest ResourceOwnerPasswordIDPAppConfig {..} = + PasswordTokenRequest + { username = idpAppUserName, + password = idpAppPassword, + grantType = GTPassword, + scope = idpAppScope + } + + conduitTokenRequest :: + (MonadIO m) => + IdpApplication 'ResourceOwnerPassword i -> + Manager -> + ExceptT (OAuth2Error TR.Errors) m OAuth2Token + conduitTokenRequest idpAppConfig@ResourceOwnerPasswordIDPAppConfig {..} mgr = + let req = mkTokenRequest idpAppConfig + key = toOAuth2Key idpAppClientId idpAppClientSecret + body = mapsToParams [idpAppTokenRequestExtraParams, toQueryParam req] + in doJSONPostRequest mgr key (idpTokenEndpoint idp) body + +-- | TODO: TBD +instance HasRefreshTokenRequest 'ResourceOwnerPassword where + data RefreshTokenRequest 'ResourceOwnerPassword = PasswordRefreshTokenRequest + + mkRefreshTokenRequest :: + IdpApplication 'ResourceOwnerPassword i -> + OAuth2.RefreshToken -> + RefreshTokenRequest 'ResourceOwnerPassword + mkRefreshTokenRequest = undefined + + conduitRefreshTokenRequest :: + MonadIO m => + IdpApplication 'ResourceOwnerPassword i -> + Manager -> + OAuth2.RefreshToken -> + ExceptT (OAuth2Error TR.Errors) m OAuth2Token + conduitRefreshTokenRequest = undefined + +instance ToQueryParam (TokenRequest 'ResourceOwnerPassword) where + toQueryParam :: TokenRequest 'ResourceOwnerPassword -> Map Text Text + toQueryParam PasswordTokenRequest {..} = + Map.unions + [ toQueryParam grantType, + toQueryParam scope, + toQueryParam username, + toQueryParam password + ] + +------------------------------------------------------------------------------- + +-- * Client Credentials flow + +------------------------------------------------------------------------------- + +-- https://www.rfc-editor.org/rfc/rfc6749#section-4.4.1 +-- 4.4.1. Authorization Request and Response (Client Credentials grant type) +-- Since the client authentication is used as the authorization grant, +-- no additional authorization request is needed. +-- +-- Hence no AuhorizationRequest instance + +data instance IdpApplication 'ClientCredentials i = ClientCredentialsIDPAppConfig + { idpAppClientId :: ClientId, + idpAppClientSecret :: ClientSecret, + idpAppName :: Text, + idpAppScope :: Set Scope, + -- | Any parameter that required by your Idp and not mentioned in the OAuth2 spec + idpAppTokenRequestExtraParams :: Map Text Text, + idp :: Idp i + } + +instance HasIdpAppName 'ClientCredentials where + getIdpAppName :: IdpApplication 'ClientCredentials i -> Text + getIdpAppName ClientCredentialsIDPAppConfig {..} = idpAppName + +instance HasTokenRequest 'ClientCredentials where + -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.4.2 + data TokenRequest 'ClientCredentials = ClientCredentialsTokenRequest + { scope :: Set Scope, + grantType :: GrantTypeValue + } + + type WithExchangeToken 'ClientCredentials a = a + + mkTokenRequest :: IdpApplication 'ClientCredentials i -> TokenRequest 'ClientCredentials + mkTokenRequest ClientCredentialsIDPAppConfig {..} = + ClientCredentialsTokenRequest + { scope = idpAppScope, + grantType = GTClientCredentials + } + + conduitTokenRequest :: + (MonadIO m) => + IdpApplication 'ClientCredentials i -> + Manager -> + ExceptT (OAuth2Error TR.Errors) m OAuth2Token + conduitTokenRequest idpAppConfig@ClientCredentialsIDPAppConfig {..} mgr = + let req = mkTokenRequest idpAppConfig + key = + toOAuth2Key + idpAppClientId + idpAppClientSecret + body = + mapsToParams + [ idpAppTokenRequestExtraParams, + toQueryParam req + ] + in doJSONPostRequest mgr key (idpTokenEndpoint idp) body + +instance ToQueryParam (TokenRequest 'ClientCredentials) where + toQueryParam :: TokenRequest 'ClientCredentials -> Map Text Text + toQueryParam ClientCredentialsTokenRequest {..} = + Map.unions + [ toQueryParam grantType, + toQueryParam scope + ] diff --git a/src/Network/OAuth2/Experiment/Utils.hs b/src/Network/OAuth2/Experiment/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Utils.hs @@ -0,0 +1,21 @@ +module Network.OAuth2.Experiment.Utils where + +import Data.Bifunctor +import Data.ByteString (ByteString) +import Data.ByteString.Char8 qualified as BS8 +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text.Encoding qualified as TE +import Data.Text.Lazy qualified as TL + +tlToBS :: TL.Text -> ByteString +tlToBS = TE.encodeUtf8 . TL.toStrict + +bs8ToLazyText :: BS8.ByteString -> TL.Text +bs8ToLazyText = TL.pack . BS8.unpack + +mapsToParams :: [Map TL.Text TL.Text] -> [(ByteString, ByteString)] +mapsToParams = + map (bimap tlToBS tlToBS) + . Map.toList + . Map.unions