hoauth2-2.10.0/0000755000000000000000000000000007346545000011335 5ustar0000000000000000hoauth2-2.10.0/LICENSE0000644000000000000000000000205407346545000012343 0ustar0000000000000000MIT License Copyright (c) 2022 Haisheng Wu 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: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 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. hoauth2-2.10.0/README.org0000644000000000000000000000103107346545000012776 0ustar0000000000000000* Introduction Haskell binding for - [[https://datatracker.ietf.org/doc/html/rfc6749][The OAuth 2.0 Authorization Framework]] - If the Identity Provider also implements [[https://openid.net/specs/openid-connect-core-1_0.html][OIDC spec]], ID Token will also be present in token response (see ~OAuth2Token~). - [[https://www.rfc-editor.org/rfc/rfc7523.html][JWT Profile for OAuth2 Client Authentication and Authorization Grants]] - [[https://www.rfc-editor.org/rfc/rfc6750][The OAuth 2.0 Authorization Framework: Bearer Token Usage]] hoauth2-2.10.0/hoauth2.cabal0000644000000000000000000000672407346545000013704 0ustar0000000000000000cabal-version: 2.4 name: hoauth2 -- http://wiki.haskell.org/Package_versioning_policy version: 2.10.0 synopsis: Haskell OAuth2 authentication client description: This is Haskell binding of OAuth2 Authorization framework and Bearer Token Usage framework. 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.6.1 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 autogen-modules: Paths_hoauth2 other-modules: Network.HTTP.Client.Contrib Network.OAuth.OAuth2.Internal Network.OAuth2.Experiment.Grants Network.OAuth2.Experiment.Utils Paths_hoauth2 exposed-modules: Network.OAuth.OAuth2 Network.OAuth.OAuth2.AuthorizationRequest Network.OAuth.OAuth2.HttpClient Network.OAuth.OAuth2.TokenRequest Network.OAuth2.Experiment Network.OAuth2.Experiment.Flows.AuthorizationRequest Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest Network.OAuth2.Experiment.Flows.RefreshTokenRequest Network.OAuth2.Experiment.Flows.TokenRequest Network.OAuth2.Experiment.Flows.UserInfoRequest Network.OAuth2.Experiment.Grants.AuthorizationCode Network.OAuth2.Experiment.Grants.ClientCredentials Network.OAuth2.Experiment.Grants.DeviceAuthorization Network.OAuth2.Experiment.Grants.JwtBearer Network.OAuth2.Experiment.Grants.ResourceOwnerPassword Network.OAuth2.Experiment.Pkce Network.OAuth2.Experiment.Types default-extensions: DeriveGeneric GeneralizedNewtypeDeriving ImportQualifiedPost InstanceSigs OverloadedStrings PolyKinds RecordWildCards TypeFamilies 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.18 , microlens ^>=0.4.0 , text >=2.0 && <2.3 , transformers >=0.4 && <0.7 , uri-bytestring >=0.2.3 && <0.4 , uri-bytestring-aeson ^>=0.1 ghc-options: -Wall -Wtabs -Wno-unused-do-bind -Wunused-packages -Wpartial-fields -Wwarn -Wwarnings-deprecations test-suite hoauth-tests type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: test ghc-options: -Wall build-depends: , aeson >=2.0 && <2.2 , base >=4 && <5 , hoauth2 , hspec >=2 && <3 , uri-bytestring >=0.2.3 && <0.4 other-modules: Network.OAuth.OAuth2.TokenRequestSpec default-language: Haskell2010 default-extensions: ImportQualifiedPost OverloadedStrings build-tool-depends: hspec-discover:hspec-discover >=2 && <3 ghc-options: -Wall -Wtabs -Wno-unused-do-bind -Wunused-packages -Wpartial-fields -Wwarn -Wwarnings-deprecations hoauth2-2.10.0/src/Network/HTTP/Client/0000755000000000000000000000000007346545000015552 5ustar0000000000000000hoauth2-2.10.0/src/Network/HTTP/Client/Contrib.hs0000644000000000000000000000176307346545000017515 0ustar0000000000000000module Network.HTTP.Client.Contrib where import Data.Aeson import Data.Bifunctor import Data.ByteString.Lazy.Char8 qualified as BSL import Network.HTTP.Conduit import Network.HTTP.Types qualified as HT -- | Get response body out of a @Response@ handleResponse :: Response BSL.ByteString -> Either BSL.ByteString BSL.ByteString handleResponse rsp | HT.statusIsSuccessful (responseStatus rsp) = Right (responseBody rsp) -- TODO: better to surface up entire resp so that client can decide what to do when error happens. -- e.g. when 404, the response body could be empty hence library user has no idea what's happening. -- Which will be breaking changes. -- The current work around is surface up entire response as string. | BSL.null (responseBody rsp) = Left (BSL.pack $ show rsp) | otherwise = Left (responseBody rsp) handleResponseJSON :: FromJSON a => Response BSL.ByteString -> Either BSL.ByteString a handleResponseJSON = either Left (first BSL.pack . eitherDecode) . handleResponse hoauth2-2.10.0/src/Network/OAuth/0000755000000000000000000000000007346545000014575 5ustar0000000000000000hoauth2-2.10.0/src/Network/OAuth/OAuth2.hs0000644000000000000000000000133507346545000016235 0ustar0000000000000000-- | A lightweight oauth2 Haskell binding. -- See Readme for more details module Network.OAuth.OAuth2 ( module Network.OAuth.OAuth2.Internal, -- * Authorization Requset module Network.OAuth.OAuth2.AuthorizationRequest, -- * Token Request module Network.OAuth.OAuth2.TokenRequest, -- * OAuth'ed http client utilities module Network.OAuth.OAuth2.HttpClient, ) where {- Hiding Errors data type from default. Shall qualified import given the naming collision. -} import Network.OAuth.OAuth2.AuthorizationRequest hiding ( AuthorizationResponseError (..), AuthorizationResponseErrorCode (..), ) import Network.OAuth.OAuth2.HttpClient import Network.OAuth.OAuth2.Internal import Network.OAuth.OAuth2.TokenRequest hoauth2-2.10.0/src/Network/OAuth/OAuth2/0000755000000000000000000000000007346545000015677 5ustar0000000000000000hoauth2-2.10.0/src/Network/OAuth/OAuth2/AuthorizationRequest.hs0000644000000000000000000000616507346545000022454 0ustar0000000000000000-- | 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 Data.List qualified as List import Data.Text (Text) import Data.Text.Encoding qualified as T import Lens.Micro (over) import Network.OAuth.OAuth2.Internal import URI.ByteString import Prelude hiding (error) -------------------------------------------------- -- * Authorization Request Errors -------------------------------------------------- -- | Authorization Code Grant Error Responses https://tools.ietf.org/html/rfc6749#section-4.1.2.1 -- -- I found hard time to figure a way to test the authorization error flow -- When anything wrong in @/authorize@ request, it will stuck 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 AuthorizationResponseError = AuthorizationResponseError { authorizationResponseError :: AuthorizationResponseErrorCode , authorizationResponseErrorDescription :: Maybe Text , authorizationResponseErrorUri :: Maybe (URIRef Absolute) } deriving (Show, Eq) data AuthorizationResponseErrorCode = InvalidRequest | UnauthorizedClient | AccessDenied | UnsupportedResponseType | InvalidScope | ServerError | TemporarilyUnavailable | UnknownErrorCode Text deriving (Show, Eq) instance FromJSON AuthorizationResponseErrorCode where parseJSON = withText "parseJSON AuthorizationResponseErrorCode" $ \t -> pure $ case t of "invalid_request" -> InvalidRequest "unauthorized_client" -> UnauthorizedClient "access_denied" -> AccessDenied "unsupported_response_type" -> UnsupportedResponseType "invalid_scope" -> InvalidScope "server_error" -> ServerError "temporarily_unavailable" -> TemporarilyUnavailable _ -> UnknownErrorCode t instance FromJSON AuthorizationResponseError where parseJSON = withObject "parseJSON AuthorizationResponseError" $ \t -> do authorizationResponseError <- t .: "error" authorizationResponseErrorDescription <- t .:? "error_description" authorizationResponseErrorUri <- t .:? "error_uri" pure AuthorizationResponseError {..} -------------------------------------------------- -- * URLs -------------------------------------------------- -- | See 'authorizationUrlWithParams' authorizationUrl :: OAuth2 -> URI authorizationUrl = authorizationUrlWithParams [] -- | Prepare the authorization URL. Redirect to this URL -- asking for user interactive authentication. -- -- @since 2.6.0 authorizationUrlWithParams :: QueryParams -> OAuth2 -> URI authorizationUrlWithParams qs oa = over (queryL . queryPairsL) (++ queryParts) (oauth2AuthorizeEndpoint oa) where queryParts = List.nubBy ((==) `on` fst) $ qs ++ [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa) , ("response_type", "code") , ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa) ] hoauth2-2.10.0/src/Network/OAuth/OAuth2/HttpClient.hs0000644000000000000000000002361507346545000020320 0ustar0000000000000000-- | 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, authPostBS2, authPostBS3, authPostJSONWithAuthMethod, authPostJSONInternal, authPostBSWithAuthMethod, authPostBSInternal, -- * Types APIAuthenticationMethod (..), ) where import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except (ExceptT (..), throwE) import Data.Aeson (FromJSON, eitherDecode) import Data.ByteString.Char8 qualified as BS import Data.ByteString.Lazy.Char8 qualified as BSL import Data.Maybe (fromJust, isJust) import Data.Text.Encoding qualified as T import Lens.Micro (over) import Network.HTTP.Client.Contrib (handleResponse) import Network.HTTP.Conduit import Network.HTTP.Types qualified as HT import Network.OAuth.OAuth2.Internal import URI.ByteString (URI, URIRef, queryL, queryPairsL) -------------------------------------------------- -- * 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 :: (MonadIO m, FromJSON a) => -- | HTTP connection manager. Manager -> AccessToken -> URI -> -- | Response as JSON ExceptT BSL.ByteString m a authGetJSON = authGetJSONWithAuthMethod AuthInRequestHeader -- | Deprecated. Use `authGetJSONWithAuthMethod` instead. authGetJSONInternal :: (MonadIO m, FromJSON a) => 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. -- -- @since 2.6.0 authGetJSONWithAuthMethod :: (MonadIO m, FromJSON a) => APIAuthenticationMethod -> -- | HTTP connection manager. Manager -> AccessToken -> URI -> -- | Response as JSON 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 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 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. -- -- @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 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 authRequest req upReq manager -- | Conduct POST request and return response as JSON. -- Inject Access Token to Authorization Header. authPostJSON :: (MonadIO m, FromJSON a) => -- | HTTP connection manager. Manager -> AccessToken -> URI -> PostBody -> -- | Response as JSON ExceptT BSL.ByteString m a authPostJSON = authPostJSONWithAuthMethod AuthInRequestHeader authPostJSONInternal :: (MonadIO m, FromJSON a) => APIAuthenticationMethod -> -- | HTTP connection manager. Manager -> AccessToken -> URI -> PostBody -> -- | Response as ByteString ExceptT BSL.ByteString m a authPostJSONInternal = authPostJSONWithAuthMethod {-# DEPRECATED authPostJSONInternal "use 'authPostJSONWithAuthMethod'" #-} -- | Conduct POST request and return response as JSON. -- Allow to specify how to append AccessToken. -- -- @since 2.6.0 authPostJSONWithAuthMethod :: (MonadIO m, FromJSON a) => APIAuthenticationMethod -> -- | HTTP connection manager. Manager -> AccessToken -> URI -> PostBody -> -- | Response as ByteString 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 http header (Authorization) authPostBS :: MonadIO m => -- | HTTP connection manager. Manager -> AccessToken -> URI -> PostBody -> -- | Response as ByteString 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 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 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. -- -- @since 2.6.0 authPostBSWithAuthMethod :: MonadIO m => APIAuthenticationMethod -> -- | HTTP connection manager. Manager -> AccessToken -> URI -> PostBody -> -- | Response as ByteString 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? 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 <- 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 m BSL.ByteString authRequest req upReq manage = ExceptT $ do resp <- httpLbs (upReq req) manage pure (handleResponse resp) -- | Set several header values: -- + userAgennt : "hoauth2" -- + accept : "application/json" -- + authorization : "Bearer xxxxx" if 'Network.OAuth.OAuth2.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.10.0/src/Network/OAuth/OAuth2/Internal.hs0000644000000000000000000001444107346545000020013 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} module Network.OAuth.OAuth2.Internal where import Control.Arrow (second) import Control.Monad.Catch import Data.Aeson import Data.Aeson.Types (Parser, explicitParseFieldMaybe) import Data.Binary (Binary) import Data.ByteString qualified as BS import Data.ByteString.Char8 qualified as BS8 import Data.Default import Data.Maybe import Data.Text (Text, unpack) import Data.Version (showVersion) import GHC.Generics import Lens.Micro import Lens.Micro.Extras import Network.HTTP.Conduit as C import Network.HTTP.Types qualified as H import Network.HTTP.Types qualified as HT import Paths_hoauth2 (version) import URI.ByteString import URI.ByteString.Aeson () import URI.ByteString.QQ ------------------------------------------------------------------------------- -- * OAuth2 Configuration ------------------------------------------------------------------------------- -- | 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/|] } ------------------------------------------------------------------------------- -- * Tokens ------------------------------------------------------------------------------- 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) -- | Authorization Code newtype ExchangeToken = ExchangeToken {extoken :: Text} deriving (Show, FromJSON, ToJSON) -- FIXME: rename to TokenResponse and move to that module -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.4 data OAuth2Token = OAuth2Token { accessToken :: AccessToken , refreshToken :: Maybe RefreshToken -- ^ Exists when @offline_access@ scope is in the Authorization Request and the provider supports Refresh Access Token. , expiresIn :: Maybe Int , tokenType :: Maybe Text -- ^ 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. , idToken :: Maybe IdToken -- ^ Exists when @openid@ scope is in the Authorization Request and the provider supports OpenID protocol. } deriving (Eq, Show, Generic) instance Binary OAuth2Token -- | 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" 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 '_'} toEncoding = genericToEncoding defaultOptions {fieldLabelModifier = camelTo2 '_'} ------------------------------------------------------------------------------- -- * Client Authentication methods ------------------------------------------------------------------------------- -- | 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, I found I have to include authentication in the header all the time in real world. -- -- In other words, `ClientSecretBasic` is always assured. `ClientSecretPost` is optional. -- -- Maybe consider an alternative implementation that boolean kind of data type is good enough. data ClientAuthenticationMethod = ClientSecretBasic | ClientSecretPost | ClientAssertionJwt deriving (Eq) ------------------------------------------------------------------------------- -- * Utilies for Request and URI ------------------------------------------------------------------------------- -- | Type synonym of post body content type PostBody = [(BS.ByteString, BS.ByteString)] -- | Type sysnonym of request query params type QueryParams = [(BS.ByteString, BS.ByteString)] defaultRequestHeaders :: [(HT.HeaderName, BS.ByteString)] defaultRequestHeaders = [ (HT.hUserAgent, "hoauth2-" <> BS8.pack (showVersion version)) , (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.10.0/src/Network/OAuth/OAuth2/TokenRequest.hs0000644000000000000000000002604607346545000020674 0ustar0000000000000000-- | Bindings Access Token and Refresh Token part of The OAuth 2.0 Authorization Framework -- RFC6749 module Network.OAuth.OAuth2.TokenRequest where import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except (ExceptT (..), throwE) import Data.Aeson import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KeyMap import Data.ByteString.Lazy.Char8 qualified as BSL import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T import Network.HTTP.Conduit import Network.HTTP.Types qualified as HT import Network.HTTP.Types.URI (parseQuery) import Network.OAuth.OAuth2.Internal import URI.ByteString import Prelude hiding (error) -------------------------------------------------- -- * Token Request Errors -------------------------------------------------- data TokenResponseError = TokenResponseError { tokenResponseError :: TokenResponseErrorCode , tokenResponseErrorDescription :: Maybe Text , tokenResponseErrorUri :: Maybe (URIRef Absolute) } deriving (Show, Eq) -- | Token Error Responses https://tools.ietf.org/html/rfc6749#section-5.2 data TokenResponseErrorCode = InvalidRequest | InvalidClient | InvalidGrant | UnauthorizedClient | UnsupportedGrantType | InvalidScope | UnknownErrorCode Text deriving (Show, Eq) instance FromJSON TokenResponseErrorCode where parseJSON = withText "parseJSON TokenResponseErrorCode" $ \t -> pure $ case t of "invalid_request" -> InvalidRequest "invalid_client" -> InvalidClient "invalid_grant" -> InvalidGrant "unauthorized_client" -> UnauthorizedClient "unsupported_grant_type" -> UnsupportedGrantType "invalid_scope" -> InvalidScope _ -> UnknownErrorCode t instance FromJSON TokenResponseError where parseJSON = withObject "parseJSON TokenResponseError" $ \t -> do tokenResponseError <- t .: "error" tokenResponseErrorDescription <- t .:? "error_description" tokenResponseErrorUri <- t .:? "error_uri" pure TokenResponseError {..} parseTokeResponseError :: BSL.ByteString -> TokenResponseError parseTokeResponseError string = either (mkDecodeOAuth2Error string) id (eitherDecode string) where mkDecodeOAuth2Error :: BSL.ByteString -> String -> TokenResponseError mkDecodeOAuth2Error response err = TokenResponseError (UnknownErrorCode "") (Just $ T.pack $ "Decode TokenResponseError failed: " <> err <> "\n Original Response:\n" <> show (T.decodeUtf8 $ BSL.toStrict response)) Nothing -------------------------------------------------- -- * 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) -- | 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) ] -------------------------------------------------- -- * Token management -------------------------------------------------- -- | Exchange @code@ for an Access Token with authenticate in request header. fetchAccessToken :: MonadIO m => -- | HTTP connection manager Manager -> -- | OAuth Data OAuth2 -> -- | OAuth2 Code ExchangeToken -> -- | Access Token ExceptT TokenResponseError m OAuth2Token fetchAccessToken = fetchAccessTokenWithAuthMethod ClientSecretBasic fetchAccessToken2 :: MonadIO m => -- | HTTP connection manager Manager -> -- | OAuth Data OAuth2 -> -- | Authorization Code ExchangeToken -> -- | Access Token ExceptT TokenResponseError m OAuth2Token fetchAccessToken2 = fetchAccessTokenWithAuthMethod ClientSecretPost {-# DEPRECATED fetchAccessToken2 "use 'fetchAccessTokenWithAuthMethod'" #-} fetchAccessTokenInternal :: MonadIO m => ClientAuthenticationMethod -> -- | HTTP connection manager Manager -> -- | OAuth Data OAuth2 -> -- | Authorization Code ExchangeToken -> -- | Access Token ExceptT TokenResponseError 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 TokenResponseError 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) -- | 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 RefreshToken -> ExceptT TokenResponseError m OAuth2Token refreshAccessToken = refreshAccessTokenWithAuthMethod ClientSecretBasic refreshAccessToken2 :: MonadIO m => -- | HTTP connection manager. Manager -> -- | OAuth context OAuth2 -> -- | Refresh Token gained after authorization RefreshToken -> ExceptT TokenResponseError 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 RefreshToken -> ExceptT TokenResponseError 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 TokenResponseError 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) -------------------------------------------------- -- * Utilies -------------------------------------------------- -- | Conduct post request and return response as JSON. doJSONPostRequest :: (MonadIO m, FromJSON a) => -- | HTTP connection manager. Manager -> -- | OAuth options OAuth2 -> -- | The URL URI -> -- | request body PostBody -> -- | Response as JSON ExceptT TokenResponseError m 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 :: MonadIO m => -- | HTTP connection manager. Manager -> -- | OAuth options OAuth2 -> -- | URL URI -> -- | Request body. PostBody -> -- | Response as ByteString ExceptT TokenResponseError m BSL.ByteString doSimplePostRequest manager oa url body = ExceptT . liftIO $ fmap handleOAuth2TokenResponse go where go = do req <- uriToRequest url let req' = (addBasicAuth oa . addDefaultRequestHeaders) req httpLbs (urlEncodedBody body req') manager -- | Gets response body from a @Response@ if 200 otherwise assume 'Network.OAuth.OAuth2.TokenRequest.TokenResponseError' handleOAuth2TokenResponse :: Response BSL.ByteString -> Either TokenResponseError BSL.ByteString handleOAuth2TokenResponse rsp = if HT.statusIsSuccessful (responseStatus rsp) then Right $ responseBody rsp else Left $ parseTokeResponseError (responseBody rsp) -- | Try to parses response as JSON, if failed, try to parse as like query string. parseResponseFlexible :: FromJSON a => BSL.ByteString -> Either TokenResponseError a parseResponseFlexible r = case eitherDecode r of Left _ -> parseResponseString r Right x -> Right x -- | Parses the response that contains not JSON but a Query String parseResponseString :: FromJSON a => BSL.ByteString -> Either TokenResponseError 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 = parseTokeResponseError b -- | Add Basic Authentication header using client_id and client_secret. addBasicAuth :: OAuth2 -> Request -> Request addBasicAuth oa = applyBasicAuth (T.encodeUtf8 $ oauth2ClientId oa) (T.encodeUtf8 $ oauth2ClientSecret oa) -- | Set several header values: -- + userAgennt : "hoauth2" -- + accept : "application/json" addDefaultRequestHeaders :: Request -> Request 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) ] hoauth2-2.10.0/src/Network/OAuth2/0000755000000000000000000000000007346545000014657 5ustar0000000000000000hoauth2-2.10.0/src/Network/OAuth2/Experiment.hs0000644000000000000000000001231007346545000017330 0ustar0000000000000000-- | 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. -- -- The key concept/change is to introduce the Grant flow, 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) -- given it is deprecated 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. -- -- @ -- -- import Network.OAuth2.Experiment -- import URI.ByteString.QQ -- -- data Google = Google deriving (Eq, Show) -- -- googleIdp :: Idp Google -- googleIdp = -- Idp -- { 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|] -- , idpDeviceAuthorizationEndpoint = Just [uri|https:\/\/oauth2.googleapis.com\/device\/code|] -- } -- -- fooApp :: AuthorizationCodeApplication -- fooApp = -- AuthorizationCodeApplication -- { acClientId = "xxxxx", -- acClientSecret = "xxxxx", -- acScope = -- Set.fromList -- [ \"https:\/\/www.googleapis.com\/auth\/userinfo.email\", -- \"https:\/\/www.googleapis.com\/auth\/userinfo.profile\" -- ], -- acAuthorizeState = \"CHANGE_ME\", -- acAuthorizeRequestExtraParams = Map.empty, -- acRedirectUri = [uri|http:\/\/localhost\/oauth2\/callback|], -- acName = "sample-google-authorization-code-app", -- acTokenRequestAuthenticationMethod = ClientSecretBasic, -- } -- -- fooIdpApplication :: IdpApplication AuthorizationCodeApplication Google -- fooIdpApplication = IdpApplication fooApp googleIdp -- @ -- -- Secondly, construct the authorize URL. -- -- @ -- authorizeUrl = mkAuthorizationRequest fooIdpApplication -- @ -- -- Thirdly, after a successful redirect with authorize code, -- you could exchange for access token -- -- @ -- mgr <- liftIO $ newManager tlsManagerSettings -- tokenResp <- conduitTokenRequest fooIdpApplication mgr authorizeCode -- @ -- -- If you'd like to fetch user info, uses this method -- -- @ -- conduitUserInfoRequest fooIdpApplication mgr (accessToken tokenResp) -- @ -- -- You could also find example from @hoauth2-providers-tutorials@ module. module Network.OAuth2.Experiment ( -- * Application per Grant type module Network.OAuth2.Experiment.Grants, -- * Authorization Code module Network.OAuth2.Experiment.Flows.AuthorizationRequest, -- * Device Authorization module Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest, -- * Token Request module Network.OAuth2.Experiment.Flows.TokenRequest, -- * Refresh Token Request module Network.OAuth2.Experiment.Flows.RefreshTokenRequest, -- * UserInfo Request module Network.OAuth2.Experiment.Flows.UserInfoRequest, -- * Types module Network.OAuth2.Experiment.Types, module Network.OAuth2.Experiment.Pkce, module Network.OAuth.OAuth2, -- * Utils module Network.OAuth2.Experiment.Utils, ) where import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..)) import Network.OAuth2.Experiment.Flows.AuthorizationRequest ( HasAuthorizeRequest, mkAuthorizationRequest, mkPkceAuthorizeRequest, ) import Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest ( DeviceAuthorizationResponse (..), HasDeviceAuthorizationRequest, conduitDeviceAuthorizationRequest, ) import Network.OAuth2.Experiment.Flows.RefreshTokenRequest ( HasRefreshTokenRequest, conduitRefreshTokenRequest, ) import Network.OAuth2.Experiment.Flows.TokenRequest ( ExchangeTokenInfo, HasTokenRequest, NoNeedExchangeToken (..), TokenRequest, conduitPkceTokenRequest, conduitTokenRequest, ) import Network.OAuth2.Experiment.Flows.UserInfoRequest ( HasUserInfoRequest, conduitUserInfoRequest, conduitUserInfoRequestWithCustomMethod, ) import Network.OAuth2.Experiment.Grants import Network.OAuth2.Experiment.Pkce ( CodeVerifier (..), ) import Network.OAuth2.Experiment.Types ( AuthorizeState (..), ClientId (..), ClientSecret (..), HasOAuth2Key, Idp (..), IdpApplication (..), Password (..), RedirectUri (..), Scope (..), Username (..), ) import Network.OAuth2.Experiment.Utils (uriToText) hoauth2-2.10.0/src/Network/OAuth2/Experiment/Flows/0000755000000000000000000000000007346545000020071 5ustar0000000000000000hoauth2-2.10.0/src/Network/OAuth2/Experiment/Flows/AuthorizationRequest.hs0000644000000000000000000000577707346545000024656 0ustar0000000000000000module Network.OAuth2.Experiment.Flows.AuthorizationRequest where import Control.Monad.IO.Class (MonadIO (..)) import Data.Bifunctor import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Text.Lazy (Text) import Network.OAuth.OAuth2 hiding (RefreshToken) import Network.OAuth2.Experiment.Pkce import Network.OAuth2.Experiment.Types import Network.OAuth2.Experiment.Utils import URI.ByteString hiding (UserInfo) ------------------------------------------------------------------------------- -- Authorization Request -- ------------------------------------------------------------------------------- data AuthorizationRequestParam = AuthorizationRequestParam { arScope :: Set Scope , arState :: AuthorizeState , arClientId :: ClientId , arRedirectUri :: Maybe RedirectUri , arResponseType :: ResponseType -- ^ It could be optional there is only one redirect_uri registered. -- See: https://www.rfc-editor.org/rfc/rfc6749#section-3.1.2.3 , arExtraParams :: Map Text Text } instance ToQueryParam AuthorizationRequestParam where toQueryParam AuthorizationRequestParam {..} = Map.unions [ toQueryParam arResponseType , toQueryParam arScope , toQueryParam arClientId , toQueryParam arState , toQueryParam arRedirectUri , arExtraParams ] class HasAuthorizeRequest a where -- | Constructs Authorization Code request parameters -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.1 mkAuthorizationRequestParam :: a -> AuthorizationRequestParam -- | Constructs Authorization Code request URI -- https://www.rfc-editor.org/rfc/rfc6749#section-4.1.1 mkAuthorizationRequest :: HasAuthorizeRequest a => IdpApplication i a -> URI mkAuthorizationRequest idpApp = let req = mkAuthorizationRequestParam (application idpApp) allParams = map (bimap tlToBS tlToBS) $ Map.toList $ toQueryParam req in appendQueryParams allParams $ idpAuthorizeEndpoint (idp idpApp) ------------------------------------------------------------------------------- -- PKCE -- ------------------------------------------------------------------------------- -- | https://datatracker.ietf.org/doc/html/rfc7636 class HasAuthorizeRequest a => HasPkceAuthorizeRequest a where mkPkceAuthorizeRequestParam :: MonadIO m => a -> m (AuthorizationRequestParam, CodeVerifier) -- | Constructs Authorization Code (PKCE) request URI and the Code Verifier. -- https://datatracker.ietf.org/doc/html/rfc7636 mkPkceAuthorizeRequest :: (MonadIO m, HasPkceAuthorizeRequest a) => IdpApplication i a -> m (URI, CodeVerifier) mkPkceAuthorizeRequest IdpApplication {..} = do (req, codeVerifier) <- mkPkceAuthorizeRequestParam application let allParams = map (bimap tlToBS tlToBS) $ Map.toList $ toQueryParam req let url = appendQueryParams allParams $ idpAuthorizeEndpoint idp pure (url, codeVerifier) hoauth2-2.10.0/src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs0000644000000000000000000001016707346545000025763 0ustar0000000000000000{-# LANGUAGE DerivingStrategies #-} module Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest where import Control.Applicative import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except (ExceptT (..), throwE) import Data.Aeson.Types import Data.Bifunctor import Data.ByteString.Lazy.Char8 qualified as BSL import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Text.Lazy (Text) import Network.HTTP.Client.Contrib import Network.HTTP.Conduit import Network.OAuth.OAuth2 hiding (RefreshToken) import Network.OAuth2.Experiment.Types import Network.OAuth2.Experiment.Utils import URI.ByteString hiding (UserInfo) ------------------------------------------------------------------------------- -- Device Authorization Request -- ------------------------------------------------------------------------------- newtype DeviceCode = DeviceCode Text deriving newtype (FromJSON) instance ToQueryParam DeviceCode where toQueryParam :: DeviceCode -> Map Text Text toQueryParam (DeviceCode dc) = Map.singleton "device_code" dc -- | https://www.rfc-editor.org/rfc/rfc8628#section-3.2 data DeviceAuthorizationResponse = DeviceAuthorizationResponse { deviceCode :: DeviceCode , userCode :: Text , verificationUri :: URI , verificationUriComplete :: Maybe URI , expiresIn :: Integer , interval :: Maybe Int } instance FromJSON DeviceAuthorizationResponse where parseJSON :: Value -> Parser DeviceAuthorizationResponse parseJSON = withObject "parse DeviceAuthorizationResponse" $ \t -> do deviceCode <- t .: "device_code" userCode <- t .: "user_code" -- https://stackoverflow.com/questions/76696956/shall-it-be-verification-uri-instead-of-verification-url-in-the-device-autho verificationUri <- t .: "verification_uri" <|> t .: "verification_url" verificationUriComplete <- t .:? "verification_uri_complete" expiresIn <- t .: "expires_in" interval <- t .:? "interval" pure DeviceAuthorizationResponse {..} data DeviceAuthorizationRequestParam = DeviceAuthorizationRequestParam { arScope :: Set Scope , arClientId :: Maybe ClientId , arExtraParams :: Map Text Text } instance ToQueryParam DeviceAuthorizationRequestParam where toQueryParam :: DeviceAuthorizationRequestParam -> Map Text Text toQueryParam DeviceAuthorizationRequestParam {..} = Map.unions [ toQueryParam arScope , toQueryParam arClientId , arExtraParams ] class HasOAuth2Key a => HasDeviceAuthorizationRequest a where -- | Create Device Authorization Request parameters -- https://www.rfc-editor.org/rfc/rfc8628#section-3.1 mkDeviceAuthorizationRequestParam :: a -> DeviceAuthorizationRequestParam -- TODO: There is only (possibly always only) on instance of 'HasDeviceAuthorizationRequest' -- Maybe consider to hard-code the data type instead of use type class. -- | Makes Device Authorization Request -- https://www.rfc-editor.org/rfc/rfc8628#section-3.1 conduitDeviceAuthorizationRequest :: (MonadIO m, HasDeviceAuthorizationRequest a) => IdpApplication i a -> Manager -> ExceptT BSL.ByteString m DeviceAuthorizationResponse conduitDeviceAuthorizationRequest IdpApplication {..} mgr = do case idpDeviceAuthorizationEndpoint idp of Nothing -> throwE "[conduiteDeviceAuthorizationRequest] Device Authorization Flow is not supported due to miss device_authorization_endpoint." Just deviceAuthEndpoint -> do let deviceAuthReq = mkDeviceAuthorizationRequestParam application oauth2Key = mkOAuth2Key application body = unionMapsToQueryParams [toQueryParam deviceAuthReq] ExceptT . liftIO $ do req <- addDefaultRequestHeaders <$> uriToRequest deviceAuthEndpoint -- Hacky: -- Missing clientId implies ClientSecretBasic authentication method. -- See Grant/DeviceAuthorization.hs let req' = case arClientId deviceAuthReq of Nothing -> addBasicAuth oauth2Key req Just _ -> req resp <- httpLbs (urlEncodedBody body req') mgr pure $ first ("[conduiteDeviceAuthorizationRequest] " <>) $ handleResponseJSON resp hoauth2-2.10.0/src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs0000644000000000000000000000376407346545000024407 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module Network.OAuth2.Experiment.Flows.RefreshTokenRequest where import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except (ExceptT (..)) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Text.Lazy (Text) import Network.HTTP.Conduit import Network.OAuth.OAuth2 hiding (RefreshToken) import Network.OAuth.OAuth2 qualified as OAuth2 import Network.OAuth2.Experiment.Flows.TokenRequest import Network.OAuth2.Experiment.Types import Network.OAuth2.Experiment.Utils ------------------------------------------------------------------------------- -- RefreshToken Requset -- ------------------------------------------------------------------------------- data RefreshTokenRequest = RefreshTokenRequest { rrRefreshToken :: OAuth2.RefreshToken , rrGrantType :: GrantTypeValue , rrScope :: Set Scope } instance ToQueryParam RefreshTokenRequest where toQueryParam :: RefreshTokenRequest -> Map Text Text toQueryParam RefreshTokenRequest {..} = Map.unions [ toQueryParam rrGrantType , toQueryParam rrScope , toQueryParam rrRefreshToken ] class (HasOAuth2Key a, HasTokenRequestClientAuthenticationMethod a) => HasRefreshTokenRequest a where -- | Make Refresh Token Request parameters -- | https://www.rfc-editor.org/rfc/rfc6749#section-6 mkRefreshTokenRequestParam :: a -> OAuth2.RefreshToken -> RefreshTokenRequest -- | Make Refresh Token Request -- https://www.rfc-editor.org/rfc/rfc6749#section-6 conduitRefreshTokenRequest :: (MonadIO m, HasRefreshTokenRequest a) => IdpApplication i a -> Manager -> OAuth2.RefreshToken -> ExceptT TokenResponseError m OAuth2Token conduitRefreshTokenRequest IdpApplication {..} mgr rt = let tokenReq = mkRefreshTokenRequestParam application rt body = unionMapsToQueryParams [toQueryParam tokenReq] in doJSONPostRequest mgr (mkOAuth2Key application) (idpTokenEndpoint idp) body hoauth2-2.10.0/src/Network/OAuth2/Experiment/Flows/TokenRequest.hs0000644000000000000000000000716207346545000023064 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module Network.OAuth2.Experiment.Flows.TokenRequest where import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except (ExceptT (..), throwE) import Network.HTTP.Conduit import Network.OAuth.OAuth2 hiding (RefreshToken) import Network.OAuth2.Experiment.Pkce import Network.OAuth2.Experiment.Types import Network.OAuth2.Experiment.Utils ------------------------------------------------------------------------------- -- Token Request -- ------------------------------------------------------------------------------- class HasTokenRequestClientAuthenticationMethod a where getClientAuthenticationMethod :: a -> ClientAuthenticationMethod -- | Only Authorization Code Grant involves a Exchange Token (Authorization Code). -- ResourceOwnerPassword and Client Credentials make token request directly. data NoNeedExchangeToken = NoNeedExchangeToken class (HasOAuth2Key a, HasTokenRequestClientAuthenticationMethod a) => HasTokenRequest a where -- Each GrantTypeFlow has slightly different request parameter to /token endpoint. data TokenRequest a type ExchangeTokenInfo 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 mkTokenRequestParam :: a -> ExchangeTokenInfo a -> TokenRequest a -- | Make Token Request -- https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3 conduitTokenRequest :: (HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) => IdpApplication i a -> Manager -> ExchangeTokenInfo a -> ExceptT TokenResponseError m OAuth2Token conduitTokenRequest IdpApplication {..} mgr exchangeToken = do let tokenReq = mkTokenRequestParam application exchangeToken body = unionMapsToQueryParams [toQueryParam tokenReq] if getClientAuthenticationMethod application == ClientAssertionJwt then do resp <- ExceptT . liftIO $ do req <- uriToRequest (idpTokenEndpoint idp) let req' = urlEncodedBody body (addDefaultRequestHeaders req) handleOAuth2TokenResponse <$> httpLbs req' mgr case parseResponseFlexible resp of Right obj -> return obj Left e -> throwE e else doJSONPostRequest mgr (mkOAuth2Key application) (idpTokenEndpoint idp) body ------------------------------------------------------------------------------- -- PKCE -- ------------------------------------------------------------------------------- -- | Make Token Request (PKCE) -- https://datatracker.ietf.org/doc/html/rfc7636#section-4.5 conduitPkceTokenRequest :: (HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) => IdpApplication i a -> Manager -> (ExchangeTokenInfo a, CodeVerifier) -> ExceptT TokenResponseError m OAuth2Token conduitPkceTokenRequest IdpApplication {..} mgr (exchangeToken, codeVerifier) = let req = mkTokenRequestParam application exchangeToken key = mkOAuth2Key application clientSecretPostParam = if getClientAuthenticationMethod application == ClientSecretPost then clientSecretPost key else [] body = unionMapsToQueryParams [ toQueryParam req , toQueryParam codeVerifier ] ++ clientSecretPostParam in doJSONPostRequest mgr key (idpTokenEndpoint idp) body hoauth2-2.10.0/src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs0000644000000000000000000000274107346545000023534 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module Network.OAuth2.Experiment.Flows.UserInfoRequest where import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except (ExceptT (..)) import Data.Aeson (FromJSON) import Data.ByteString.Lazy.Char8 qualified as BSL import Network.HTTP.Conduit import Network.OAuth.OAuth2 import Network.OAuth2.Experiment.Types import URI.ByteString (URI) ------------------------------------------------------------------------------- -- User Info Request -- ------------------------------------------------------------------------------- class HasUserInfoRequest a -- | Standard approach of fetching /userinfo conduitUserInfoRequest :: (MonadIO m, HasUserInfoRequest a, FromJSON b) => IdpApplication i a -> Manager -> AccessToken -> ExceptT BSL.ByteString m b conduitUserInfoRequest = conduitUserInfoRequestWithCustomMethod authGetJSON -- | Usually 'conduitUserInfoRequest' is good enough. -- But some IdP has different approach to fetch user information rather than GET. -- This method gives the flexiblity. conduitUserInfoRequestWithCustomMethod :: (MonadIO m, HasUserInfoRequest a, FromJSON b) => ( Manager -> AccessToken -> URI -> ExceptT BSL.ByteString m b ) -> IdpApplication i a -> Manager -> AccessToken -> ExceptT BSL.ByteString m b conduitUserInfoRequestWithCustomMethod fetchMethod IdpApplication {..} mgr at = fetchMethod mgr at (idpUserInfoEndpoint idp) hoauth2-2.10.0/src/Network/OAuth2/Experiment/0000755000000000000000000000000007346545000016777 5ustar0000000000000000hoauth2-2.10.0/src/Network/OAuth2/Experiment/Grants.hs0000644000000000000000000000152407346545000020573 0ustar0000000000000000module Network.OAuth2.Experiment.Grants ( module Network.OAuth2.Experiment.Grants.AuthorizationCode, module Network.OAuth2.Experiment.Grants.DeviceAuthorization, module Network.OAuth2.Experiment.Grants.ClientCredentials, module Network.OAuth2.Experiment.Grants.ResourceOwnerPassword, module Network.OAuth2.Experiment.Grants.JwtBearer, ) where import Network.OAuth2.Experiment.Grants.AuthorizationCode (AuthorizationCodeApplication (..)) import Network.OAuth2.Experiment.Grants.ClientCredentials (ClientCredentialsApplication (..)) import Network.OAuth2.Experiment.Grants.DeviceAuthorization ( DeviceAuthorizationApplication (..), pollDeviceTokenRequest, ) import Network.OAuth2.Experiment.Grants.JwtBearer (JwtBearerApplication (..)) import Network.OAuth2.Experiment.Grants.ResourceOwnerPassword (ResourceOwnerPasswordApplication (..)) hoauth2-2.10.0/src/Network/OAuth2/Experiment/Grants/0000755000000000000000000000000007346545000020235 5ustar0000000000000000hoauth2-2.10.0/src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs0000644000000000000000000001025607346545000024230 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} module Network.OAuth2.Experiment.Grants.AuthorizationCode where import Control.Monad.IO.Class (MonadIO (..)) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Text.Lazy (Text) import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..), ExchangeToken (..), OAuth2) import Network.OAuth.OAuth2 qualified as OAuth2 import Network.OAuth2.Experiment.Flows.AuthorizationRequest import Network.OAuth2.Experiment.Flows.RefreshTokenRequest import Network.OAuth2.Experiment.Flows.TokenRequest import Network.OAuth2.Experiment.Flows.UserInfoRequest import Network.OAuth2.Experiment.Pkce import Network.OAuth2.Experiment.Types import URI.ByteString hiding (UserInfo) -- | An Application that supports "Authorization code" flow -- -- https://www.rfc-editor.org/rfc/rfc6749#section-4.1 data AuthorizationCodeApplication = AuthorizationCodeApplication { acName :: Text , acClientId :: ClientId , acClientSecret :: ClientSecret , acScope :: Set Scope , acRedirectUri :: URI , acAuthorizeState :: AuthorizeState , acAuthorizeRequestExtraParams :: Map Text Text , acTokenRequestAuthenticationMethod :: ClientAuthenticationMethod } instance HasOAuth2Key AuthorizationCodeApplication where mkOAuth2Key :: AuthorizationCodeApplication -> OAuth2 mkOAuth2Key AuthorizationCodeApplication {..} = toOAuth2Key acClientId acClientSecret instance HasTokenRequestClientAuthenticationMethod AuthorizationCodeApplication where getClientAuthenticationMethod :: AuthorizationCodeApplication -> ClientAuthenticationMethod getClientAuthenticationMethod AuthorizationCodeApplication {..} = acTokenRequestAuthenticationMethod instance HasAuthorizeRequest AuthorizationCodeApplication where mkAuthorizationRequestParam :: AuthorizationCodeApplication -> AuthorizationRequestParam mkAuthorizationRequestParam AuthorizationCodeApplication {..} = AuthorizationRequestParam { arScope = acScope , arState = acAuthorizeState , arClientId = acClientId , arRedirectUri = Just (RedirectUri acRedirectUri) , arResponseType = Code , arExtraParams = acAuthorizeRequestExtraParams } instance HasPkceAuthorizeRequest AuthorizationCodeApplication where mkPkceAuthorizeRequestParam :: MonadIO m => AuthorizationCodeApplication -> m (AuthorizationRequestParam, CodeVerifier) mkPkceAuthorizeRequestParam app = do PkceRequestParam {..} <- mkPkceParam let authReqParam = mkAuthorizationRequestParam app combinatedExtraParams = Map.unions [ arExtraParams authReqParam , toQueryParam codeChallenge , toQueryParam codeChallengeMethod ] pure (authReqParam {arExtraParams = combinatedExtraParams}, codeVerifier) -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3 instance HasTokenRequest AuthorizationCodeApplication where type ExchangeTokenInfo AuthorizationCodeApplication = ExchangeToken data TokenRequest AuthorizationCodeApplication = AuthorizationCodeTokenRequest { trCode :: ExchangeToken , trGrantType :: GrantTypeValue , trRedirectUri :: RedirectUri } mkTokenRequestParam :: AuthorizationCodeApplication -> ExchangeToken -> TokenRequest AuthorizationCodeApplication mkTokenRequestParam AuthorizationCodeApplication {..} authCode = AuthorizationCodeTokenRequest { trCode = authCode , trGrantType = GTAuthorizationCode , trRedirectUri = RedirectUri acRedirectUri } instance ToQueryParam (TokenRequest AuthorizationCodeApplication) where toQueryParam :: TokenRequest AuthorizationCodeApplication -> Map Text Text toQueryParam AuthorizationCodeTokenRequest {..} = Map.unions [ toQueryParam trCode , toQueryParam trGrantType , toQueryParam trRedirectUri ] instance HasUserInfoRequest AuthorizationCodeApplication instance HasRefreshTokenRequest AuthorizationCodeApplication where mkRefreshTokenRequestParam :: AuthorizationCodeApplication -> OAuth2.RefreshToken -> RefreshTokenRequest mkRefreshTokenRequestParam AuthorizationCodeApplication {..} rt = RefreshTokenRequest { rrScope = acScope , rrGrantType = GTRefreshToken , rrRefreshToken = rt } hoauth2-2.10.0/src/Network/OAuth2/Experiment/Grants/ClientCredentials.hs0000644000000000000000000000605307346545000024171 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} module Network.OAuth2.Experiment.Grants.ClientCredentials where import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Text.Lazy (Text) import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..), OAuth2) import Network.OAuth2.Experiment.Flows.TokenRequest import Network.OAuth2.Experiment.Types import Network.OAuth2.Experiment.Utils -- | An Application that supports "Client Credentials" flow -- -- https://www.rfc-editor.org/rfc/rfc6749#section-4.4 data ClientCredentialsApplication = ClientCredentialsApplication { ccClientId :: ClientId , ccClientSecret :: ClientSecret , ccName :: Text , ccScope :: Set Scope , ccTokenRequestExtraParams :: Map Text Text , ccTokenRequestAuthenticationMethod :: ClientAuthenticationMethod } instance HasOAuth2Key ClientCredentialsApplication where mkOAuth2Key :: ClientCredentialsApplication -> OAuth2 mkOAuth2Key ClientCredentialsApplication {..} = toOAuth2Key ccClientId ccClientSecret instance HasTokenRequestClientAuthenticationMethod ClientCredentialsApplication where getClientAuthenticationMethod :: ClientCredentialsApplication -> ClientAuthenticationMethod getClientAuthenticationMethod ClientCredentialsApplication {..} = ccTokenRequestAuthenticationMethod -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.4.2 instance HasTokenRequest ClientCredentialsApplication where type ExchangeTokenInfo ClientCredentialsApplication = NoNeedExchangeToken data TokenRequest ClientCredentialsApplication = ClientCredentialsTokenRequest { trScope :: Set Scope , trGrantType :: GrantTypeValue , trClientSecret :: ClientSecret , trClientId :: ClientId , trExtraParams :: Map Text Text , trClientAuthenticationMethod :: ClientAuthenticationMethod } mkTokenRequestParam :: ClientCredentialsApplication -> NoNeedExchangeToken -> TokenRequest ClientCredentialsApplication mkTokenRequestParam ClientCredentialsApplication {..} _ = ClientCredentialsTokenRequest { trScope = ccScope , trGrantType = GTClientCredentials , trClientSecret = ccClientSecret , trClientAuthenticationMethod = ccTokenRequestAuthenticationMethod , trExtraParams = ccTokenRequestExtraParams , trClientId = ccClientId } instance ToQueryParam (TokenRequest ClientCredentialsApplication) where toQueryParam :: TokenRequest ClientCredentialsApplication -> Map Text Text toQueryParam ClientCredentialsTokenRequest {..} = let jwtAssertionBody = if trClientAuthenticationMethod == ClientAssertionJwt then [ toQueryParam trClientId , Map.fromList [ ("client_assertion_type", "urn:ietf:params:oauth:client-assertion-type:jwt-bearer") , ("client_assertion", bs8ToLazyText $ tlToBS $ unClientSecret trClientSecret) ] ] else [] in Map.unions $ [ toQueryParam trGrantType , toQueryParam trScope , trExtraParams ] ++ jwtAssertionBody hoauth2-2.10.0/src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs0000644000000000000000000001306407346545000024555 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} module Network.OAuth2.Experiment.Grants.DeviceAuthorization ( DeviceAuthorizationApplication (..), pollDeviceTokenRequest, ) where import Control.Concurrent import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe import Data.Set (Set) import Data.Text.Lazy (Text) import Network.HTTP.Conduit import Network.OAuth.OAuth2 import Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest import Network.OAuth2.Experiment.Flows.TokenRequest import Network.OAuth2.Experiment.Flows.UserInfoRequest import Network.OAuth2.Experiment.Types import Prelude hiding (error) -- | An Application that supports "Device Authorization Grant" -- -- https://www.rfc-editor.org/rfc/rfc8628#section-3.1 data DeviceAuthorizationApplication = DeviceAuthorizationApplication { daName :: Text , daClientId :: ClientId , daClientSecret :: ClientSecret , daScope :: Set Scope , daAuthorizationRequestExtraParam :: Map Text Text -- ^ Additional parameters to the device authorization request. -- Most of identity providers follow the spec strictly but -- AzureAD requires "tenant" parameter. , daAuthorizationRequestAuthenticationMethod :: Maybe ClientAuthenticationMethod -- ^ The spec requires similar authentication method as /token request. -- Most of identity providers doesn't required it but some does like Okta. } pollDeviceTokenRequest :: MonadIO m => IdpApplication i DeviceAuthorizationApplication -> Manager -> DeviceAuthorizationResponse -> ExceptT TokenResponseError m OAuth2Token pollDeviceTokenRequest idpApp mgr deviceAuthResp = do pollDeviceTokenRequestInternal idpApp mgr (deviceCode deviceAuthResp) (fromMaybe 5 $ interval deviceAuthResp) pollDeviceTokenRequestInternal :: MonadIO m => IdpApplication i DeviceAuthorizationApplication -> Manager -> DeviceCode -> Int -> -- | Polling Interval ExceptT TokenResponseError m OAuth2Token pollDeviceTokenRequestInternal idpApp mgr deviceCode intervalSeconds = do resp <- runExceptT (conduitTokenRequest idpApp mgr deviceCode) case resp of Left trRespError -> do case tokenResponseError trRespError of -- TODO: Didn't have a good idea to expand the error code -- specifically for device token request flow -- Device Token Response additional error code: https://www.rfc-editor.org/rfc/rfc8628#section-3.5 UnknownErrorCode "authorization_pending" -> do liftIO $ threadDelay $ intervalSeconds * 1000000 pollDeviceTokenRequestInternal idpApp mgr deviceCode intervalSeconds UnknownErrorCode "slow_down" -> do let newIntervalSeconds = intervalSeconds + 5 liftIO $ threadDelay $ newIntervalSeconds * 1000000 pollDeviceTokenRequestInternal idpApp mgr deviceCode newIntervalSeconds _ -> throwE trRespError Right v -> pure v instance HasOAuth2Key DeviceAuthorizationApplication where mkOAuth2Key :: DeviceAuthorizationApplication -> OAuth2 mkOAuth2Key DeviceAuthorizationApplication {..} = toOAuth2Key daClientId daClientSecret instance HasTokenRequestClientAuthenticationMethod DeviceAuthorizationApplication where getClientAuthenticationMethod :: DeviceAuthorizationApplication -> ClientAuthenticationMethod getClientAuthenticationMethod _ = ClientSecretBasic instance HasDeviceAuthorizationRequest DeviceAuthorizationApplication where mkDeviceAuthorizationRequestParam :: DeviceAuthorizationApplication -> DeviceAuthorizationRequestParam mkDeviceAuthorizationRequestParam DeviceAuthorizationApplication {..} = DeviceAuthorizationRequestParam { arScope = daScope , arClientId = if daAuthorizationRequestAuthenticationMethod == Just ClientSecretBasic then Nothing else Just daClientId , arExtraParams = daAuthorizationRequestExtraParam } -- | https://www.rfc-editor.org/rfc/rfc8628#section-3.4 instance HasTokenRequest DeviceAuthorizationApplication where type ExchangeTokenInfo DeviceAuthorizationApplication = DeviceCode data TokenRequest DeviceAuthorizationApplication = AuthorizationCodeTokenRequest { trCode :: DeviceCode , trGrantType :: GrantTypeValue , trClientId :: Maybe ClientId } mkTokenRequestParam :: DeviceAuthorizationApplication -> DeviceCode -> TokenRequest DeviceAuthorizationApplication mkTokenRequestParam DeviceAuthorizationApplication {..} deviceCode = -- -- This is a bit hacky! -- The token request use `ClientSecretBasic` by default. (has to pick up one Client Authn Method) -- ClientId shall be also be in request body per spec. -- However, for some IdPs, e.g. Okta, when using `ClientSecretBasic` to authn Client, -- it doesn't allow @client_id@ in the request body -- 'daAuthorizationRequestAuthenticationMethod' set the tone for Authorization Request, -- hence just follow it in the token request AuthorizationCodeTokenRequest { trCode = deviceCode , trGrantType = GTDeviceCode , trClientId = if daAuthorizationRequestAuthenticationMethod == Just ClientSecretBasic then Nothing else Just daClientId } instance ToQueryParam (TokenRequest DeviceAuthorizationApplication) where toQueryParam :: TokenRequest DeviceAuthorizationApplication -> Map Text Text toQueryParam AuthorizationCodeTokenRequest {..} = Map.unions [ toQueryParam trCode , toQueryParam trGrantType , toQueryParam trClientId ] instance HasUserInfoRequest DeviceAuthorizationApplication hoauth2-2.10.0/src/Network/OAuth2/Experiment/Grants/JwtBearer.hs0000644000000000000000000000427107346545000022462 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} module Network.OAuth2.Experiment.Grants.JwtBearer where import Data.ByteString qualified as BS import Data.Default (Default (def)) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Text.Lazy (Text) import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..), OAuth2) import Network.OAuth2.Experiment.Flows.TokenRequest import Network.OAuth2.Experiment.Flows.UserInfoRequest import Network.OAuth2.Experiment.Types import Network.OAuth2.Experiment.Utils -- | An Application that supports "JWT Bearer" flow -- -- https://datatracker.ietf.org/doc/html/rfc7523 data JwtBearerApplication = JwtBearerApplication { jbName :: Text , jbJwtAssertion :: BS.ByteString } -- JwtBearner doesn't use @client_id@ and @client_secret@ for authentication. -- -- FIXME: The ideal solution shall be do not implement `HasOAuth2Key` -- but it will stop to re-use the method 'conduitTokenRequest' for JwtBearer flow. instance HasOAuth2Key JwtBearerApplication where mkOAuth2Key :: JwtBearerApplication -> OAuth2 mkOAuth2Key _ = def instance HasTokenRequestClientAuthenticationMethod JwtBearerApplication where getClientAuthenticationMethod :: JwtBearerApplication -> ClientAuthenticationMethod getClientAuthenticationMethod _ = ClientAssertionJwt instance HasTokenRequest JwtBearerApplication where type ExchangeTokenInfo JwtBearerApplication = NoNeedExchangeToken data TokenRequest JwtBearerApplication = JwtBearerTokenRequest { trGrantType :: GrantTypeValue -- \| 'GTJwtBearer' , trAssertion :: BS.ByteString -- \| The the signed JWT token } mkTokenRequestParam :: JwtBearerApplication -> NoNeedExchangeToken -> TokenRequest JwtBearerApplication mkTokenRequestParam JwtBearerApplication {..} _ = JwtBearerTokenRequest { trGrantType = GTJwtBearer , trAssertion = jbJwtAssertion } instance ToQueryParam (TokenRequest JwtBearerApplication) where toQueryParam :: TokenRequest JwtBearerApplication -> Map Text Text toQueryParam JwtBearerTokenRequest {..} = Map.unions [ toQueryParam trGrantType , Map.singleton "assertion" (bs8ToLazyText trAssertion) ] instance HasUserInfoRequest JwtBearerApplication hoauth2-2.10.0/src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs0000644000000000000000000000601707346545000025122 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} module Network.OAuth2.Experiment.Grants.ResourceOwnerPassword where import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Text.Lazy (Text) import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..), OAuth2 (..)) import Network.OAuth.OAuth2 qualified as OAuth2 import Network.OAuth2.Experiment.Flows.RefreshTokenRequest import Network.OAuth2.Experiment.Flows.TokenRequest import Network.OAuth2.Experiment.Flows.UserInfoRequest import Network.OAuth2.Experiment.Types -- | An Application that supports "Resource Owner Password" flow -- -- https://www.rfc-editor.org/rfc/rfc6749#section-4.3 data ResourceOwnerPasswordApplication = ResourceOwnerPasswordApplication { ropClientId :: ClientId , ropClientSecret :: ClientSecret , ropName :: Text , ropScope :: Set Scope , ropUserName :: Username , ropPassword :: Password , ropTokenRequestExtraParams :: Map Text Text } instance HasOAuth2Key ResourceOwnerPasswordApplication where mkOAuth2Key :: ResourceOwnerPasswordApplication -> OAuth2 mkOAuth2Key ResourceOwnerPasswordApplication {..} = toOAuth2Key ropClientId ropClientSecret instance HasTokenRequestClientAuthenticationMethod ResourceOwnerPasswordApplication where getClientAuthenticationMethod :: ResourceOwnerPasswordApplication -> ClientAuthenticationMethod getClientAuthenticationMethod _ = ClientSecretBasic -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.3.2 instance HasTokenRequest ResourceOwnerPasswordApplication where type ExchangeTokenInfo ResourceOwnerPasswordApplication = NoNeedExchangeToken data TokenRequest ResourceOwnerPasswordApplication = PasswordTokenRequest { trScope :: Set Scope , trUsername :: Username , trPassword :: Password , trGrantType :: GrantTypeValue , trExtraParams :: Map Text Text } mkTokenRequestParam :: ResourceOwnerPasswordApplication -> NoNeedExchangeToken -> TokenRequest ResourceOwnerPasswordApplication mkTokenRequestParam ResourceOwnerPasswordApplication {..} _ = PasswordTokenRequest { trUsername = ropUserName , trPassword = ropPassword , trGrantType = GTPassword , trScope = ropScope , trExtraParams = ropTokenRequestExtraParams } instance ToQueryParam (TokenRequest ResourceOwnerPasswordApplication) where toQueryParam :: TokenRequest ResourceOwnerPasswordApplication -> Map Text Text toQueryParam PasswordTokenRequest {..} = Map.unions [ toQueryParam trGrantType , toQueryParam trScope , toQueryParam trUsername , toQueryParam trPassword , trExtraParams ] instance HasUserInfoRequest ResourceOwnerPasswordApplication instance HasRefreshTokenRequest ResourceOwnerPasswordApplication where mkRefreshTokenRequestParam :: ResourceOwnerPasswordApplication -> OAuth2.RefreshToken -> RefreshTokenRequest mkRefreshTokenRequestParam ResourceOwnerPasswordApplication {..} rt = RefreshTokenRequest { rrScope = ropScope , rrGrantType = GTRefreshToken , rrRefreshToken = rt } hoauth2-2.10.0/src/Network/OAuth2/Experiment/Pkce.hs0000644000000000000000000000440707346545000020222 0ustar0000000000000000module 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} data CodeChallengeMethod = S256 deriving (Show) data PkceRequestParam = PkceRequestParam { codeVerifier :: CodeVerifier , codeChallenge :: CodeChallenge , codeChallengeMethod :: CodeChallengeMethod -- ^ spec says optional but in practice it is S256 -- https://datatracker.ietf.org/doc/html/rfc7636#section-4.3 } 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] hoauth2-2.10.0/src/Network/OAuth2/Experiment/Types.hs0000644000000000000000000002064107346545000020442 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} module Network.OAuth2.Experiment.Types where import Data.Default (Default (def)) 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.Lazy (Text) import Data.Text.Lazy qualified as TL import Network.OAuth.OAuth2 hiding (RefreshToken) import Network.OAuth.OAuth2 qualified as OAuth2 import Network.OAuth2.Experiment.Pkce import Network.OAuth2.Experiment.Utils import URI.ByteString (URI, serializeURIRef') ------------------------------------------------------------------------------- -- * Idp App ------------------------------------------------------------------------------- -- TODO: Distinct type per endpoint -- Because I made mistake at passing to Authorize and Token Request -- | @Idp i@ consists various endpoints endpoints. -- -- The @i@ is actually phantom type for information only (Idp name) at this moment. -- And it is PolyKinds. -- -- Hence whenever @Idp i@ or @IdpApplication i a@ is used as function parameter, -- PolyKinds need to be enabled. data Idp (i :: k) = Idp { idpUserInfoEndpoint :: URI -- ^ Userinfo Endpoint , idpAuthorizeEndpoint :: URI -- ^ Authorization Endpoint , idpTokenEndpoint :: URI -- ^ Token Endpoint , idpDeviceAuthorizationEndpoint :: Maybe URI -- ^ Apparently not all IdP support device code flow } -- | An OAuth2 Application "a" of IdP "i". -- "a" can be one of following type: -- -- * `Network.OAuth2.Experiment.AuthorizationCodeApplication` -- * `Network.OAuth2.Experiment.DeviceAuthorizationApplication` -- * `Network.OAuth2.Experiment.ClientCredentialsApplication` -- * `Network.OAuth2.Experiment.ResourceOwnerPasswordApplication` -- * `Network.OAuth2.Experiment.JwtBearerApplication` data IdpApplication (i :: k) a = IdpApplication { idp :: Idp i , application :: a } ------------------------------------------------------------------------------- -- * Scope ------------------------------------------------------------------------------- -- TODO: What's best type for Scope? -- Use 'Text' isn't super type safe. All cannot specify some standard scopes like openid, email etc. -- But 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 (Eq, Ord) instance IsString Scope where fromString :: String -> Scope fromString = Scope . TL.pack ------------------------------------------------------------------------------- -- * Grant Type value ------------------------------------------------------------------------------- -- | Grant type query parameter has association with different GrantType flows but not completely strict. -- -- e.g. Both AuthorizationCode and ResourceOwnerPassword flow could support refresh token flow. data GrantTypeValue = GTAuthorizationCode | GTPassword | GTClientCredentials | GTRefreshToken | GTJwtBearer | GTDeviceCode deriving (Eq, Show) ------------------------------------------------------------------------------- -- Response Type -- ------------------------------------------------------------------------------- data ResponseType = Code ------------------------------------------------------------------------------- -- * Credentials ------------------------------------------------------------------------------- newtype ClientId = ClientId {unClientId :: Text} deriving (Show, Eq, IsString) -- | Can be either "Client Secret" or JWT base on client authentication method 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" val GTJwtBearer = "urn:ietf:params:oauth:grant-type:jwt-bearer" val GTDeviceCode = "urn:ietf:params:oauth:grant-type:device_code" 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) instance ToQueryParam ResponseType where toQueryParam :: ResponseType -> Map Text Text toQueryParam Code = Map.singleton "response_type" "code" ------------------------------------------------------------------------------- -- HasOAuth2Key -- -- -- -- Find a way to reuse some methods from old implementation -- -- Probably will be removed when Experiment module becomes default -- ------------------------------------------------------------------------------- class HasOAuth2Key a where mkOAuth2Key :: a -> OAuth2 hoauth2-2.10.0/src/Network/OAuth2/Experiment/Utils.hs0000644000000000000000000000144707346545000020441 0ustar0000000000000000module 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 qualified as T import Data.Text.Encoding qualified as T import Data.Text.Encoding qualified as TE import Data.Text.Lazy qualified as TL import URI.ByteString (URI, serializeURIRef') tlToBS :: TL.Text -> ByteString tlToBS = TE.encodeUtf8 . TL.toStrict bs8ToLazyText :: BS8.ByteString -> TL.Text bs8ToLazyText = TL.pack . BS8.unpack unionMapsToQueryParams :: [Map TL.Text TL.Text] -> [(ByteString, ByteString)] unionMapsToQueryParams = map (bimap tlToBS tlToBS) . Map.toList . Map.unions uriToText :: URI -> T.Text uriToText = T.decodeUtf8 . serializeURIRef' hoauth2-2.10.0/test/Network/OAuth/OAuth2/0000755000000000000000000000000007346545000016067 5ustar0000000000000000hoauth2-2.10.0/test/Network/OAuth/OAuth2/TokenRequestSpec.hs0000644000000000000000000000434007346545000021670 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} module Network.OAuth.OAuth2.TokenRequestSpec where import Data.Aeson qualified as Aeson import Network.OAuth.OAuth2.TokenRequest import Test.Hspec import URI.ByteString.QQ import Prelude hiding (error) spec :: Spec spec = do describe "parseJSON TokenResponseErrorCode" $ do it "invalid_request" $ do Aeson.eitherDecode "\"invalid_request\"" `shouldBe` Right InvalidRequest it "invalid_client" $ do Aeson.eitherDecode "\"invalid_client\"" `shouldBe` Right InvalidClient it "invalid_grant" $ do Aeson.eitherDecode "\"invalid_grant\"" `shouldBe` Right InvalidGrant it "unauthorized_client" $ do Aeson.eitherDecode "\"unauthorized_client\"" `shouldBe` Right UnauthorizedClient it "unsupported_grant_type" $ do Aeson.eitherDecode "\"unsupported_grant_type\"" `shouldBe` Right UnsupportedGrantType it "invalid_scope" $ do Aeson.eitherDecode "\"invalid_scope\"" `shouldBe` Right InvalidScope it "foo_code" $ do Aeson.eitherDecode "\"foo_code\"" `shouldBe` Right (UnknownErrorCode "foo_code") describe "parseJSON TokenResponseError" $ do it "parse error" $ do Aeson.eitherDecode "{\"error\": \"invalid_request\"}" `shouldBe` Right ( TokenResponseError { tokenResponseError = InvalidRequest , tokenResponseErrorDescription = Nothing , tokenResponseErrorUri = Nothing } ) it "parse error_description" $ do Aeson.eitherDecode "{\"error\": \"invalid_request\", \"error_description\": \"token request error foo1\"}" `shouldBe` Right ( TokenResponseError { tokenResponseError = InvalidRequest , tokenResponseErrorDescription = Just "token request error foo1" , tokenResponseErrorUri = Nothing } ) it "parse error_uri" $ do Aeson.eitherDecode "{\"error\": \"invalid_request\", \"error_uri\": \"https://example.com\"}" `shouldBe` Right ( TokenResponseError { tokenResponseError = InvalidRequest , tokenResponseErrorDescription = Nothing , tokenResponseErrorUri = Just [uri|https://example.com|] } ) hoauth2-2.10.0/test/0000755000000000000000000000000007346545000012314 5ustar0000000000000000hoauth2-2.10.0/test/Spec.hs0000644000000000000000000000010107346545000013532 0ustar0000000000000000-- file test/Spec.hs {-# OPTIONS_GHC -F -pgmF hspec-discover #-}