hoauth2 1.16.2 → 2.15.1
raw patch · 61 files changed
Files
- CHANGELOG.md +161/−0
- LICENSE +17/−26
- README.md +10/−24
- Setup.hs +0/−2
- example/App.hs +0/−206
- example/IDP.hs +0/−48
- example/IDP/Auth0.hs +0/−63
- example/IDP/AzureAD.hs +0/−52
- example/IDP/Douban.hs +0/−53
- example/IDP/Dropbox.hs +0/−60
- example/IDP/Facebook.hs +0/−54
- example/IDP/Fitbit.hs +0/−63
- example/IDP/Github.hs +0/−51
- example/IDP/Google.hs +0/−54
- example/IDP/Linkedin.hs +0/−46
- example/IDP/Okta.hs +0/−62
- example/IDP/StackExchange.hs +0/−77
- example/IDP/Weibo.hs +0/−71
- example/IDP/ZOHO.hs +0/−69
- example/Keys.hs +0/−129
- example/Keys.hs.sample +0/−129
- example/README.org +0/−26
- example/Session.hs +0/−38
- example/Types.hs +0/−116
- example/Utils.hs +0/−37
- example/Views.hs +0/−39
- example/assets/main.css +0/−11
- example/main.hs +0/−6
- example/templates/index.mustache +0/−31
- hoauth2.cabal +109/−130
- src/Network/HTTP/Client/Contrib.hs +25/−0
- src/Network/OAuth/OAuth2.hs +0/−21
- src/Network/OAuth/OAuth2/AuthorizationRequest.hs +0/−23
- src/Network/OAuth/OAuth2/HttpClient.hs +0/−278
- src/Network/OAuth/OAuth2/Internal.hs +0/−254
- src/Network/OAuth/OAuth2/TokenRequest.hs +0/−21
- src/Network/OAuth2.hs +26/−0
- src/Network/OAuth2/AuthorizationRequest.hs +88/−0
- src/Network/OAuth2/Experiment.hs +157/−0
- src/Network/OAuth2/Experiment/Flows.hs +273/−0
- src/Network/OAuth2/Experiment/Flows/AuthorizationRequest.hs +33/−0
- src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs +59/−0
- src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs +39/−0
- src/Network/OAuth2/Experiment/Flows/TokenRequest.hs +41/−0
- src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs +7/−0
- src/Network/OAuth2/Experiment/Grants.hs +15/−0
- src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs +117/−0
- src/Network/OAuth2/Experiment/Grants/ClientCredentials.hs +73/−0
- src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs +90/−0
- src/Network/OAuth2/Experiment/Grants/JwtBearer.hs +50/−0
- src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs +78/−0
- src/Network/OAuth2/Experiment/Pkce.hs +82/−0
- src/Network/OAuth2/Experiment/Types.hs +218/−0
- src/Network/OAuth2/Experiment/Utils.hs +27/−0
- src/Network/OAuth2/HttpClient.hs +245/−0
- src/Network/OAuth2/Internal.hs +116/−0
- src/Network/OAuth2/TokenRequest.hs +362/−0
- test/Network/OAuth2/InternalSpec.hs +69/−0
- test/Network/OAuth2/TokenRequestSpec.hs +56/−0
- test/Network/OAuth2/TokenResponseSpec.hs +48/−0
- test/Spec.hs +2/−0
+ CHANGELOG.md view
@@ -0,0 +1,161 @@+# hoauth2 Changelog++## 2.15.1 (2026-04-17)+- Dependency changes+ - Relax the `containers` upper bound to `< 0.9` so `containers-0.8` is supported.+ - No API or behavior changes.++## 2.15.0 (2025-10-05)+- Breaking changes+ - Type and class renames+ - `OAuth2Token` renamed to `TokenResponse`.+ - `TokenRequestAuthenicationMethod` renamed to `ClientAuthenticationMethod`.+ - `HasTokenRequestClientAuthenticationMethod` renamed to `HasClientAuthenticationMethod`.+ - Removed several `Has*` type classes (e.g., `HasOAuth2Key`, `HasOAuthKey` from `HasTokenRequest`).+ - Removed deprecated API in `Network.OAuth2.HttpClient`+ - Deprecated functions have been removed. Use `authGetJSON`/`authGetBS`/`authPostJSON`/`authPostBS` and the `WithAuthMethod` variants with `APIAuthenticationMethod`.+ - Request body encoding behavior+ - `authPostJSON` now sends JSON with `Content-Type: application/json`. If an endpoint requires form-encoded data, use `authPostBS` or construct a custom request body.+ - Import/module path cleanup+ - Consumers should import `Network.OAuth2` (not `Network.OAuth.OAuth2`).+- Behavioral changes and bug fixes+ - Client authentication handling+ - Append `client_id` and `client_secret` for `ClientSecretPost` in client credentials flow.+ - Refresh token flow honors the configured client authentication method.+ - Authorization Code flow supports client authentication methods.+ - Device Authorization flow+ - Updated handling of device authorization requests and polling behavior.+- Refactors and internal cleanup+ - Refactored header handling, simplified URI-to-Request conversion, removed deprecated or unused internals, and general cleanups.+- Dependency changes+ - Allow `microlens` 0.5 (`microlens` >= 0.4 && < 0.6).+ - Raise lower bound to `uri-bytestring` >= 0.4 (< 0.5).++## 2.14.3 (2025-03-14)++- Fixes and improvements:+ - Append client_id and client_secret for ClientSecretPost in client credentials flow+ - Add raw response to token response and derive Show instances+ - Skip empty scope; assorted refactors and cleanups++## 2.14.2 (2025-01-30)++* Updated uri-bytestring to version 0.4++## 2.14.1 (2024-11-19)++* Updated data-default to version 0.8++## 2.14.0 (2024-11-19)++* Updated crypton to version 1.0++## 2.13.0 (2024-03-07)++* Replaced cryptonite with crypton++## 2.12.0 (2024-01-19)++* Updated base64 to version 1.0++## 2.11.0 (2023-12-30)++* Updated aeson to version 2.2+* Updated binary to version 0.10+* Updated bytestring to version 0.12+* Updated container to version 0.7++## 2.10.0 (2023-11-17)++* Added support for text 2.2++## 2.9.0 (2023-10-26)++* Refactored oauth2 Experiment module implementation+* Removed generics+* Added Device Authorization grant+* Moved IdpName to hoauth2 and enabled DataKinds+* Changed the type parameter in HttpClient methods+* Removed data family `RefreshTokenRequest`++## 2.8.1 (2023-06-17)++* Added support for GHC-9.6+* Updated CI configuration for GHC 9.6.1+* Added hiedb integration++## 2.8.0 (2023-03-15)++* Added support for GHC-9.4.4+* Added support for text-2.0++## 2.7 (2022-11-17)++* Added GrantType jwt-bearer+* Added JWT authentication method for ClientCredential flow+* Replaced `OAuth2Error` with `TokenRequestError`+* Moved `HasIdpName` class to hoauth2-demo+* Improved error handling when response body is empty in `HttpClient.handleResponse`+* Removed the following modules from exposure list:+ - Network.OAuth2.Experiment.Pkce+ - Network.OAuth2.Experiment.Types+ - Network.OAuth2.Experiment.Utils+ - Network.OAuth.OAuth2.Internal++## 2.6 (2022-10-04)++* Changed type parameter order in http client JSON method+* Modified http client to only accept one Authentication Method instead of a Set+* Removed `authPostBS1` (non-standard approach to sending credentials)+* Removed Douban IdP (discontinued OAuth2 support)+* Deprecated all *Internal methods, added *WithAuthMethod alternatives+* Changed license to MIT+* Added support for PKCE flow in `Network.OAuth2.Experiment` module+* Added support for Resource Owner Password and Client Credentials flows+* Added `hoauth2-providers` and `hoauth2-providers-tutorial` modules+* Added `hoauth2-tutorial` module++## 2.5 (2022-08-17)++* Updated aeson to version 2.1++## 2.4 (2022-08-17)++* Relaxed binary and bytestring version constraints++## 2.1 (2022-02-19)++* Added documentation for OAuth2 specification+* Updated aeson to version 2++## 2.0 (2022-02-15)++* Breaking change: Refactored naming convention of `OAuth2` data type+ ```diff+ - { oauthClientId = "xxxxxxxxxxxxxxx"+ - , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"+ - , oauthCallback = Just [uri|http://127.0.0.1:9988/oauthCallback|]+ - , oauthOAuthorizeEndpoint = [uri|https://api.weibo.com/oauth2/authorize|]+ - , oauthAccessTokenEndpoint = [uri|https://api.weibo.com/oauth2/access_token|]+ + { oauth2ClientId = "xxxxxxxxxxxxxxx"+ + , oauth2ClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"+ + , oauth2RedirectUri = Just [uri|http://127.0.0.1:9988/oauthCallback|]+ + , oauth2AuthorizeEndpoint = [uri|https://api.weibo.com/oauth2/authorize|]+ + , oauth2TokenEndpoint = [uri|https://api.weibo.com/oauth2/access_token|]+ + }+ ```++## 1.7.0 (2018-03-03)++* Added sample server and removed individual sample tests+* Added `fetchAccessToken2` function+* Added `refreshAccessToken` function and deprecated `fetchRefreshToken`+* Renamed `authGetBS'` to `authGetBS2`+* Renamed `authPostBS'` to `authPostBS2`+* Added `authPostBS3` function++## 1.0.0 (2017-04-07)++* Added umbrella type `OAuth2Token` to accommodate `AccessToken` and `RefreshToken`+* Typed the intermediate authentication code as `ExchangeToken`+* Fixed missing client_id error in tests by appending client_id and client_secret to header
LICENSE view
@@ -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.
README.md view
@@ -1,25 +1,11 @@-[](http://travis-ci.org/freizl/hoauth2)-[](https://hackage.haskell.org/package/hoauth2)--# Introduction--A lightweight OAuth2 Haskell binding.--# Build the sample App--- Make sure `ghc-8.10` and `cabal-3.x` installed.-- `make create-keys`-- check the `example/Keys.hs` to make sure it's config correctly for the IdP you're going to test. (client id, client secret, oauth Urls etc)-- `make build`-- `make start-demo`-- open <http://localhost:9988>--## Nix--- assume `cabal-install` has been install (either globally or in nix store)-- `nix-shell` then could do `cabal v2-` build-- or `nix-build`--# Contribute+Haskell bindings for -Feel free send pull request or submit issue ticket.+- [The OAuth 2.0 Authorization Framework](https://datatracker.ietf.org/doc/html/rfc6749)+ - If the Identity Provider also implements [OIDC+ spec](https://openid.net/specs/openid-connect-core-1_0.html), ID+ Token will also be present in the token response (see+ `TokenResponse`).+- [JWT Profile for OAuth2 Client Authentication and Authorization+ Grants](https://www.rfc-editor.org/rfc/rfc7523.html)+- [The OAuth 2.0 Authorization Framework: Bearer Token+ Usage](https://www.rfc-editor.org/rfc/rfc6750)
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− example/App.hs
@@ -1,206 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}--module App- ( app- , waiApp- ) where--import Control.Monad-import Control.Monad.IO.Class ( MonadIO- , liftIO- )-import Data.Bifunctor-import Data.Maybe-import Data.Text.Lazy ( Text )-import qualified Data.Text.Lazy as TL-import IDP-import Network.HTTP.Conduit-import Network.HTTP.Types-import Network.OAuth.OAuth2-import qualified Network.Wai as WAI-import Network.Wai.Handler.Warp ( run )-import Network.Wai.Middleware.Static-import Prelude-import Session-import Types-import Utils-import Views-import Web.Scotty----------------------------------- App---------------------------------myServerPort :: Int-myServerPort = 9988--app :: IO ()-app =- putStrLn ("Starting Server. http://localhost:" ++ show myServerPort)- >> waiApp- >>= run myServerPort---- TODO: how to add either Monad or a middleware to do session?-waiApp :: IO WAI.Application-waiApp = do- cache <- initCacheStore- initIdps cache- scottyApp $ do- middleware $ staticPolicy (addBase "example/assets")- defaultHandler globalErrorHandler- get "/" $ indexH cache- get "/oauth2/callback" $ callbackH cache- get "/logout" $ logoutH cache- get "/refresh" $ refreshH cache--debug :: Bool-debug = True------------------------------------------------------- * Handlers-----------------------------------------------------redirectToHomeM :: ActionM ()-redirectToHomeM = redirect "/"--globalErrorHandler :: Text -> ActionM ()-globalErrorHandler t = status status401 >> html t--readIdpParam :: ActionM (Either Text IDPApp)-readIdpParam = do- pas <- params- let idpP = paramValue "idp" pas- when (null idpP) redirectToHomeM- return $ parseIDP (head idpP)--refreshH :: CacheStore -> ActionM ()-refreshH c = do- eitherIdpApp <- readIdpParam- case eitherIdpApp of- Right (IDPApp idp) -> do- maybeIdpData <- lookIdp c idp- when (isNothing maybeIdpData)- (raise "refreshH: cannot find idp data from cache")- let idpData = fromJust maybeIdpData- re <- liftIO $ doRefreshToken idp idpData- case re of- Right newToken -> liftIO (print newToken) >> redirectToHomeM -- TODO: update access token in the store- Left e -> raise (TL.pack e)- Left e -> raise ("logout: unknown IDP " `TL.append` e)--doRefreshToken- :: HasTokenRefreshReq a => a -> IDPData -> IO (Either String OAuth2Token)-doRefreshToken idp idpData = do- mgr <- newManager tlsManagerSettings- case oauth2Token idpData of- Nothing -> return $ Left "no token found for idp"- Just at -> case refreshToken at of- Nothing -> return $ Left "no refresh token presents"- Just rt -> do- re <- tokenRefreshReq idp mgr rt- return (first show re)--logoutH :: CacheStore -> ActionM ()-logoutH c = do- eitherIdpApp <- readIdpParam- -- let eitherIdpApp = parseIDP (head idpP)- case eitherIdpApp of- Right (IDPApp idp) ->- liftIO (removeKey c (idpLabel idp)) >> redirectToHomeM- Left e -> raise ("logout: unknown IDP " `TL.append` e)--indexH :: CacheStore -> ActionM ()-indexH c = liftIO (allValues c) >>= overviewTpl--callbackH :: CacheStore -> ActionM ()-callbackH c = do- pas <- params- let codeP = paramValue "code" pas- let stateP = paramValue "state" pas- when (null codeP) (raise "callbackH: no code from callback request")- when (null stateP) (raise "callbackH: no state from callback request")- let eitherIdpApp = parseIDP (TL.takeWhile (/= '.') (head stateP))- -- TODO: looks like `state` shall be passed when fetching access token- -- turns out no IDP enforce this yet- case eitherIdpApp of- Right (IDPApp idp) -> fetchTokenAndUser c (head codeP) idp- Left e ->- raise ("callbackH: cannot find IDP name from text " `TL.append` e)--fetchTokenAndUser- :: (HasTokenReq a, HasUserReq a, HasLabel a)- => CacheStore- -> TL.Text -- ^ code- -> a- -> ActionM ()-fetchTokenAndUser c code idp = do- maybeIdpData <- lookIdp c idp- when (isNothing maybeIdpData)- (raise "fetchTokenAndUser - cannot find idp data from cache")-- let idpData = fromJust maybeIdpData- result <- liftIO $ fetchTokenAndUser' c code idp idpData- case result of- Right _ -> redirectToHomeM- Left err -> raise err--fetchTokenAndUser'- :: (HasTokenReq a, HasUserReq a)- => CacheStore- -> Text- -> a- -> IDPData- -> IO (Either Text ())-fetchTokenAndUser' c code idp idpData = do- mgr <- newManager tlsManagerSettings- token <- tokenReq idp mgr (ExchangeToken $ TL.toStrict code)- when debug (print token)-- result <- case token of- Right at -> tryFetchUser mgr at idp- Left e -> return- ( Left- $ TL.pack- $ "tryFetchUser - cannot fetch asses token. error detail: "- ++ show e- )-- case result of- Right (luser, at) -> updateIdp c idpData luser at >> return (Right ())- Left err ->- return $ Left ("fetchTokenAndUser - no user found: " `TL.append` err)-- where- updateIdp c1 oldIdpData luser token = insertIDPData- c1- (oldIdpData { loginUser = Just luser, oauth2Token = Just token })--lookIdp :: (MonadIO m, HasLabel a) => CacheStore -> a -> m (Maybe IDPData)-lookIdp c1 idp1 = liftIO $ lookupKey c1 (idpLabel idp1)---- TODO: may use Exception monad to capture error in this IO monad----tryFetchUser- :: HasUserReq a- => Manager- -> OAuth2Token- -> a- -> IO (Either Text (LoginUser, OAuth2Token))-tryFetchUser mgr at idp = do- re <- fetchUser idp mgr (accessToken at)- return $ case re of- Right user' -> Right (user', at)- Left e -> Left e---- * Fetch UserInfo----fetchUser- :: (HasUserReq a) => a -> Manager -> AccessToken -> IO (Either Text LoginUser)-fetchUser idp mgr token = do- re <- userReq idp mgr token- return (first bslToText re)
− example/IDP.hs
@@ -1,48 +0,0 @@-module IDP where--import qualified Data.HashMap.Strict as Map-import Data.Text.Lazy (Text)-import qualified IDP.Auth0 as IAuth0-import qualified IDP.AzureAD as IAzureAD-import qualified IDP.Douban as IDouban-import qualified IDP.Dropbox as IDropbox-import qualified IDP.Facebook as IFacebook-import qualified IDP.Fitbit as IFitbit-import qualified IDP.Github as IGithub-import qualified IDP.Google as IGoogle-import qualified IDP.Okta as IOkta-import qualified IDP.StackExchange as IStackExchange-import qualified IDP.Weibo as IWeibo-import qualified IDP.ZOHO as IZOHO-import Session-import Types---- TODO: make this generic to discover any IDPs from idp directory.----idps :: [IDPApp]-idps =- [ IDPApp IAzureAD.AzureAD,- IDPApp IDouban.Douban,- IDPApp IDropbox.Dropbox,- IDPApp IFacebook.Facebook,- IDPApp IFitbit.Fitbit,- IDPApp IGithub.Github,- IDPApp IGoogle.Google,- IDPApp IOkta.Okta,- IDPApp IStackExchange.StackExchange,- IDPApp IWeibo.Weibo,- IDPApp IAuth0.Auth0,- IDPApp IZOHO.ZOHO- ]--initIdps :: CacheStore -> IO ()-initIdps c = mapM_ (insertIDPData c) (fmap mkIDPData idps)--idpsMap :: Map.HashMap Text IDPApp-idpsMap = Map.fromList $ fmap (\x@(IDPApp idp) -> (idpLabel idp, x)) idps--parseIDP :: Text -> Either Text IDPApp-parseIDP s = maybe (Left s) Right (Map.lookup s idpsMap)--mkIDPData :: IDPApp -> IDPData-mkIDPData (IDPApp idp) = IDPData (authUri idp) Nothing Nothing (idpLabel idp)
− example/IDP/Auth0.hs
@@ -1,63 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--module IDP.Auth0 where--import Data.Aeson-import Data.Bifunctor-import Data.Hashable-import Data.Text.Lazy (Text)-import GHC.Generics-import Keys-import Network.OAuth.OAuth2-import Types-import URI.ByteString-import URI.ByteString.QQ-import Utils--data Auth0 = Auth0- deriving (Show, Generic)--instance Hashable Auth0--instance IDP Auth0--instance HasLabel Auth0--instance HasTokenReq Auth0 where- tokenReq _ mgr = fetchAccessToken mgr auth0Key--instance HasTokenRefreshReq Auth0 where- tokenRefreshReq _ mgr = refreshAccessToken mgr auth0Key--instance HasUserReq Auth0 where- userReq _ mgr at = do- re <- authGetJSON mgr at userInfoUri- return (second toLoginUser re)--instance HasAuthUri Auth0 where- authUri _ =- createCodeUri- auth0Key- [ ("state", "Auth0.test-state-123"),- ( "scope",- "openid profile email offline_access"- )- ]--data Auth0User = Auth0User- { name :: Text,- email :: Text- }- deriving (Show, Generic)--instance FromJSON Auth0User where- parseJSON =- genericParseJSON defaultOptions {fieldLabelModifier = camelTo2 '_'}--userInfoUri :: URI-userInfoUri = [uri|https://freizl.auth0.com/userinfo|]--toLoginUser :: Auth0User -> LoginUser-toLoginUser ouser = LoginUser {loginUserName = name ouser}
− example/IDP/AzureAD.hs
@@ -1,52 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--module IDP.AzureAD where-import Data.Aeson-import Data.Bifunctor-import Data.Hashable-import Data.Text.Lazy (Text)-import GHC.Generics-import Keys-import Network.OAuth.OAuth2-import Types-import URI.ByteString-import URI.ByteString.QQ-import Utils--data AzureAD = AzureAD deriving (Show, Generic)--instance Hashable AzureAD--instance IDP AzureAD--instance HasLabel AzureAD--instance HasTokenRefreshReq AzureAD where- tokenRefreshReq _ mgr = refreshAccessToken mgr azureADKey--instance HasTokenReq AzureAD where- tokenReq _ mgr = fetchAccessToken mgr azureADKey--instance HasUserReq AzureAD where- userReq _ mgr at = do- re <- authGetJSON mgr at userInfoUri- return (second toLoginUser re)--instance HasAuthUri AzureAD where- authUri _ = createCodeUri azureADKey [ ("state", "AzureAD.test-state-123")- , ("scope", "openid,profile")- , ("resource", "https://graph.microsoft.com")- ]--newtype AzureADUser = AzureADUser { mail :: Text } deriving (Show, Generic)--instance FromJSON AzureADUser where- parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }--userInfoUri :: URI-userInfoUri = [uri|https://graph.microsoft.com/v1.0/me|]--toLoginUser :: AzureADUser -> LoginUser-toLoginUser ouser = LoginUser { loginUserName = mail ouser }
− example/IDP/Douban.hs
@@ -1,53 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--module IDP.Douban where-import Data.Aeson-import Data.Bifunctor-import Data.Hashable-import Data.Text.Lazy (Text)-import GHC.Generics-import Keys-import Network.OAuth.OAuth2-import Types-import URI.ByteString-import URI.ByteString.QQ-import Utils--data Douban = Douban deriving (Show, Generic)--instance Hashable Douban--instance IDP Douban--instance HasLabel Douban--instance HasTokenRefreshReq Douban where- tokenRefreshReq _ mgr = refreshAccessToken mgr doubanKey--instance HasTokenReq Douban where- tokenReq _ mgr = fetchAccessToken2 mgr doubanKey--instance HasUserReq Douban where- userReq _ mgr at = do- re <- authGetJSON mgr at userInfoUri- return (second toLoginUser re)--instance HasAuthUri Douban where- authUri _ = createCodeUri doubanKey [ ("state", "Douban.test-state-123")- ]--data DoubanUser = DoubanUser { name :: Text- , uid :: Text- } deriving (Show, Generic)--instance FromJSON DoubanUser where- parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }--userInfoUri :: URI-userInfoUri = [uri|https://api.douban.com/v2/user/~me|]--toLoginUser :: DoubanUser -> LoginUser-toLoginUser ouser = LoginUser { loginUserName = name ouser }-
− example/IDP/Dropbox.hs
@@ -1,60 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--module IDP.Dropbox where-import Data.Aeson-import Data.Bifunctor-import qualified Data.ByteString.Lazy.Char8 as BSL-import Data.Hashable-import Data.Text.Lazy (Text)-import GHC.Generics-import Keys-import Network.OAuth.OAuth2-import Types-import URI.ByteString-import URI.ByteString.QQ-import Utils--data Dropbox = Dropbox deriving (Show, Generic)--instance Hashable Dropbox--instance IDP Dropbox--instance HasLabel Dropbox--instance HasTokenReq Dropbox where- tokenReq _ mgr = fetchAccessToken mgr dropboxKey--instance HasTokenRefreshReq Dropbox where- tokenRefreshReq _ mgr = refreshAccessToken mgr dropboxKey--instance HasUserReq Dropbox where- userReq _ mgr at = do- re <- authPostBS3 mgr at userInfoUri- return (re >>= (bimap BSL.pack toLoginUser . eitherDecode))---instance HasAuthUri Dropbox where- authUri _ = createCodeUri dropboxKey [ ("state", "Dropbox.test-state-123")- ]--newtype DropboxName = DropboxName { displayName :: Text }- deriving (Show, Generic)--data DropboxUser = DropboxUser { email :: Text- , name :: DropboxName- } deriving (Show, Generic)--instance FromJSON DropboxName where- parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }--instance FromJSON DropboxUser where- parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }--userInfoUri :: URI-userInfoUri = [uri|https://api.dropboxapi.com/2/users/get_current_account|]--toLoginUser :: DropboxUser -> LoginUser-toLoginUser ouser = LoginUser { loginUserName = displayName $ name ouser }
− example/IDP/Facebook.hs
@@ -1,54 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--module IDP.Facebook where-import Data.Aeson-import Data.Bifunctor-import Data.Hashable-import Data.Text.Lazy (Text)-import GHC.Generics-import Keys-import Network.OAuth.OAuth2-import Types-import URI.ByteString-import URI.ByteString.QQ-import Utils--data Facebook = Facebook deriving (Show, Generic)--instance Hashable Facebook--instance IDP Facebook--instance HasLabel Facebook--instance HasTokenReq Facebook where- tokenReq _ mgr = fetchAccessToken2 mgr facebookKey--instance HasTokenRefreshReq Facebook where- tokenRefreshReq _ mgr = refreshAccessToken mgr facebookKey--instance HasUserReq Facebook where- userReq _ mgr at = do- re <- authGetJSON mgr at userInfoUri- return (second toLoginUser re)--instance HasAuthUri Facebook where- authUri _ = createCodeUri facebookKey [ ("state", "Facebook.test-state-123")- , ("scope", "user_about_me,email")- ]--data FacebookUser = FacebookUser { id :: Text- , name :: Text- , email :: Text- } deriving (Show, Generic)--instance FromJSON FacebookUser where- parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }--userInfoUri :: URI-userInfoUri = [uri|https://graph.facebook.com/me?fields=id,name,email|]--toLoginUser :: FacebookUser -> LoginUser-toLoginUser ouser = LoginUser { loginUserName = name ouser }
− example/IDP/Fitbit.hs
@@ -1,63 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--module IDP.Fitbit where-import Control.Monad (mzero)-import Data.Aeson-import Data.Bifunctor-import Data.Hashable-import Data.Text.Lazy (Text)-import GHC.Generics-import Keys-import Network.OAuth.OAuth2-import Types-import URI.ByteString-import URI.ByteString.QQ-import Utils---data Fitbit = Fitbit deriving (Show, Generic)--instance Hashable Fitbit--instance IDP Fitbit--instance HasLabel Fitbit--instance HasTokenReq Fitbit where- tokenReq _ mgr = fetchAccessToken mgr fitbitKey--instance HasTokenRefreshReq Fitbit where- tokenRefreshReq _ mgr = refreshAccessToken mgr fitbitKey--instance HasUserReq Fitbit where- userReq _ mgr at = do- re <- authGetJSON mgr at userInfoUri- return (second toLoginUser re)--instance HasAuthUri Fitbit where- authUri _ = createCodeUri fitbitKey [ ("state", "Fitbit.test-state-123")- , ("scope", "profile")- ]--data FitbitUser = FitbitUser- { userId :: Text- , userName :: Text- , userAge :: Int- } deriving (Show, Eq)--instance FromJSON FitbitUser where- parseJSON (Object o) =- FitbitUser- <$> ((o .: "user") >>= (.: "encodedId"))- <*> ((o .: "user") >>= (.: "fullName"))- <*> ((o .: "user") >>= (.: "age"))- parseJSON _ = mzero---userInfoUri :: URI-userInfoUri = [uri|https://api.fitbit.com/1/user/-/profile.json|]--toLoginUser :: FitbitUser -> LoginUser-toLoginUser ouser = LoginUser { loginUserName = userName ouser }
− example/IDP/Github.hs
@@ -1,51 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--module IDP.Github where-import Data.Aeson-import Data.Bifunctor-import Data.Hashable-import Data.Text.Lazy (Text)-import GHC.Generics-import Keys-import Network.OAuth.OAuth2-import Types-import URI.ByteString-import URI.ByteString.QQ-import Utils--data Github = Github deriving (Show, Generic)--instance Hashable Github--instance IDP Github--instance HasLabel Github--instance HasTokenReq Github where- tokenReq _ mgr = fetchAccessToken mgr githubKey--instance HasTokenRefreshReq Github where- tokenRefreshReq _ mgr = refreshAccessToken mgr githubKey--instance HasUserReq Github where- userReq _ mgr at = do- re <- authGetJSON mgr at userInfoUri- return (second toLoginUser re)--instance HasAuthUri Github where- authUri _ = createCodeUri githubKey [("state", "Github.test-state-123")]--data GithubUser = GithubUser { name :: Text- , id :: Integer- } deriving (Show, Generic)--instance FromJSON GithubUser where- parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }--userInfoUri :: URI-userInfoUri = [uri|https://api.github.com/user|]--toLoginUser :: GithubUser -> LoginUser-toLoginUser guser = LoginUser { loginUserName = name guser }
− example/IDP/Google.hs
@@ -1,54 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--module IDP.Google where-import Data.Aeson-import Data.Bifunctor-import Data.Hashable-import Data.Text.Lazy (Text)-import GHC.Generics-import Keys-import Network.OAuth.OAuth2-import Types-import URI.ByteString-import URI.ByteString.QQ-import Utils--data Google = Google deriving (Show, Generic)--instance Hashable Google--instance IDP Google--instance HasLabel Google--instance HasTokenReq Google where- tokenReq _ mgr = fetchAccessToken mgr googleKey--instance HasTokenRefreshReq Google where- tokenRefreshReq _ mgr = refreshAccessToken mgr googleKey--instance HasUserReq Google where- userReq _ mgr at = do- re <- authGetJSON mgr at userInfoUri- return (second toLoginUser re)--instance HasAuthUri Google where- authUri _ = createCodeUri googleKey [ ("state", "Google.test-state-123")- , ("scope", "https://www.googleapis.com/auth/userinfo.email")- ]--data GoogleUser = GoogleUser { name :: Text- , id :: Text- } deriving (Show, Generic)--instance FromJSON GoogleUser where- parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }--userInfoUri :: URI-userInfoUri = [uri|https://www.googleapis.com/oauth2/v2/userinfo|]--toLoginUser :: GoogleUser -> LoginUser-toLoginUser guser = LoginUser { loginUserName = name guser }-
− example/IDP/Linkedin.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RecordWildCards #-}--{-- disabled since it's not yet working. error:- - serviceErrorCode:100- - message:Not enough permissions to access /me GET--}-module IDP.Linkedin where-import Data.Aeson-import Data.Text.Lazy (Text)-import qualified Data.Text.Lazy as TL-import GHC.Generics-import Types-import URI.ByteString-import URI.ByteString.QQ--data LinkedinUser = LinkedinUser { firstName :: Text- , lastName :: Text- } deriving (Show, Generic)--instance FromJSON LinkedinUser where- parseJSON = genericParseJSON defaultOptions--userInfoUri :: URI-userInfoUri = [uri|https://api.linkedin.com/v2/me|]---toLoginUser :: LinkedinUser -> LoginUser-toLoginUser LinkedinUser {..} = LoginUser { loginUserName = firstName `TL.append` " " `TL.append` lastName }--{--mkIDPData Linkedin =- let userUri = createCodeUri linkedinKey [("state", "linkedin.test-state-123")]- in- IDPData { codeFlowUri = userUri- , loginUser = Nothing- , idpName = Linkedin- , oauth2Key = linkedinKey- , toFetchAccessToken = postAT- , userApiUri = ILinkedin.userInfoUri- , toLoginUser = ILinkedin.toLoginUser- }--}
− example/IDP/Okta.hs
@@ -1,62 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--module IDP.Okta where-import Data.Aeson-import Data.Bifunctor-import Data.Hashable-import Data.Text.Lazy ( Text )-import GHC.Generics-import Keys-import Network.OAuth.OAuth2-import Types-import URI.ByteString-import URI.ByteString.QQ-import Utils--data Okta = Okta- deriving (Show, Generic)--instance Hashable Okta--instance IDP Okta--instance HasLabel Okta--instance HasTokenReq Okta where- tokenReq _ mgr = fetchAccessToken mgr oktaKey--instance HasTokenRefreshReq Okta where- tokenRefreshReq _ mgr = refreshAccessToken mgr oktaKey--instance HasUserReq Okta where- userReq _ mgr at = do- re <- authGetJSON mgr at userInfoUri- return (second toLoginUser re)--instance HasAuthUri Okta where- authUri _ = createCodeUri- oktaKey- [ ("state", "Okta.test-state-123")- , ( "scope"- , "openid profile offline_access okta.users.read.self okta.users.read"- )- ]--data OktaUser = OktaUser- { name :: Text- , preferredUsername :: Text- }- deriving (Show, Generic)--instance FromJSON OktaUser where- parseJSON =- genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }--userInfoUri :: URI-userInfoUri = [uri|http://rain.okta1.com:1802/oauth2/v1/userinfo|]--toLoginUser :: OktaUser -> LoginUser-toLoginUser ouser = LoginUser { loginUserName = name ouser }-
− example/IDP/StackExchange.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RecordWildCards #-}--{-- NOTES: stackexchange API spec and its document just sucks!--}-module IDP.StackExchange where-import Data.Aeson-import Data.Bifunctor-import Data.ByteString (ByteString)-import qualified Data.ByteString.Lazy.Char8 as BSL-import Data.Hashable-import Data.Text.Lazy (Text)-import qualified Data.Text.Lazy as TL-import GHC.Generics-import Keys-import Lens.Micro-import Network.OAuth.OAuth2-import Types-import URI.ByteString-import URI.ByteString.QQ-import Utils--data StackExchange = StackExchange deriving (Show, Generic)--instance Hashable StackExchange--instance IDP StackExchange--instance HasLabel StackExchange--instance HasTokenReq StackExchange where- tokenReq _ mgr = fetchAccessToken2 mgr stackexchangeKey--instance HasTokenRefreshReq StackExchange where- tokenRefreshReq _ mgr = refreshAccessToken mgr stackexchangeKey--instance HasUserReq StackExchange where- userReq _ mgr token = do- re <- authGetBS2 mgr token- (userInfoUri `appendStackExchangeAppKey` stackexchangeAppKey)- return (re >>= (bimap BSL.pack toLoginUser . eitherDecode))--instance HasAuthUri StackExchange where- authUri _ = createCodeUri stackexchangeKey [ ("state", "StackExchange.test-state-123")- ]--data StackExchangeResp = StackExchangeResp { hasMore :: Bool- , quotaMax :: Integer- , quotaRemaining :: Integer- , items :: [StackExchangeUser]- } deriving (Show, Generic)--data StackExchangeUser = StackExchangeUser { userId :: Integer- , displayName :: Text- , profileImage :: Text- } deriving (Show, Generic)--instance FromJSON StackExchangeResp where- parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }-instance FromJSON StackExchangeUser where- parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }--userInfoUri :: URI-userInfoUri = [uri|https://api.stackexchange.com/2.2/me?site=stackoverflow|]--toLoginUser :: StackExchangeResp -> LoginUser-toLoginUser StackExchangeResp {..} =- case items of- [] -> LoginUser { loginUserName = TL.pack "Cannot find stackexchange user" }- (user:_) -> LoginUser { loginUserName = displayName user }--appendStackExchangeAppKey :: URI -> ByteString -> URI-appendStackExchangeAppKey useruri k =- over (queryL . queryPairsL) (\query -> query ++ [("key", k)]) useruri
− example/IDP/Weibo.hs
@@ -1,71 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--module IDP.Weibo where--import Data.Aeson-import Data.Bifunctor-import qualified Data.ByteString.Lazy.Char8 as BSL-import Data.Hashable-import Data.Text.Lazy (Text)-import qualified Data.Text.Lazy as TL-import GHC.Generics-import Keys-import Network.OAuth.OAuth2-import Types-import URI.ByteString-import URI.ByteString.QQ-import Utils--data Weibo = Weibo deriving (Show, Generic)--instance Hashable Weibo--instance IDP Weibo--instance HasLabel Weibo--instance HasTokenRefreshReq Weibo where- tokenRefreshReq _ mgr = refreshAccessToken mgr weiboKey--instance HasTokenReq Weibo where- tokenReq _ mgr = fetchAccessToken mgr weiboKey---- fetch user info via--- GET--- access token in query param only-instance HasUserReq Weibo where- userReq _ mgr at = do- re <- authGetBS2 mgr at userInfoUri- return (re >>= (bimap BSL.pack toLoginUser . eitherDecode))--instance HasAuthUri Weibo where- authUri _ =- createCodeUri- weiboKey- [ ("state", "Weibo.test-state-123")- ]---- | UserInfor API: http://open.weibo.com/wiki/2/users/show-data WeiboUser = WeiboUser- { id :: Integer,- name :: Text,- screenName :: Text- }- deriving (Show, Generic)--newtype WeiboUID = WeiboUID {uid :: Integer}- deriving (Show, Generic)--instance FromJSON WeiboUID where- parseJSON = genericParseJSON defaultOptions {fieldLabelModifier = camelTo2 '_'}--instance FromJSON WeiboUser where- parseJSON = genericParseJSON defaultOptions {fieldLabelModifier = camelTo2 '_'}--userInfoUri :: URI-userInfoUri = [uri|https://api.weibo.com/2/account/get_uid.json|]--toLoginUser :: WeiboUID -> LoginUser-toLoginUser ouser = LoginUser {loginUserName = TL.pack $ show $ uid ouser}
− example/IDP/ZOHO.hs
@@ -1,69 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--module IDP.ZOHO where-import Data.Aeson-import Data.Bifunctor-import Data.Hashable-import Data.Text.Lazy (Text)-import GHC.Generics-import Keys-import Network.OAuth.OAuth2-import Types-import URI.ByteString-import URI.ByteString.QQ-import Utils--data ZOHO = ZOHO deriving (Show, Generic)--instance Hashable ZOHO--instance IDP ZOHO--instance HasLabel ZOHO--instance HasTokenReq ZOHO where- tokenReq _ mgr = fetchAccessToken2 mgr zohoKey--instance HasTokenRefreshReq ZOHO where- tokenRefreshReq _ mgr = refreshAccessToken2 mgr zohoKey--instance HasUserReq ZOHO where- userReq _ mgr at = do- re <- authGetJSON mgr at userInfoUri- return (second toLoginUser re)--instance HasAuthUri ZOHO where- authUri _ = createCodeUri zohoKey [ ("state", "ZOHO.test-state-123")- , ("scope", "ZohoCRM.users.READ")- , ("access_type", "offline")- , ("prompt", "consent")- ]--data ZOHOUser = ZOHOUser { email :: Text- , fullName :: Text- } deriving (Show, Generic)--newtype ZOHOUserResp = ZOHOUserResp { users :: [ZOHOUser] }- deriving (Show, Generic)--instance FromJSON ZOHOUserResp where- parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }--instance FromJSON ZOHOUser where- parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }--userInfoUri :: URI-userInfoUri = [uri|https://www.zohoapis.com/crm/v2/users|]- -- `oauth/user/info` url does not work and find answer from- -- https://help.zoho.com/portal/community/topic/oauth2-api-better-document-oauth-user-info--toLoginUser :: ZOHOUserResp -> LoginUser-toLoginUser resp =- let us = users resp- in- case us of- [] -> LoginUser { loginUserName = "no user found" }- (a:_) -> LoginUser { loginUserName = fullName a }-
− example/Keys.hs
@@ -1,129 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--module Keys where--import Data.ByteString ( ByteString )-import Network.OAuth.OAuth2-import URI.ByteString.QQ--weiboKey :: OAuth2-weiboKey = OAuth2- { oauthClientId = "xxxxxxxxxxxxxxx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://127.0.0.1:9988/oauthCallback|]- , oauthOAuthorizeEndpoint = [uri|https://api.weibo.com/oauth2/authorize|]- , oauthAccessTokenEndpoint = [uri|https://api.weibo.com/oauth2/access_token|]- }---- | http://developer.github.com/v3/oauth/-githubKey :: OAuth2-githubKey = OAuth2- { oauthClientId = "xxxxxxxxxxxxxxx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://127.0.0.1:9988/githubCallback|]- , oauthOAuthorizeEndpoint = [uri|https://github.com/login/oauth/authorize|]- , oauthAccessTokenEndpoint =- [uri|https://github.com/login/oauth/access_token|]- }---- | oauthCallback = Just "https://developers.google.com/oauthplayground"-googleKey :: OAuth2-googleKey = OAuth2- { oauthClientId = "xxxxxxxxxxxxxxx.apps.googleusercontent.com"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://127.0.0.1:9988/googleCallback|]- , oauthOAuthorizeEndpoint = [uri|https://accounts.google.com/o/oauth2/auth|]- , oauthAccessTokenEndpoint = [uri|https://www.googleapis.com/oauth2/v3/token|]- }--facebookKey :: OAuth2-facebookKey = OAuth2- { oauthClientId = "xxxxxxxxxxxxxxx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://t.haskellcn.org/cb|]- , oauthOAuthorizeEndpoint = [uri|https://www.facebook.com/dialog/oauth|]- , oauthAccessTokenEndpoint =- [uri|https://graph.facebook.com/v2.3/oauth/access_token|]- }--doubanKey :: OAuth2-doubanKey = OAuth2- { oauthClientId = "xxxxxxxxxxxxxxx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://localhost:9999/oauthCallback|]- , oauthOAuthorizeEndpoint = [uri|https://www.douban.com/service/auth2/auth|]- , oauthAccessTokenEndpoint = [uri|https://www.douban.com/service/auth2/token|]- }--fitbitKey :: OAuth2-fitbitKey = OAuth2- { oauthClientId = "xxxxxx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint = [uri|https://www.fitbit.com/oauth2/authorize|]- , oauthAccessTokenEndpoint = [uri|https://api.fitbit.com/oauth2/token|]- }---- fix key from your application edit page--- https://stackapps.com/apps/oauth-stackexchangeAppKey :: ByteString-stackexchangeAppKey = "xxxxxx"--stackexchangeKey :: OAuth2-stackexchangeKey = OAuth2- { oauthClientId = "xx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://c.haskellcn.org/cb|]- , oauthOAuthorizeEndpoint = [uri|https://stackexchange.com/oauth|]- , oauthAccessTokenEndpoint =- [uri|https://stackexchange.com/oauth/access_token|]- }-dropboxKey :: OAuth2-dropboxKey = OAuth2- { oauthClientId = "xxx"- , oauthClientSecret = Just "xxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint = [uri|https://www.dropbox.com/1/oauth2/authorize|]- , oauthAccessTokenEndpoint = [uri|https://api.dropboxapi.com/oauth2/token|]- }--oktaKey :: OAuth2-oktaKey = OAuth2- { oauthClientId = "xxx"- , oauthClientSecret = Just "xxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint =- [uri|https://dev-148986.oktapreview.com/oauth2/v1/authorize|]- , oauthAccessTokenEndpoint =- [uri|https://dev-148986.oktapreview.com/oauth2/v1/token|]- }--azureADKey :: OAuth2-azureADKey = OAuth2- { oauthClientId = "xxx"- , oauthClientSecret = Just "xxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint =- [uri|https://login.windows.net/common/oauth2/authorize|]- , oauthAccessTokenEndpoint =- [uri|https://login.windows.net/common/oauth2/token|]- }--zohoKey :: OAuth2-zohoKey = OAuth2- { oauthClientId = "xxx"- , oauthClientSecret = Just "xxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint = [uri|https://accounts.zoho.com/oauth/v2/auth|]- , oauthAccessTokenEndpoint = [uri|https://accounts.zoho.com/oauth/v2/token|]- }--auth0Key :: OAuth2-auth0Key = OAuth2- { oauthClientId = "xxx"- , oauthClientSecret = Just "xxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint = [uri|https://foo.auth0.com/authorize|]- , oauthAccessTokenEndpoint = [uri|https://foo.auth0.com/oauth/token|]- }
− example/Keys.hs.sample
@@ -1,129 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--module Keys where--import Data.ByteString ( ByteString )-import Network.OAuth.OAuth2-import URI.ByteString.QQ--weiboKey :: OAuth2-weiboKey = OAuth2- { oauthClientId = "xxxxxxxxxxxxxxx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://127.0.0.1:9988/oauthCallback|]- , oauthOAuthorizeEndpoint = [uri|https://api.weibo.com/oauth2/authorize|]- , oauthAccessTokenEndpoint = [uri|https://api.weibo.com/oauth2/access_token|]- }---- | http://developer.github.com/v3/oauth/-githubKey :: OAuth2-githubKey = OAuth2- { oauthClientId = "xxxxxxxxxxxxxxx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://127.0.0.1:9988/githubCallback|]- , oauthOAuthorizeEndpoint = [uri|https://github.com/login/oauth/authorize|]- , oauthAccessTokenEndpoint =- [uri|https://github.com/login/oauth/access_token|]- }---- | oauthCallback = Just "https://developers.google.com/oauthplayground"-googleKey :: OAuth2-googleKey = OAuth2- { oauthClientId = "xxxxxxxxxxxxxxx.apps.googleusercontent.com"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://127.0.0.1:9988/googleCallback|]- , oauthOAuthorizeEndpoint = [uri|https://accounts.google.com/o/oauth2/auth|]- , oauthAccessTokenEndpoint = [uri|https://www.googleapis.com/oauth2/v3/token|]- }--facebookKey :: OAuth2-facebookKey = OAuth2- { oauthClientId = "xxxxxxxxxxxxxxx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://t.haskellcn.org/cb|]- , oauthOAuthorizeEndpoint = [uri|https://www.facebook.com/dialog/oauth|]- , oauthAccessTokenEndpoint =- [uri|https://graph.facebook.com/v2.3/oauth/access_token|]- }--doubanKey :: OAuth2-doubanKey = OAuth2- { oauthClientId = "xxxxxxxxxxxxxxx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://localhost:9999/oauthCallback|]- , oauthOAuthorizeEndpoint = [uri|https://www.douban.com/service/auth2/auth|]- , oauthAccessTokenEndpoint = [uri|https://www.douban.com/service/auth2/token|]- }--fitbitKey :: OAuth2-fitbitKey = OAuth2- { oauthClientId = "xxxxxx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint = [uri|https://www.fitbit.com/oauth2/authorize|]- , oauthAccessTokenEndpoint = [uri|https://api.fitbit.com/oauth2/token|]- }---- fix key from your application edit page--- https://stackapps.com/apps/oauth-stackexchangeAppKey :: ByteString-stackexchangeAppKey = "xxxxxx"--stackexchangeKey :: OAuth2-stackexchangeKey = OAuth2- { oauthClientId = "xx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://c.haskellcn.org/cb|]- , oauthOAuthorizeEndpoint = [uri|https://stackexchange.com/oauth|]- , oauthAccessTokenEndpoint =- [uri|https://stackexchange.com/oauth/access_token|]- }-dropboxKey :: OAuth2-dropboxKey = OAuth2- { oauthClientId = "xxx"- , oauthClientSecret = Just "xxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint = [uri|https://www.dropbox.com/1/oauth2/authorize|]- , oauthAccessTokenEndpoint = [uri|https://api.dropboxapi.com/oauth2/token|]- }--oktaKey :: OAuth2-oktaKey = OAuth2- { oauthClientId = "xxx"- , oauthClientSecret = Just "xxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint =- [uri|https://dev-148986.oktapreview.com/oauth2/v1/authorize|]- , oauthAccessTokenEndpoint =- [uri|https://dev-148986.oktapreview.com/oauth2/v1/token|]- }--azureADKey :: OAuth2-azureADKey = OAuth2- { oauthClientId = "xxx"- , oauthClientSecret = Just "xxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint =- [uri|https://login.windows.net/common/oauth2/authorize|]- , oauthAccessTokenEndpoint =- [uri|https://login.windows.net/common/oauth2/token|]- }--zohoKey :: OAuth2-zohoKey = OAuth2- { oauthClientId = "xxx"- , oauthClientSecret = Just "xxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint = [uri|https://accounts.zoho.com/oauth/v2/auth|]- , oauthAccessTokenEndpoint = [uri|https://accounts.zoho.com/oauth/v2/token|]- }--auth0Key :: OAuth2-auth0Key = OAuth2- { oauthClientId = "xxx"- , oauthClientSecret = Just "xxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint = [uri|https://foo.auth0.com/authorize|]- , oauthAccessTokenEndpoint = [uri|https://foo.auth0.com/oauth/token|]- }
− example/README.org
@@ -1,26 +0,0 @@-* IDPs--- Auth0: <https://auth0.com/docs/authorization/protocols/protocol-oauth2>-- AzureAD: <https://docs.microsoft.com/en-us/azure/active-directory/develop/v1-protocols-oauth-code>-- Douban: <http://developers.douban.com/wiki/?title=oauth2>-- DropBox: <https://www.dropbox.com/developers/reference/oauth-guide>-- Facebook: <http://developers.facebook.com/docs/facebook-login/>-- Fitbit: <http://dev.fitbit.com/docs/oauth2/>-- Github: <http://developer.github.com/v3/oauth/>-- Google: <https://developers.google.com/accounts/docs/OAuth2WebServer>-- Okta: https://developer.okta.com/docs/reference/api/oidc/-- StackExchange: <https://api.stackexchange.com/docs/authentication>- - StackExchange Apps page: <https://stackapps.com/apps/oauth>-- Weibo: <http://open.weibo.com/wiki/Oauth2>-- ZOHO: https://www.zoho.com/crm/developer/docs/api/v2/oauth-overview.html--* WIP: Linkedin-- - <https://developer.linkedin.com>--* NOTES-- classes in Types.hs takes a (`IDP`) as first parameter but it is actually not used. bad pattern. how to fix it??-- refactor: `App.hs` is messy!-- It is tedious to add a new IDP (especially support OIDC)- a. creates entry in ~Key.hs~- b. creates a IDP module which mostly are boilerpate code, needs reference to OAuth2 Key object multiple times
− example/Session.hs
@@ -1,38 +0,0 @@-{-# LANGUAGE RankNTypes #-}--{- mimic server side session store -}--module Session where--import Control.Concurrent.MVar-import qualified Data.HashMap.Strict as Map--import Types--initCacheStore :: IO CacheStore-initCacheStore = newMVar Map.empty--allValues :: CacheStore -> IO [IDPData]-allValues store = do- m1 <- tryReadMVar store- return $ maybe [] Map.elems m1--removeKey :: CacheStore -> IDPLabel -> IO ()-removeKey store idpKey = do- m1 <- takeMVar store- let m2 = Map.update updateIdpData idpKey m1- putMVar store m2- where updateIdpData idpD = Just $ idpD { loginUser = Nothing }--lookupKey :: CacheStore- -> IDPLabel- -> IO (Maybe IDPData)-lookupKey store idpKey = do- m1 <- tryReadMVar store- return (Map.lookup idpKey =<< m1)--insertIDPData :: CacheStore -> IDPData -> IO ()-insertIDPData store val = do- m1 <- takeMVar store- let m2 = Map.insert (idpDisplayLabel val) val m1- putMVar store m2
− example/Types.hs
@@ -1,116 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}--module Types where--import Control.Concurrent.MVar-import Data.Aeson-import qualified Data.ByteString.Lazy.Char8 as BSL-import qualified Data.HashMap.Strict as Map-import Data.Hashable-import Data.Maybe-import Data.Text.Lazy-import qualified Data.Text.Lazy as TL-import GHC.Generics-import Network.HTTP.Conduit-import Network.OAuth.OAuth2-import qualified Network.OAuth.OAuth2.TokenRequest as TR-import Text.Mustache-import qualified Text.Mustache as M--type IDPLabel = Text--type CacheStore = MVar (Map.HashMap IDPLabel IDPData)---- * type class for defining a IDP-----class (Hashable a, Show a) => IDP a--class (IDP a) => HasLabel a where- idpLabel :: a -> IDPLabel- idpLabel = TL.pack . show--class (IDP a) => HasAuthUri a where- authUri :: a -> Text--class (IDP a) => HasTokenReq a where- tokenReq :: a -> Manager -> ExchangeToken -> IO (OAuth2Result TR.Errors OAuth2Token)--class (IDP a) => HasTokenRefreshReq a where- tokenRefreshReq :: a -> Manager -> RefreshToken -> IO (OAuth2Result TR.Errors OAuth2Token)--class (IDP a) => HasUserReq a where- userReq :: a -> Manager -> AccessToken -> IO (Either BSL.ByteString LoginUser)---- Heterogenous collections--- https://wiki.haskell.org/Heterogenous_collections----data IDPApp- = forall a.- ( HasTokenRefreshReq a,- HasTokenReq a,- HasUserReq a,- HasLabel a,- HasAuthUri a- ) =>- IDPApp a---- dummy oauth2 request error----data Errors- = SomeRandomError- deriving (Show, Eq, Generic)--instance FromJSON Errors where- parseJSON = genericParseJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}--newtype LoginUser = LoginUser- { loginUserName :: Text- }- deriving (Eq, Show)--data IDPData = IDPData- { codeFlowUri :: Text,- loginUser :: Maybe LoginUser,- oauth2Token :: Maybe OAuth2Token,- idpDisplayLabel :: IDPLabel- }---- simplify use case to only allow one idp instance for now.-instance Eq IDPData where- a == b = idpDisplayLabel a == idpDisplayLabel b--instance Ord IDPData where- a `compare` b = idpDisplayLabel a `compare` idpDisplayLabel b--newtype TemplateData = TemplateData- { idpTemplateData :: [IDPData]- }- deriving (Eq)---- * Mustache instances--instance ToMustache IDPData where- toMustache t' =- M.object- [ "codeFlowUri" ~> codeFlowUri t',- "isLogin" ~> isJust (loginUser t'),- "user" ~> loginUser t',- "name" ~> TL.unpack (idpDisplayLabel t')- ]--instance ToMustache LoginUser where- toMustache t' =- M.object- ["name" ~> loginUserName t']--instance ToMustache TemplateData where- toMustache td' =- M.object- [ "idps" ~> idpTemplateData td'- ]
− example/Utils.hs
@@ -1,37 +0,0 @@-module Utils where--import qualified Data.Aeson as Aeson-import Data.ByteString (ByteString)-import qualified Data.ByteString.Lazy.Char8 as BSL-import qualified Data.Text.Encoding as TE-import Data.Text.Lazy (Text)-import qualified Data.Text.Lazy as TL--import Network.OAuth.OAuth2-import URI.ByteString-import Web.Scotty.Internal.Types--tlToBS :: TL.Text -> ByteString-tlToBS = TE.encodeUtf8 . TL.toStrict--bslToText :: BSL.ByteString -> Text-bslToText = TL.pack . BSL.unpack--paramValue :: Text -> [Param] -> [Text]-paramValue key = fmap snd . filter (hasParam key)--hasParam :: Text -> Param -> Bool-hasParam t = (== t) . fst--parseValue :: Aeson.FromJSON a => Maybe Aeson.Value -> Maybe a-parseValue Nothing = Nothing-parseValue (Just a) = case Aeson.fromJSON a of- Aeson.Error _ -> Nothing- Aeson.Success b -> Just b--createCodeUri :: OAuth2- -> [(ByteString, ByteString)]- -> Text-createCodeUri key params = TL.fromStrict $ TE.decodeUtf8 $ serializeURIRef'- $ appendQueryParams params- $ authorizationUrl key
− example/Views.hs
@@ -1,39 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Views where--import Control.Monad.IO.Class (liftIO)-import Data.List (sort)-import qualified Data.Text.Lazy as TL-import Text.Mustache-import Text.Parsec.Error-import Web.Scotty--import Types--type CookieUser = String--tpl :: FilePath -> IO (Either ParseError Template)-tpl f = automaticCompile ["./example/templates", "./templates"] (f ++ ".mustache")--tplS :: FilePath- -> [IDPData]- -> IO TL.Text-tplS path xs = do- template <- tpl path- case template of- Left e -> return- $ TL.unlines- $ map TL.pack [ "can not parse template " ++ path ++ ".mustache" , show e ]- Right t' -> return $ TL.fromStrict $ substitute t' (TemplateData $ sort xs)--tplH :: FilePath- -> [IDPData]- -> ActionM ()-tplH path xs = do- s <- liftIO (tplS path xs)- html s---overviewTpl :: [IDPData] -> ActionM ()-overviewTpl = tplH "index"
− example/assets/main.css
@@ -1,11 +0,0 @@-body {- padding: 10px 50px;-}--.login-with {- margin: 10px 0;- padding: 10px;- border: 1px solid grey;- border-radius: 5px;- width: 500px;-}
− example/main.hs
@@ -1,6 +0,0 @@-module Main where--import App (app)--main :: IO ()-main = app
− example/templates/index.mustache
@@ -1,31 +0,0 @@-<html>- <head>- <link href="/main.css" rel="stylesheet"/>- </head>- <body>- <h1>Hello OAuth2</h1>- {{#idps}}- <section class="login-with">-- {{^isLogin}}- <a href="{{codeFlowUri}}">Login {{name}}</a>- {{/isLogin}}-- {{#isLogin}}- <h2>Welcome to {{name}}</h2>- {{#user}}- <div class="result">Hello, {{name}}</div>- {{/user}}- <a href="/logout?idp={{name}}">Logout</a>- <a href="/refresh?idp={{name}}">Refresh</a>- {{/isLogin}}-- </section>- {{/idps}}- <h2>Notes</h2>- <ol>- <li>for StackExchange, the callback domain is localhost, have manually add port 9988.</li>- </ol>- </p>- </body>-</html>
hoauth2.cabal view
@@ -1,143 +1,122 @@-Cabal-version: 2.4-Name: hoauth2+cabal-version: 2.4+name: hoauth2+ -- http://wiki.haskell.org/Package_versioning_policy-Version: 1.16.2+version: 2.15.1+synopsis: Haskell OAuth2 authentication client+description:+ This package provides Haskell bindings for the OAuth2 Authorization Framework and Bearer Token Usage. -Synopsis: Haskell OAuth2 authentication client+homepage: https://github.com/freizl/hoauth2+license: MIT+license-file: LICENSE+author: Haisheng Wu+maintainer: Haisheng Wu <freizl@gmail.com>+copyright: Haisheng Wu+category: Network+build-type: Simple+stability: Beta+tested-with:+ GHC ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.4 || ==9.6.1 || ==9.8.2 -Description: Haskell OAuth2 authentication client. Tested with the following services:- .- * AzureAD: <https://docs.microsoft.com/en-us/azure/active-directory/develop/v1-protocols-oauth-code>- .- * Google: <https://developers.google.com/accounts/docs/OAuth2WebServer>- .- * Github: <http://developer.github.com/v3/oauth/>- .- * Facebook: <http://developers.facebook.com/docs/facebook-login/>- .- * Fitbit: <http://dev.fitbit.com/docs/oauth2/>- .- * StackExchange: <https://api.stackexchange.com/docs/authentication>- .- * DropBox: <https://www.dropbox.com/developers/reference/oauth-guide>- .- * Weibo: <http://open.weibo.com/wiki/Oauth2>- .- * Douban: <http://developers.douban.com/wiki/?title=oauth2>+extra-source-files:+ CHANGELOG.md+ README.md -Homepage: https://github.com/freizl/hoauth2-License: BSD-3-Clause-License-file: LICENSE-Author: Haisheng Wu-Maintainer: Haisheng Wu <freizl@gmail.com>-Copyright: Haisheng Wu-Category: Network-Build-type: Simple-Stability: Beta-Tested-With: GHC <= 8.6.5+source-repository head+ type: git+ location: https://github.com/freizl/hoauth2.git -Extra-source-files: README.md- example/Keys.hs.sample- example/IDP/AzureAD.hs- example/IDP/Google.hs- example/IDP/Weibo.hs- example/IDP/Github.hs- example/IDP/Facebook.hs- example/IDP/Fitbit.hs- example/IDP/Douban.hs- example/IDP/Linkedin.hs- example/IDP/Auth0.hs- example/IDP.hs- example/App.hs- example/Session.hs- example/Types.hs- example/Utils.hs- example/Views.hs- example/main.hs- example/README.org- example/templates/index.mustache- example/assets/main.css+library+ hs-source-dirs: src+ default-language: Haskell2010+ autogen-modules: Paths_hoauth2+ other-modules:+ Network.HTTP.Client.Contrib+ Network.OAuth2.Internal+ Network.OAuth2.Experiment.Grants+ Network.OAuth2.Experiment.Utils+ Paths_hoauth2 -Source-Repository head- Type: git- Location: git://github.com/freizl/hoauth2.git+ exposed-modules:+ Network.OAuth2+ Network.OAuth2.AuthorizationRequest+ Network.OAuth2.HttpClient+ Network.OAuth2.TokenRequest+ Network.OAuth2.Experiment+ Network.OAuth2.Experiment.Flows+ 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 -Flag test- Description: Build the executables- Default: False+ default-extensions:+ DeriveGeneric+ GeneralizedNewtypeDeriving+ ImportQualifiedPost+ InstanceSigs+ OverloadedStrings+ PolyKinds+ RecordWildCards+ TypeFamilies -Library- hs-source-dirs: src- default-language: Haskell2010- Exposed-modules: Network.OAuth.OAuth2.HttpClient- Network.OAuth.OAuth2.Internal- Network.OAuth.OAuth2- Network.OAuth.OAuth2.TokenRequest- Network.OAuth.OAuth2.AuthorizationRequest+ build-depends:+ , aeson >=2.0 && <2.3+ , base >=4.11 && <5+ , base64 >=1.0 && <1.1+ , binary >=0.8 && <0.11+ , binary-instances >=1.0 && <1.1+ , bytestring >=0.9 && <0.13+ , containers >=0.6 && <0.9+ , crypton >=0.32 && <1.1+ , data-default ^>=0.8+ , 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.6+ , text >=2.0 && <2.3+ , transformers >=0.4 && <0.7+ , uri-bytestring >=0.4 && <0.5+ , uri-bytestring-aeson ^>=0.1 - Build-Depends: base >= 4 && < 5,- binary >= 0.8.3.0 && < 0.8.9,- text >= 0.11 && < 1.3,- bytestring >= 0.9 && < 0.11,- http-conduit >= 2.1 && < 2.4,- http-types >= 0.11 && < 0.13,- aeson >= 1.3.0.0 && < 1.6,- unordered-containers >= 0.2.5,- uri-bytestring >= 0.2.3.1 && < 0.4,- uri-bytestring-aeson >= 0.1 && < 0.2,- microlens >= 0.4.0 && < 0.5,- exceptions >= 0.8.3 && < 0.11+ ghc-options:+ -Wall -Wtabs -Wno-unused-do-bind -Wunused-packages -Wpartial-fields+ -Wwarn -Wwarnings-deprecations - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields- -fno-warn-unused-do-bind+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.3+ , base >=4.11 && <5+ , binary >=0.8 && <0.11+ , hoauth2+ , hspec >=2 && <3+ , uri-bytestring >=0.4 && <0.5+ , http-conduit >=2.1 && <2.4 -Executable demo-server- if flag(test)- Buildable: True- else- Buildable: False+ other-modules:+ Network.OAuth2.InternalSpec+ Network.OAuth2.TokenRequestSpec+ Network.OAuth2.TokenResponseSpec - main-is: main.hs- other-modules: IDP,- App- IDP.AzureAD- IDP.Douban- IDP.Dropbox- IDP.Facebook- IDP.Fitbit- IDP.Github- IDP.Google- IDP.Auth0- IDP.Okta- IDP.StackExchange- IDP.Weibo- IDP.Linkedin- IDP.ZOHO- Keys- Session- Types- Utils- Views- hs-source-dirs: example- default-language: Haskell2010- build-depends: base >= 4.5 && < 5,- text >= 0.11 && < 1.3,- bytestring >= 0.9 && < 0.11,- uri-bytestring >= 0.2.3.1 && < 0.4,- http-conduit >= 2.1 && < 2.4,- http-types >= 0.11 && < 0.13,- wai >= 3.2 && < 3.3,- warp >= 3.2 && < 3.4,- aeson >= 1.3.0.0 && < 1.6,- microlens >= 0.4.0 && < 0.5,- unordered-containers >= 0.2.5,- wai-middleware-static >= 0.8.1 && < 0.10.0,- mustache >= 2.2.3 && < 2.5.0,- scotty >= 0.10.0 && < 0.13,- binary >= 0.8.3.0 && < 0.8.9,- parsec >= 3.1.11 && < 3.2.0 ,- hashable >= 1.2.6 && < 1.5.0,- hoauth2+ default-language: Haskell2010+ default-extensions:+ ImportQualifiedPost+ OverloadedStrings - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields- -fno-warn-unused-do-bind -fno-warn-orphans+ build-tool-depends: hspec-discover:hspec-discover >=2 && <3+ ghc-options:+ -Wall -Wtabs -Wno-unused-do-bind -Wunused-packages -Wpartial-fields+ -Wwarn -Wwarnings-deprecations
+ src/Network/HTTP/Client/Contrib.hs view
@@ -0,0 +1,25 @@+module 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
− src/Network/OAuth/OAuth2.hs
@@ -1,21 +0,0 @@---------------------------------------------------------------- |--- Module : Network.OAuth.OAuth2--- Description : OAuth2 client--- Copyright : (c) 2012 Haisheng Wu--- License : BSD-style (see the file LICENSE)--- Maintainer : Haisheng Wu <freizl@gmail.com>--- Stability : alpha--- Portability : portable------ A lightweight oauth2 haskell binding.---------------------------------------------------------------module Network.OAuth.OAuth2- (module Network.OAuth.OAuth2.HttpClient,- module Network.OAuth.OAuth2.Internal- )- where--import Network.OAuth.OAuth2.HttpClient-import Network.OAuth.OAuth2.Internal
− src/Network/OAuth/OAuth2/AuthorizationRequest.hs
@@ -1,23 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--module Network.OAuth.OAuth2.AuthorizationRequest where--import Data.Aeson-import GHC.Generics--instance FromJSON Errors where- parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }-instance ToJSON Errors where- toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }---- | Authorization Code Grant Error Responses https://tools.ietf.org/html/rfc6749#section-4.1.2.1--- Implicit Grant Error Responses https://tools.ietf.org/html/rfc6749#section-4.2.2.1-data Errors =- InvalidRequest- | UnauthorizedClient- | AccessDenied- | UnsupportedResponseType- | InvalidScope- | ServerError- | TemporarilyUnavailable- deriving (Show, Eq, Generic)
− src/Network/OAuth/OAuth2/HttpClient.hs
@@ -1,278 +0,0 @@-{-# LANGUAGE ExplicitForAll #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}---- | A simple http client to request OAuth2 tokens and several utils.--module Network.OAuth.OAuth2.HttpClient (--- * Token management- fetchAccessToken,- fetchAccessToken2,- refreshAccessToken,- refreshAccessToken2,- doSimplePostRequest,--- * AUTH requests- authGetJSON,- authGetBS,- authGetBS2,- authPostJSON,- authPostBS,- authPostBS2,- authPostBS3,- authRequest-) where--import Data.Aeson-import Data.Bifunctor (first)-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy.Char8 as BSL-import qualified Data.HashMap.Strict as HM (fromList)-import Data.Maybe-import qualified Data.Text.Encoding as T-import Network.HTTP.Conduit-import qualified Network.HTTP.Types as HT-import Network.HTTP.Types.URI (parseQuery)-import Network.OAuth.OAuth2.Internal-import qualified Network.OAuth.OAuth2.TokenRequest as TR-import URI.ByteString------------------------------------------------------- * Token management------------------------------------------------------- | Fetch OAuth2 Token with authenticate in request header.------ OAuth2 spec allows `client_id` and `client_secret` to--- either be sent in the header (as basic authentication)--- OR as form/url params.--- The OAuth server can choose to implement only one, or both.--- Unfortunately, there is no way for the OAuth client (i.e. this library) to--- know which method to use. Please take a look at the documentation of the--- service that you are integrating with and either use `fetchAccessToken` or `fetchAccessToken2`-fetchAccessToken :: Manager -- ^ HTTP connection manager- -> OAuth2 -- ^ OAuth Data- -> ExchangeToken -- ^ OAuth2 Code- -> IO (OAuth2Result TR.Errors OAuth2Token) -- ^ Access Token-fetchAccessToken manager oa code = doJSONPostRequest manager oa uri body- where (uri, body) = accessTokenUrl oa code---- | Please read the docs of `fetchAccessToken`.----fetchAccessToken2 :: Manager -- ^ HTTP connection manager- -> OAuth2 -- ^ OAuth Data- -> ExchangeToken -- ^ OAuth 2 Tokens- -> IO (OAuth2Result TR.Errors OAuth2Token) -- ^ Access Token-fetchAccessToken2 mgr oa code = do- let (url, body1) = accessTokenUrl oa code- let secret x = [("client_secret", T.encodeUtf8 x)]- let extraBody = ("client_id", T.encodeUtf8 $ oauthClientId oa) : maybe [] secret (oauthClientSecret oa)- doJSONPostRequest mgr oa url (extraBody ++ body1)---- | Fetch a new AccessToken with the Refresh Token with authentication in request header.--- OAuth2 spec allows `client_id` and `client_secret` to--- either be sent in the header (as basic authentication)--- OR as form/url params.--- The OAuth server can choose to implement only one, or both.--- Unfortunately, there is no way for the OAuth client (i.e. this library) to--- know which method to use. Please take a look at the documentation of the--- service that you are integrating with and either use `refreshAccessToken` or `refreshAccessToken2`-refreshAccessToken :: Manager -- ^ HTTP connection manager.- -> OAuth2 -- ^ OAuth context- -> RefreshToken -- ^ refresh token gained after authorization- -> IO (OAuth2Result TR.Errors OAuth2Token)-refreshAccessToken manager oa token = doJSONPostRequest manager oa uri body- where (uri, body) = refreshAccessTokenUrl oa token---- | Please read the docs of `refreshAccessToken`.----refreshAccessToken2 :: Manager -- ^ HTTP connection manager.- -> OAuth2 -- ^ OAuth context- -> RefreshToken -- ^ refresh token gained after authorization- -> IO (OAuth2Result TR.Errors OAuth2Token)-refreshAccessToken2 manager oa token = do- let (uri, body) = refreshAccessTokenUrl oa token- let secret x = [("client_secret", T.encodeUtf8 x)]- let extraBody = ("client_id", T.encodeUtf8 $ oauthClientId oa) : maybe [] secret (oauthClientSecret oa)- doJSONPostRequest manager oa uri (extraBody ++ body)---- | Conduct post request and return response as JSON.-doJSONPostRequest :: (FromJSON err, FromJSON a)- => Manager -- ^ HTTP connection manager.- -> OAuth2 -- ^ OAuth options- -> URI -- ^ The URL- -> PostBody -- ^ request body- -> IO (OAuth2Result err a) -- ^ Response as JSON-doJSONPostRequest manager oa uri body = fmap parseResponseFlexible (doSimplePostRequest manager oa uri body)---- | Conduct post request.-doSimplePostRequest :: FromJSON err => Manager -- ^ HTTP connection manager.- -> OAuth2 -- ^ OAuth options- -> URI -- ^ URL- -> PostBody -- ^ Request body.- -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString-doSimplePostRequest manager oa url body = fmap handleOAuth2TokenResponse go- where go = do- req <- uriToRequest url- let addBasicAuth = case oauthClientSecret oa of- (Just secret) -> applyBasicAuth (T.encodeUtf8 $ oauthClientId oa) (T.encodeUtf8 secret)- Nothing -> id- req' = (addBasicAuth . updateRequestHeaders Nothing) req- httpLbs (urlEncodedBody body req') manager---- | Parses a @Response@ to to @OAuth2Result@-handleOAuth2TokenResponse :: FromJSON err => Response BSL.ByteString -> OAuth2Result err BSL.ByteString-handleOAuth2TokenResponse rsp =- if HT.statusIsSuccessful (responseStatus rsp)- then Right $ responseBody rsp- else Left $ parseOAuth2Error (responseBody rsp)---- | Try 'parseResponseJSON', if failed then parses the @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String.-parseResponseFlexible :: FromJSON err => FromJSON a- => OAuth2Result err BSL.ByteString- -> OAuth2Result err a-parseResponseFlexible r = case parseResponseJSON r of- Left _ -> parseResponseString r- x -> x--parseResponseJSON :: (FromJSON err, FromJSON a)- => OAuth2Result err BSL.ByteString- -> OAuth2Result err a-parseResponseJSON (Left b) = Left b-parseResponseJSON (Right b) = case eitherDecode b of- Left e -> Left $ mkDecodeOAuth2Error b e- Right x -> Right x---- | Parses a @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String-parseResponseString :: (FromJSON err, FromJSON a)- => OAuth2Result err BSL.ByteString- -> OAuth2Result err a-parseResponseString (Left b) = Left b-parseResponseString (Right b) = case parseQuery $ BSL.toStrict b of- [] -> Left errorMessage- a -> case fromJSON $ queryToValue a of- Error _ -> Left errorMessage- Success x -> Right x- where- queryToValue = Object . HM.fromList . map paramToPair- paramToPair (k, mv) = (T.decodeUtf8 k, maybe Null (String . T.decodeUtf8) mv)- errorMessage = parseOAuth2Error b------------------------------------------------------- * AUTH requests------------------------------------------------------- | Conduct an authorized GET request and return response as JSON.-authGetJSON :: (FromJSON b)- => Manager -- ^ HTTP connection manager.- -> AccessToken- -> URI- -> IO (Either BSL.ByteString b) -- ^ Response as JSON-authGetJSON manager t uri = do- resp <- authGetBS manager t uri- return (resp >>= (first BSL.pack . eitherDecode))---- | Conduct an authorized GET request.-authGetBS :: Manager -- ^ HTTP connection manager.- -> AccessToken- -> URI- -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString-authGetBS manager token url = do- req <- uriToRequest url- authRequest req upReq manager- where upReq = updateRequestHeaders (Just token) . setMethod HT.GET---- | same to 'authGetBS' but set access token to query parameter rather than header-authGetBS2 :: Manager -- ^ HTTP connection manager.- -> AccessToken- -> URI- -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString-authGetBS2 manager token url = do- req <- uriToRequest (url `appendAccessToken` token)- authRequest req upReq manager- where upReq = updateRequestHeaders Nothing . setMethod HT.GET---- | Conduct POST request and return response as JSON.-authPostJSON :: (FromJSON b)- => Manager -- ^ HTTP connection manager.- -> AccessToken- -> URI- -> PostBody- -> IO (Either BSL.ByteString b) -- ^ Response as JSON-authPostJSON manager t uri pb = do- resp <- authPostBS manager t uri pb- return (resp >>= (first BSL.pack . eitherDecode))---- | Conduct POST request.-authPostBS :: Manager -- ^ HTTP connection manager.- -> AccessToken- -> URI- -> PostBody- -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString-authPostBS manager token url pb = do- req <- uriToRequest url- authRequest req upReq manager- where upBody = urlEncodedBody (pb ++ accessTokenToParam token)- upHeaders = updateRequestHeaders (Just token) . setMethod HT.POST- upReq = upHeaders . upBody---- | Conduct POST request with access token in the request body rather header-authPostBS2 :: Manager -- ^ HTTP connection manager.- -> AccessToken- -> URI- -> PostBody- -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString-authPostBS2 manager token url pb = do- req <- uriToRequest url- authRequest req upReq manager- where upBody = urlEncodedBody (pb ++ accessTokenToParam token)- upHeaders = updateRequestHeaders Nothing . setMethod HT.POST- upReq = upHeaders . upBody---- | Conduct POST request with access token in the header and null in body-authPostBS3 :: Manager -- ^ HTTP connection manager.- -> AccessToken- -> URI- -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString-authPostBS3 manager token url = do- req <- uriToRequest url- authRequest req upReq manager- where upBody req = req { requestBody = "null" }- upHeaders = updateRequestHeaders (Just token) . setMethod HT.POST- upReq = upHeaders . upBody---- |Send an HTTP request including the Authorization header with the specified--- access token.----authRequest :: Request -- ^ Request to perform- -> (Request -> Request) -- ^ Modify request before sending- -> Manager -- ^ HTTP connection manager.- -> IO (Either BSL.ByteString BSL.ByteString)-authRequest req upReq manage = handleResponse <$> httpLbs (upReq req) manage------------------------------------------------------- * Utilities------------------------------------------------------- | Parses a @Response@ to to @OAuth2Result@-handleResponse :: Response BSL.ByteString -> Either BSL.ByteString BSL.ByteString-handleResponse rsp =- if HT.statusIsSuccessful (responseStatus rsp)- then Right $ responseBody rsp- else Left $ responseBody rsp---- | Set several header values:--- + userAgennt : `hoauth2`--- + accept : `application/json`--- + authorization : 'Bearer' `xxxxx` if 'AccessToken' provided.-updateRequestHeaders :: Maybe AccessToken -> Request -> Request-updateRequestHeaders t req =- let extras = [ (HT.hUserAgent, "hoauth2")- , (HT.hAccept, "application/json") ]- bearer = [(HT.hAuthorization, "Bearer " `BS.append` T.encodeUtf8 (atoken (fromJust t))) | isJust t]- headers = bearer ++ extras ++ requestHeaders req- in- req { requestHeaders = headers }---- | Set the HTTP method to use.-setMethod :: HT.StdMethod -> Request -> Request-setMethod m req = req { method = HT.renderStdMethod m }
− src/Network/OAuth/OAuth2/Internal.hs
@@ -1,254 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}-{-# OPTIONS_HADDOCK -ignore-exports #-}---- | A simple OAuth2 Haskell binding. (This is supposed to be--- independent of the http client used.)-module Network.OAuth.OAuth2.Internal where--import Control.Applicative-import Control.Arrow (second)-import Control.Monad.Catch-import Data.Aeson-import Data.Aeson.Types (Parser, explicitParseFieldMaybe)-import Data.Binary (Binary)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL-import Data.Maybe-import Data.Text (Text, pack, unpack)-import Data.Text.Encoding-import GHC.Generics-import Lens.Micro-import Lens.Micro.Extras-import Network.HTTP.Conduit as C-import qualified Network.HTTP.Types as H-import URI.ByteString-import URI.ByteString.Aeson ()-------------------------------------------------------- * Data Types-------------------------------------------------------- | Query Parameter Representation-data OAuth2 = OAuth2- { oauthClientId :: Text,- oauthClientSecret :: Maybe Text,- oauthOAuthorizeEndpoint :: URI,- oauthAccessTokenEndpoint :: URI,- oauthCallback :: Maybe URI- }- deriving (Show, Eq)--newtype AccessToken = AccessToken {atoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON)--newtype RefreshToken = RefreshToken {rtoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON)--newtype IdToken = IdToken {idtoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON)--newtype ExchangeToken = ExchangeToken {extoken :: Text} deriving (Show, FromJSON, ToJSON)---- | The gained Access Token. Use @Data.Aeson.decode@ to--- decode string to @AccessToken@. The @refreshToken@ is--- special in some cases,--- e.g. <https://developers.google.com/accounts/docs/OAuth2>-data OAuth2Token = OAuth2Token- { accessToken :: AccessToken,- refreshToken :: Maybe RefreshToken,- expiresIn :: Maybe Int,- tokenType :: Maybe Text,- idToken :: Maybe IdToken- }- deriving (Eq, Show, Generic)--instance Binary OAuth2Token--parseIntFlexible :: Value -> Parser Int-parseIntFlexible (String s) = pure . read $ unpack s-parseIntFlexible v = parseJSON v---- | Parse JSON data into 'OAuth2Token'-instance FromJSON OAuth2Token where- parseJSON = withObject "OAuth2Token" $ \v ->- OAuth2Token- <$> v .: "access_token"- <*> v .:? "refresh_token"- <*> explicitParseFieldMaybe parseIntFlexible v "expires_in"- <*> v .:? "token_type"- <*> v .:? "id_token"--instance ToJSON OAuth2Token where- toJSON = genericToJSON defaultOptions {fieldLabelModifier = camelTo2 '_'}- toEncoding = genericToEncoding defaultOptions {fieldLabelModifier = camelTo2 '_'}--data OAuth2Error a = OAuth2Error- { error :: Either Text a,- errorDescription :: Maybe Text,- errorUri :: Maybe (URIRef Absolute)- }- deriving (Show, Eq, Generic)--instance FromJSON err => FromJSON (OAuth2Error err) where- parseJSON (Object a) =- do- err <- (a .: "error") >>= (\str -> Right <$> parseJSON str <|> Left <$> parseJSON str)- desc <- a .:? "error_description"- uri <- a .:? "error_uri"- return $ OAuth2Error err desc uri- parseJSON _ = fail "Expected an object"--instance ToJSON err => ToJSON (OAuth2Error err) where- toJSON = genericToJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}- toEncoding = genericToEncoding defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}--parseOAuth2Error :: FromJSON err => BSL.ByteString -> OAuth2Error err-parseOAuth2Error string =- either (mkDecodeOAuth2Error string) id (eitherDecode string)--mkDecodeOAuth2Error :: BSL.ByteString -> String -> OAuth2Error err-mkDecodeOAuth2Error response err =- OAuth2Error- (Left "Decode error")- (Just $ pack $ "Error: " <> err <> "\n Original Response:\n" <> show (decodeUtf8 $ BSL.toStrict response))- Nothing-------------------------------------------------------- * Types Synonym-------------------------------------------------------- | Is either 'Left' containing an error or 'Right' containg a result-type OAuth2Result err a = Either (OAuth2Error err) a---- | type synonym of post body content-type PostBody = [(BS.ByteString, BS.ByteString)]--type QueryParams = [(BS.ByteString, BS.ByteString)]-------------------------------------------------------- * URLs-------------------------------------------------------- | Prepare the authorization URL. Redirect to this URL--- asking for user interactive authentication.-authorizationUrl :: OAuth2 -> URI-authorizationUrl oa = over (queryL . queryPairsL) (++ queryParts) (oauthOAuthorizeEndpoint oa)- where- queryParts =- catMaybes- [ Just ("client_id", encodeUtf8 $ oauthClientId oa),- Just ("response_type", "code"),- fmap (("redirect_uri",) . serializeURIRef') (oauthCallback oa)- ]---- | Prepare the URL and the request body query for fetching an access token.-accessTokenUrl ::- OAuth2 ->- -- | access code gained via authorization URL- ExchangeToken ->- -- | access token request URL plus the request body.- (URI, PostBody)-accessTokenUrl oa code = accessTokenUrl' oa code (Just "authorization_code")---- | Prepare the URL and the request body query for fetching an access token, with--- optional grant type.-accessTokenUrl' ::- OAuth2 ->- -- | access code gained via authorization URL- ExchangeToken ->- -- | Grant Type- Maybe Text ->- -- | access token request URL plus the request body.- (URI, PostBody)-accessTokenUrl' oa code gt = (uri, body)- where- uri = oauthAccessTokenEndpoint oa- body =- catMaybes- [ Just ("code", encodeUtf8 $ extoken code),- ("redirect_uri",) . serializeURIRef' <$> oauthCallback oa,- fmap (("grant_type",) . encodeUtf8) gt- ]---- | Using a Refresh Token. Obtain a new access token by--- sending a refresh token to the Authorization server.-refreshAccessTokenUrl ::- OAuth2 ->- -- | refresh token gained via authorization URL- RefreshToken ->- -- | refresh token request URL plus the request body.- (URI, PostBody)-refreshAccessTokenUrl oa token = (uri, body)- where- uri = oauthAccessTokenEndpoint oa- body =- [ ("grant_type", "refresh_token"),- ("refresh_token", encodeUtf8 $ rtoken token)- ]---- | For `GET` method API.-appendAccessToken ::- -- | Base URI- URIRef a ->- -- | Authorized Access Token- AccessToken ->- -- | Combined Result- URIRef a-appendAccessToken uri t = over (queryL . queryPairsL) (\query -> query ++ accessTokenToParam t) uri---- | Create 'QueryParams' with given access token value.-accessTokenToParam :: AccessToken -> [(BS.ByteString, BS.ByteString)]-accessTokenToParam t = [("access_token", encodeUtf8 $ atoken t)]--appendQueryParams :: [(BS.ByteString, BS.ByteString)] -> URIRef a -> URIRef a-appendQueryParams params =- over (queryL . queryPairsL) (params ++)--uriToRequest :: MonadThrow m => URI -> m Request-uriToRequest uri = do- ssl <- case view (uriSchemeL . schemeBSL) uri of- "http" -> return False- "https" -> return True- s -> throwM $ InvalidUrlException (show uri) ("Invalid scheme: " ++ show s)- let query = fmap (second Just) (view (queryL . queryPairsL) uri)- 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 uri- }- req2 = (over hostLens . maybe id const . preview hostL) uri req- req3 = (over portLens . (const . fromMaybe defaultPort) . preview portL) uri 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 #-}
− src/Network/OAuth/OAuth2/TokenRequest.hs
@@ -1,21 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--module Network.OAuth.OAuth2.TokenRequest where--import Data.Aeson-import GHC.Generics--instance FromJSON Errors where- parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }-instance ToJSON Errors where- toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }---- | Token Error Responses https://tools.ietf.org/html/rfc6749#section-5.2-data Errors =- InvalidRequest- | InvalidClient- | InvalidGrant- | UnauthorizedClient- | UnsupportedGrantType- | InvalidScope- deriving (Show, Eq, Generic)
+ src/Network/OAuth2.hs view
@@ -0,0 +1,26 @@+-- | A lightweight oauth2 Haskell binding.+-- See Readme for more details+module Network.OAuth2 (+ module Network.OAuth2.Internal,++ -- * Authorization Requset+ module Network.OAuth2.AuthorizationRequest,++ -- * Token Request+ module Network.OAuth2.TokenRequest,++ -- * OAuth'ed http client utilities+ module Network.OAuth2.HttpClient,+) where++{-+ Hiding Errors data type from default.+ Shall qualified import given the naming collision.+-}+import Network.OAuth2.AuthorizationRequest hiding (+ AuthorizationResponseError (..),+ AuthorizationResponseErrorCode (..),+ )+import Network.OAuth2.HttpClient+import Network.OAuth2.Internal+import Network.OAuth2.TokenRequest
+ src/Network/OAuth2/AuthorizationRequest.hs view
@@ -0,0 +1,88 @@+-- | Bindings Authorization part of The OAuth 2.0 Authorization Framework+-- RFC6749 <https://www.rfc-editor.org/rfc/rfc6749>+module Network.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.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 it hard to figure out a way to test the authorization error flow.+-- When anything goes wrong in an @/authorize@ request, it gets 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 you find a case where an OAuth2 provider redirects back to the 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)+ ]
+ src/Network/OAuth2/Experiment.hs view
@@ -0,0 +1,157 @@+-- | This module contains a new way of doing OAuth2 authorization and authentication+-- in order to obtain an access token and maybe a refresh token based on RFC 6749.+--+-- This module will become the default in a future release.+--+-- The key concept is introducing grant flows, which determine the entire workflow per the spec.+-- Each workflow has slightly different request parameters, which is why you'll often see+-- different configuration options when creating an OAuth2 application in an IdP developer console.+--+-- Here are the supported flows:+--+-- 1. Authorization Code. This flow requires an authorize call to obtain an authorization code,+-- then exchange the code for tokens.+--+-- 2. Resource Owner Password. This flow only requires hitting the token endpoint with, of course,+-- username and password, to obtain tokens.+--+-- 3. Client Credentials. This flow also only requires hitting the token endpoint, but with different parameters.+-- The client credentials flow does not involve an end user, so you won't be able to hit the userinfo endpoint+-- with the access token you obtain.+--+-- 4. PKCE (RFC 7636). This is an enhancement on top of the authorization code flow.+--+-- The implicit flow is not supported because it is primarily for SPAs (single-page apps),+-- and it has been deprecated in favor of the authorization code flow with PKCE.+--+-- Here is a quick sample showing how to use the vocabulary from this module.+--+-- First, initialize your IdP (using Google as an 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",+-- acClientAuthenticationMethod = ClientSecretBasic,+-- }+--+-- fooIdpApplication :: IdpApplication AuthorizationCodeApplication Google+-- fooIdpApplication = IdpApplication fooApp googleIdp+-- @+--+-- Second, construct the authorize URL.+--+-- @+-- authorizeUrl = mkAuthorizationRequest fooIdpApplication+-- @+--+-- Third, after a successful redirect with an authorization code,+-- you can exchange it for an access token.+--+-- @+-- mgr <- liftIO $ newManager tlsManagerSettings+-- tokenResp <- conduitTokenRequest fooIdpApplication mgr authorizeCode+-- @+--+-- If you'd like to fetch user info, use this method:+--+-- @+-- conduitUserInfoRequest fooIdpApplication mgr (accessToken tokenResp)+-- @+--+-- You can also find an example in the @hoauth2-providers-tutorial@ module.+module Network.OAuth2.Experiment (+ -- * Application per Grant type+ module Network.OAuth2.Experiment.Grants,++ -- * Authorization Code+ mkAuthorizationRequest,+ mkPkceAuthorizeRequest,++ -- * Device Authorization+ module Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest,+ conduitDeviceAuthorizationRequest,+ pollDeviceTokenRequest,++ -- * Token Request+ module Network.OAuth2.Experiment.Flows.TokenRequest,+ conduitPkceTokenRequest,+ conduitTokenRequest,++ -- * Refresh Token Request+ module Network.OAuth2.Experiment.Flows.RefreshTokenRequest,+ conduitRefreshTokenRequest,++ -- * UserInfo Request+ module Network.OAuth2.Experiment.Flows.UserInfoRequest,+ conduitUserInfoRequest,+ conduitUserInfoRequestWithCustomMethod,++ -- * Types+ module Network.OAuth2.Experiment.Types,+ module Network.OAuth2.Experiment.Pkce,+ module Network.OAuth2,++ -- * Utils+ module Network.OAuth2.Experiment.Utils,+) where++import Network.OAuth2 (ClientAuthenticationMethod (..))+import Network.OAuth2.Experiment.Flows+import Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest (+ DeviceAuthorizationResponse (..),+ )+import Network.OAuth2.Experiment.Flows.RefreshTokenRequest (+ HasRefreshTokenRequest,+ )+import Network.OAuth2.Experiment.Flows.TokenRequest (+ ExchangeTokenInfo,+ HasTokenRequest,+ NoNeedExchangeToken (..),+ TokenRequest,+ )+import Network.OAuth2.Experiment.Flows.UserInfoRequest (+ HasUserInfoRequest,+ )+import Network.OAuth2.Experiment.Grants+import Network.OAuth2.Experiment.Pkce (+ CodeVerifier (..),+ )+import Network.OAuth2.Experiment.Types (+ AuthorizeState (..),+ ClientId (..),+ ClientSecret (..),+ Idp (..),+ IdpApplication (..),+ Password (..),+ RedirectUri (..),+ Scope (..),+ Username (..),+ )+import Network.OAuth2.Experiment.Utils (uriToText)
+ src/Network/OAuth2/Experiment/Flows.hs view
@@ -0,0 +1,273 @@+{-# LANGUAGE FlexibleContexts #-}++-- | Module implementing various OAuth2 flow types and their request/response handling.+-- Provides support for:+--+-- * Authorization Code Grant+-- * Device Authorization Grant+-- * PKCE Extension+-- * Token Refresh+-- * User Info Endpoints+module Network.OAuth2.Experiment.Flows where++import Control.Concurrent+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Except+import Data.Aeson (FromJSON)+import Data.Bifunctor+import Data.ByteString.Lazy.Char8 qualified as BSL+import Data.Map.Strict qualified as Map+import Data.Maybe+import Network.HTTP.Client.Contrib+import Network.HTTP.Conduit+import Network.OAuth2+import Network.OAuth2 qualified as OAuth2+import Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest+import Network.OAuth2.Experiment.Flows.RefreshTokenRequest+import Network.OAuth2.Experiment.Flows.TokenRequest+import Network.OAuth2.Experiment.Flows.UserInfoRequest+import Network.OAuth2.Experiment.Grants.AuthorizationCode+import Network.OAuth2.Experiment.Grants.DeviceAuthorization+import Network.OAuth2.Experiment.Pkce+import Network.OAuth2.Experiment.Types+import Network.OAuth2.Experiment.Utils+import URI.ByteString hiding (UserInfo)++-------------------------------------------------------------------------------+-- Authorization Requests --+-------------------------------------------------------------------------------++-- | Constructs an Authorization Code request URI according to+-- <https://www.rfc-editor.org/rfc/rfc6749#section-4.1.1 RFC 6749 Section 4.1.1>.+--+-- The generated URI includes:+-- * client_id+-- * response_type (always "code")+-- * redirect_uri+-- * state (if provided)+-- * scope (if provided)+mkAuthorizationRequest :: IdpApplication i AuthorizationCodeApplication -> URI+mkAuthorizationRequest idpApp =+ let req = mkAuthorizationRequestParam (application idpApp)+ allParams =+ map (bimap tlToBS tlToBS) $+ Map.toList $+ toQueryParam req+ in appendQueryParams allParams $+ idpAuthorizeEndpoint (idp idpApp)++-- | Constructs an Authorization Code request URI with PKCE support according to+-- <https://datatracker.ietf.org/doc/html/rfc7636 RFC 7636>.+--+-- Returns both the authorization URI and the generated code verifier.+-- The code verifier must be stored securely for later use in the token request.+mkPkceAuthorizeRequest ::+ MonadIO m =>+ IdpApplication i AuthorizationCodeApplication ->+ 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)++-------------------------------------------------------------------------------+-- Device Auth --+-------------------------------------------------------------------------------++-- | Makes Device Authorization Request+-- https://www.rfc-editor.org/rfc/rfc8628#section-3.1+conduitDeviceAuthorizationRequest ::+ MonadIO m =>+ IdpApplication i DeviceAuthorizationApplication ->+ Manager ->+ ExceptT BSL.ByteString m DeviceAuthorizationResponse+conduitDeviceAuthorizationRequest IdpApplication {..} mgr = do+ case idpDeviceAuthorizationEndpoint idp of+ Nothing -> throwE "[conduitDeviceAuthorizationRequest] Device Authorization Flow is not supported: missing device_authorization_endpoint."+ Just deviceAuthEndpoint -> do+ let deviceAuthReq = mkDeviceAuthorizationRequestParam application+ body = unionMapsToQueryParams [toQueryParam deviceAuthReq]+ ExceptT . liftIO $ do+ req <- addDefaultRequestHeaders <$> uriToRequest deviceAuthEndpoint+ let req' =+ if daAuthorizationRequestAuthenticationMethod application == ClientSecretBasic+ then addSecretToHeader (daClientId application) (daClientSecret application) req+ else req+ resp <- httpLbs (urlEncodedBody body req') mgr+ pure $ first ("[conduitDeviceAuthorizationRequest] " <>) $ handleResponseJSON resp++-- | Polls for a token using the device authorization flow.+--+-- This implements the polling mechanism described in+-- <https://www.rfc-editor.org/rfc/rfc8628#section-3.5 RFC 8628 Section 3.5>.+-- Handles automatic retries and interval adjustments based on IdP responses.+pollDeviceTokenRequest ::+ MonadIO m =>+ IdpApplication i DeviceAuthorizationApplication ->+ Manager ->+ DeviceAuthorizationResponse ->+ ExceptT TokenResponseError m TokenResponse+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 TokenResponse+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++-------------------------------------------------------------------------------+-- Token Request --+-------------------------------------------------------------------------------++-- | Sends a token request according to+-- <https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3 RFC 6749 Section 4.1.3>.+--+-- This is used for exchanging authorization codes, device codes, or other+-- grant types for access tokens.+conduitTokenRequest ::+ (HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) =>+ IdpApplication i a ->+ Manager ->+ ExchangeTokenInfo a ->+ ExceptT TokenResponseError m TokenResponse+conduitTokenRequest idpApp mgr exchangeToken = do+ let req = mkTokenRequestParam (application idpApp) exchangeToken+ body =+ unionMapsToQueryParams+ [ toQueryParam req+ ]+ in conduitTokenRequestInternal idpApp mgr body++-------------------------------------------------------------------------------+-- PKCE Token Request --+-------------------------------------------------------------------------------++-- | 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 TokenResponse+conduitPkceTokenRequest idpApp mgr (exchangeToken, codeVerifier) =+ let req = mkTokenRequestParam (application idpApp) exchangeToken+ body =+ unionMapsToQueryParams+ [ toQueryParam req+ , toQueryParam codeVerifier+ ]+ in conduitTokenRequestInternal idpApp mgr body++-------------------------------------------------------------------------------+-- Refresh Token --+-------------------------------------------------------------------------------++-- | Makes a Refresh Token Request according to+-- <https://www.rfc-editor.org/rfc/rfc6749#section-6 RFC 6749 Section 6>.+--+-- Used to obtain a new access token using a refresh token.+conduitRefreshTokenRequest ::+ (MonadIO m, HasRefreshTokenRequest a) =>+ IdpApplication i a ->+ Manager ->+ OAuth2.RefreshToken ->+ ExceptT TokenResponseError m TokenResponse+conduitRefreshTokenRequest ia mgr rt =+ let tokenReq = mkRefreshTokenRequestParam (application ia) rt+ body = unionMapsToQueryParams [toQueryParam tokenReq]+ in conduitTokenRequestInternal ia mgr body++-------------------------------------------------------------------------------+-- User Info --+-------------------------------------------------------------------------------++-- | Makes a standard request to the userinfo endpoint using GET method.+--+-- This is commonly used with OpenID Connect providers to fetch+-- user profile information using an access token.+conduitUserInfoRequest ::+ (MonadIO m, HasUserInfoRequest a, FromJSON b) =>+ IdpApplication i a ->+ Manager ->+ AccessToken ->+ ExceptT BSL.ByteString m b+conduitUserInfoRequest = conduitUserInfoRequestWithCustomMethod authGetJSON++-- | Makes a request to the userinfo endpoint using a custom HTTP method.+--+-- Some IdPs may require different HTTP methods (instead of GET) or custom headers+-- for fetching user information. This function provides that flexibility.+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)++-------------------------------------------------------------------------------+-- Internal helpers --+-------------------------------------------------------------------------------++conduitTokenRequestInternal ::+ ( MonadIO m+ , HasClientAuthenticationMethod a+ , FromJSON b+ ) =>+ IdpApplication i a ->+ -- | HTTP connection manager.+ Manager ->+ -- | Request body.+ PostBody ->+ -- | Response as ByteString+ ExceptT TokenResponseError m b+conduitTokenRequestInternal IdpApplication {..} manager body = do+ let clientAuthMethod = getClientAuthenticationMethod application+ url = idpTokenEndpoint idp+ updateAuthHeader =+ case clientAuthMethod of+ ClientSecretBasic -> addClientAuthToHeader application+ ClientSecretPost -> id+ ClientAssertionJwt -> id+ go = do+ req <- uriToRequest url+ let req' = (updateAuthHeader . addDefaultRequestHeaders) req+ httpLbs (urlEncodedBody body req') manager+ resp <- ExceptT . liftIO $ fmap handleOAuth2TokenResponse go+ case parseResponseFlexible resp of+ Right obj -> return obj+ Left e -> throwE e
+ src/Network/OAuth2/Experiment/Flows/AuthorizationRequest.hs view
@@ -0,0 +1,33 @@+module Network.OAuth2.Experiment.Flows.AuthorizationRequest where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Text.Lazy (Text)+import Network.OAuth2.Experiment.Types++-------------------------------------------------------------------------------+-- 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+ ]
+ src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DerivingStrategies #-}++module Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest where++import Control.Applicative+import Data.Aeson.Types+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Text.Lazy (Text)+import Network.OAuth2.Experiment.Types+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+ { darScope :: Set Scope+ , darClientId :: Maybe ClientId+ , darExtraParams :: Map Text Text+ }++instance ToQueryParam DeviceAuthorizationRequestParam where+ toQueryParam :: DeviceAuthorizationRequestParam -> Map Text Text+ toQueryParam DeviceAuthorizationRequestParam {..} =+ Map.unions+ [ toQueryParam darScope+ , toQueryParam darClientId+ , darExtraParams+ ]
+ src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE FlexibleContexts #-}++module Network.OAuth2.Experiment.Flows.RefreshTokenRequest where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Text.Lazy (Text)+import Network.OAuth2 qualified as OAuth2+import Network.OAuth2.Experiment.Flows.TokenRequest+import Network.OAuth2.Experiment.Types++-------------------------------------------------------------------------------+-- RefreshToken Requset --+-------------------------------------------------------------------------------++data RefreshTokenRequest = RefreshTokenRequest+ { rrRefreshToken :: OAuth2.RefreshToken+ , rrGrantType :: GrantTypeValue+ , rrScope :: Set Scope+ , rrClientId :: Maybe ClientId+ , rrClientSecret :: Maybe ClientSecret+ }++instance ToQueryParam RefreshTokenRequest where+ toQueryParam :: RefreshTokenRequest -> Map Text Text+ toQueryParam RefreshTokenRequest {..} =+ Map.unions+ [ toQueryParam rrGrantType+ , toQueryParam rrScope+ , toQueryParam rrRefreshToken+ , toQueryParam rrClientId+ , toQueryParam rrClientSecret+ ]++class HasClientAuthenticationMethod a => HasRefreshTokenRequest a where+ -- | Make Refresh Token Request parameters+ -- | https://www.rfc-editor.org/rfc/rfc6749#section-6+ mkRefreshTokenRequestParam :: a -> OAuth2.RefreshToken -> RefreshTokenRequest
+ src/Network/OAuth2/Experiment/Flows/TokenRequest.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE FlexibleContexts #-}++module Network.OAuth2.Experiment.Flows.TokenRequest where++import Data.Text.Encoding qualified as T+import Data.Text.Lazy qualified as TL+import Network.HTTP.Conduit+import Network.OAuth2 (+ ClientAuthenticationMethod (..),+ )+import Network.OAuth2.Experiment.Types (+ ClientId (unClientId),+ ClientSecret (unClientSecret),+ )++addSecretToHeader :: ClientId -> ClientSecret -> Request -> Request+addSecretToHeader cid csecret =+ applyBasicAuth+ (T.encodeUtf8 $ TL.toStrict $ unClientId cid)+ (T.encodeUtf8 $ TL.toStrict $ unClientSecret csecret)++class HasClientAuthenticationMethod a where+ getClientAuthenticationMethod :: a -> ClientAuthenticationMethod+ addClientAuthToHeader :: a -> Request -> Request+ addClientAuthToHeader _ = id++-- | Only Authorization Code Grant involves a Exchange Token (Authorization Code).+-- ResourceOwnerPassword and Client Credentials make token request directly.+data NoNeedExchangeToken = NoNeedExchangeToken++class HasClientAuthenticationMethod 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
+ src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs view
@@ -0,0 +1,7 @@+module Network.OAuth2.Experiment.Flows.UserInfoRequest where++-------------------------------------------------------------------------------+-- User Info Request --+-------------------------------------------------------------------------------++class HasUserInfoRequest a
+ src/Network/OAuth2/Experiment/Grants.hs view
@@ -0,0 +1,15 @@+module 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 (..),+ )+import Network.OAuth2.Experiment.Grants.JwtBearer (JwtBearerApplication (..))+import Network.OAuth2.Experiment.Grants.ResourceOwnerPassword (ResourceOwnerPasswordApplication (..))
+ src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs view
@@ -0,0 +1,117 @@+{-# 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.OAuth2 (ClientAuthenticationMethod (..), ExchangeToken (..))+import Network.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 Network.OAuth2.Experiment.Utils+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+ , acClientAuthenticationMethod :: ClientAuthenticationMethod+ }++instance HasClientAuthenticationMethod AuthorizationCodeApplication where+ getClientAuthenticationMethod :: AuthorizationCodeApplication -> ClientAuthenticationMethod+ getClientAuthenticationMethod AuthorizationCodeApplication {..} = acClientAuthenticationMethod+ addClientAuthToHeader AuthorizationCodeApplication {..} = addSecretToHeader acClientId acClientSecret++mkAuthorizationRequestParam :: AuthorizationCodeApplication -> AuthorizationRequestParam+mkAuthorizationRequestParam AuthorizationCodeApplication {..} =+ AuthorizationRequestParam+ { arScope = acScope+ , arState = acAuthorizeState+ , arClientId = acClientId+ , arRedirectUri = Just (RedirectUri acRedirectUri)+ , arResponseType = Code+ , arExtraParams = acAuthorizeRequestExtraParams+ }++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+ , trClientId :: ClientId+ , trClientSecret :: ClientSecret+ , trClientAuthenticationMethod :: ClientAuthenticationMethod+ }++ mkTokenRequestParam :: AuthorizationCodeApplication -> ExchangeToken -> TokenRequest AuthorizationCodeApplication+ mkTokenRequestParam AuthorizationCodeApplication {..} authCode =+ AuthorizationCodeTokenRequest+ { trCode = authCode+ , trGrantType = GTAuthorizationCode+ , trRedirectUri = RedirectUri acRedirectUri+ , trClientId = acClientId+ , trClientSecret = acClientSecret+ , trClientAuthenticationMethod = acClientAuthenticationMethod+ }++instance ToQueryParam (TokenRequest AuthorizationCodeApplication) where+ toQueryParam :: TokenRequest AuthorizationCodeApplication -> Map Text Text+ toQueryParam AuthorizationCodeTokenRequest {..} =+ let extraBodyBasedOnClientAuthMethod =+ case trClientAuthenticationMethod of+ ClientAssertionJwt ->+ [ Map.fromList+ [ ("client_assertion_type", "urn:ietf:params:oauth:client-assertion-type:jwt-bearer")+ , ("client_assertion", bs8ToLazyText $ tlToBS $ unClientSecret trClientSecret)+ ]+ ]+ ClientSecretPost -> [toQueryParam trClientId, toQueryParam trClientSecret]+ ClientSecretBasic -> []+ in Map.unions $+ [ toQueryParam trCode+ , toQueryParam trGrantType+ , toQueryParam trRedirectUri+ ]+ ++ extraBodyBasedOnClientAuthMethod++instance HasUserInfoRequest AuthorizationCodeApplication++instance HasRefreshTokenRequest AuthorizationCodeApplication where+ mkRefreshTokenRequestParam :: AuthorizationCodeApplication -> OAuth2.RefreshToken -> RefreshTokenRequest+ mkRefreshTokenRequestParam AuthorizationCodeApplication {..} rt =+ RefreshTokenRequest+ { rrScope = acScope+ , rrGrantType = GTRefreshToken+ , rrRefreshToken = rt+ , rrClientId = if acClientAuthenticationMethod == ClientSecretPost then Just acClientId else Nothing+ , rrClientSecret = if acClientAuthenticationMethod == ClientSecretPost then Just acClientSecret else Nothing+ }
+ src/Network/OAuth2/Experiment/Grants/ClientCredentials.hs view
@@ -0,0 +1,73 @@+{-# 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.OAuth2 (ClientAuthenticationMethod (..))+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+ , ccClientAuthenticationMethod :: ClientAuthenticationMethod+ }++instance HasClientAuthenticationMethod ClientCredentialsApplication where+ getClientAuthenticationMethod :: ClientCredentialsApplication -> ClientAuthenticationMethod+ getClientAuthenticationMethod ClientCredentialsApplication {..} = ccClientAuthenticationMethod++ addClientAuthToHeader ClientCredentialsApplication {..} = addSecretToHeader ccClientId ccClientSecret++-- | 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 = ccClientAuthenticationMethod+ , trExtraParams = ccTokenRequestExtraParams+ , trClientId = ccClientId+ }++instance ToQueryParam (TokenRequest ClientCredentialsApplication) where+ toQueryParam :: TokenRequest ClientCredentialsApplication -> Map Text Text+ toQueryParam ClientCredentialsTokenRequest {..} =+ let extraBodyBasedOnClientAuthMethod =+ case trClientAuthenticationMethod of+ ClientAssertionJwt ->+ [ Map.fromList+ [ ("client_assertion_type", "urn:ietf:params:oauth:client-assertion-type:jwt-bearer")+ , ("client_assertion", bs8ToLazyText $ tlToBS $ unClientSecret trClientSecret)+ ]+ ]+ ClientSecretPost -> [toQueryParam trClientId, toQueryParam trClientSecret]+ ClientSecretBasic -> []+ in Map.unions $+ [ toQueryParam trGrantType+ , toQueryParam trScope+ , trExtraParams+ ]+ ++ extraBodyBasedOnClientAuthMethod
+ src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE FlexibleInstances #-}++module Network.OAuth2.Experiment.Grants.DeviceAuthorization where++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.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 :: ClientAuthenticationMethod+ -- ^ The spec requires similar authentication method as /token request.+ -- Most of identity providers doesn't required it but some does like Okta.+ }++instance HasClientAuthenticationMethod DeviceAuthorizationApplication where+ getClientAuthenticationMethod :: DeviceAuthorizationApplication -> ClientAuthenticationMethod+ getClientAuthenticationMethod = daAuthorizationRequestAuthenticationMethod+ addClientAuthToHeader DeviceAuthorizationApplication {..} = addSecretToHeader daClientId daClientSecret++mkDeviceAuthorizationRequestParam :: DeviceAuthorizationApplication -> DeviceAuthorizationRequestParam+mkDeviceAuthorizationRequestParam DeviceAuthorizationApplication {..} =+ DeviceAuthorizationRequestParam+ { darScope = daScope+ , darClientId =+ if daAuthorizationRequestAuthenticationMethod == ClientSecretPost+ then Just daClientId+ else Nothing+ , darExtraParams = 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 == ClientSecretPost+ then Just daClientId+ else Nothing+ }++instance ToQueryParam (TokenRequest DeviceAuthorizationApplication) where+ toQueryParam :: TokenRequest DeviceAuthorizationApplication -> Map Text Text+ toQueryParam AuthorizationCodeTokenRequest {..} =+ Map.unions+ [ toQueryParam trCode+ , toQueryParam trGrantType+ , toQueryParam trClientId+ ]++instance HasUserInfoRequest DeviceAuthorizationApplication
+ src/Network/OAuth2/Experiment/Grants/JwtBearer.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE FlexibleInstances #-}++module Network.OAuth2.Experiment.Grants.JwtBearer where++import Data.ByteString qualified as BS+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text.Lazy (Text)+import Network.OAuth2 (ClientAuthenticationMethod (..))+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+ }++instance HasClientAuthenticationMethod 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
+ src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs view
@@ -0,0 +1,78 @@+{-# 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.OAuth2 (ClientAuthenticationMethod (..))+import Network.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+ , ropClientAuthenticationMethod :: ClientAuthenticationMethod+ }++instance HasClientAuthenticationMethod ResourceOwnerPasswordApplication where+ getClientAuthenticationMethod :: ResourceOwnerPasswordApplication -> ClientAuthenticationMethod+ getClientAuthenticationMethod = ropClientAuthenticationMethod+ addClientAuthToHeader ResourceOwnerPasswordApplication {..} = addSecretToHeader ropClientId ropClientSecret++-- | 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+ , rrClientId = if ropClientAuthenticationMethod == ClientSecretPost then Just ropClientId else Nothing+ , rrClientSecret = if ropClientAuthenticationMethod == ClientSecretPost then Just ropClientSecret else Nothing+ }
+ src/Network/OAuth2/Experiment/Pkce.hs view
@@ -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.Base64.Types qualified as B64+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.extractBase64 . 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]
+ src/Network/OAuth2/Experiment/Types.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}++module Network.OAuth2.Experiment.Types where++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.OAuth2 hiding (RefreshToken)+import Network.OAuth2 qualified as OAuth2+import Network.OAuth2.Experiment.Pkce+import Network.OAuth2.Experiment.Utils+import URI.ByteString (URI, serializeURIRef')++-------------------------------------------------------------------------------++-- * Idp App++-------------------------------------------------------------------------------++-- | @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, Show)++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 based on the client authentication method+newtype ClientSecret = ClientSecret {unClientSecret :: Text}+ deriving (Eq, IsString)++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 =+ if Set.null scope+ then Map.empty+ else 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"
+ src/Network/OAuth2/Experiment/Utils.hs view
@@ -0,0 +1,27 @@+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 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'
+ src/Network/OAuth2/HttpClient.hs view
@@ -0,0 +1,245 @@+-- | Bindings for The OAuth 2.0 Authorization Framework: Bearer Token Usage+-- RFC6750 <https://www.rfc-editor.org/rfc/rfc6750>+module Network.OAuth2.HttpClient (+ -- * AUTH requests+ authGetJSON,+ authGetBS,+ authGetJSONWithAuthMethod,+ authGetBSWithAuthMethod,+ authPostJSON,+ authPostBS,+ authPostJSONWithAuthMethod,+ authPostBSWithAuthMethod,++ -- * Types+ APIAuthenticationMethod (..),+) where++import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Except (ExceptT (..), throwE)+import Data.Aeson (FromJSON)+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Aeson+import Data.Aeson.KeyMap qualified as Aeson+import Data.ByteString.Char8 qualified as BS+import Data.ByteString.Lazy.Char8 qualified as BSL+import Data.Text.Encoding qualified as T+import Lens.Micro (over)+import Network.HTTP.Client.Conduit (applyBearerAuth)+import Network.HTTP.Client.Contrib (handleResponse)+import Network.HTTP.Conduit+import Network.HTTP.Types qualified as HT+import Network.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++-- | 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 (Aeson.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++-- | 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++-- | 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 (Aeson.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 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+ let upBody = if null reqBody then id else jsonBody 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++jsonBody :: PostBody -> Request -> Request+jsonBody body req =+ req+ { requestBody =+ RequestBodyLBS $+ Aeson.encode $+ Aeson.fromList $+ fmap (\(a, b) -> (Aeson.fromText (T.decodeUtf8 a), T.decodeUtf8 b)) body+ , requestHeaders =+ (HT.hContentType, "application/json")+ : filter (\(x, _) -> x /= HT.hContentType) (requestHeaders req)+ }++--------------------------------------------------++-- * 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)++updateRequestHeaders :: Maybe AccessToken -> Request -> Request+updateRequestHeaders mt =+ maybe id (applyBearerAuth . T.encodeUtf8 . atoken) mt+ . addDefaultRequestHeaders++-- | 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)]
+ src/Network/OAuth2/Internal.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE QuasiQuotes #-}++module Network.OAuth2.Internal where++import Control.Monad.Catch+import Data.Aeson+import Data.Binary.Instances.Aeson ()+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as BS8+import Data.Default+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Version (showVersion)+import Lens.Micro (over)+import Network.HTTP.Conduit as C+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 (Eq, Show, FromJSON, ToJSON)++newtype RefreshToken = RefreshToken {rtoken :: Text} deriving (Eq, Show, FromJSON, ToJSON)++newtype IdToken = IdToken {idtoken :: Text} deriving (Eq, Show, FromJSON, ToJSON)++-- | Authorization Code+newtype ExchangeToken = ExchangeToken {extoken :: Text} deriving (Show, FromJSON, ToJSON)++-------------------------------------------------------------------------------++-- * Client Authentication methods++-------------------------------------------------------------------------------++-- | How would the Client (RP) authenticate itself?+--+-- The client MUST NOT use more than one authentication method in each request.+-- Means use Authorization header or Post body.+--+-- See more details+--+-- https://www.rfc-editor.org/rfc/rfc6749#section-2.3+-- https://oauth.net/private-key-jwt/+-- https://www.rfc-editor.org/rfc/rfc7523.html+data ClientAuthenticationMethod+ = ClientSecretBasic+ | ClientSecretPost+ | ClientAssertionJwt+ deriving (Eq, Show)++-------------------------------------------------------------------------------++-- * 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-" <> (T.encodeUtf8 . T.pack $ showVersion version))+ , (HT.hAccept, "application/json")+ ]++-- | Set several header values:+-- + userAgennt : "hoauth2"+-- + accept : "application/json"+addDefaultRequestHeaders :: Request -> Request+addDefaultRequestHeaders req =+ let headers = defaultRequestHeaders ++ requestHeaders req+ in req {requestHeaders = headers}++appendQueryParams :: [(BS.ByteString, BS.ByteString)] -> URIRef a -> URIRef a+appendQueryParams params = over (queryL . queryPairsL) (params ++)++uriToRequest :: MonadThrow m => URI -> m Request+uriToRequest = parseRequest . BS8.unpack . serializeURIRef'
+ src/Network/OAuth2/TokenRequest.hs view
@@ -0,0 +1,362 @@+-- | Bindings Access Token and Refresh Token part of The OAuth 2.0 Authorization Framework+-- RFC6749 <https://www.rfc-editor.org/rfc/rfc6749>+module Network.OAuth2.TokenRequest where++import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Except (ExceptT (..), throwE)+import Data.Aeson+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types (Parser, explicitParseFieldMaybe)+import Data.Binary (Binary (..))+import Data.Binary.Instances.Aeson ()+import Data.ByteString.Lazy.Char8 qualified as BSL+import Data.Text (Text, unpack)+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.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++-------------------------------------------------------------------------------++-- * Tokens++-------------------------------------------------------------------------------++-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.4+data TokenResponse = TokenResponse+ { 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 by spec, but OAuth2 provider implementations vary. We may remove 'Maybe' in a future release.+ , idToken :: Maybe IdToken+ -- ^ Exists when @openid@ scope is in the Authorization Request and the provider supports OpenID protocol.+ , scope :: Maybe Text+ , rawResponse :: Object+ }+ deriving (Eq)++instance Show TokenResponse where+ show TokenResponse {..} =+ "TokenResponse {"+ <> "access_token = ***"+ <> ", id_token = "+ <> showM idToken+ <> ", refresh_token = "+ <> showM refreshToken+ <> ", expires_in = "+ <> show expiresIn+ <> ", token_type = "+ <> show tokenType+ <> ", scope = "+ <> show scope+ <> ", raw_response = ***"+ <> "}"+ where+ showM (Just _) = "***"+ showM Nothing = "Nothing"++instance Binary TokenResponse where+ put TokenResponse {..} = put rawResponse+ get = do+ rawt <- get+ case fromJSON (Aeson.Object rawt) of+ Success a -> pure a+ Error err -> fail err++-- | Parse JSON data into 'TokenResponse'+instance FromJSON TokenResponse where+ parseJSON :: Value -> Parser TokenResponse+ parseJSON = withObject "TokenResponse" $ \v ->+ TokenResponse+ <$> v .: "access_token"+ <*> v .:? "refresh_token"+ <*> explicitParseFieldMaybe parseIntFlexible v "expires_in"+ <*> v .:? "token_type"+ <*> v .:? "id_token"+ <*> v .:? "scope"+ <*> pure v+ where+ parseIntFlexible :: Value -> Parser Int+ parseIntFlexible (String s) = pure . read $ unpack s+ parseIntFlexible v = parseJSON v++instance ToJSON TokenResponse where+ toJSON :: TokenResponse -> Value+ toJSON = toJSON . Object . rawResponse+ toEncoding :: TokenResponse -> Encoding+ toEncoding = toEncoding . Object . rawResponse++--------------------------------------------------++-- * 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 TokenResponse+fetchAccessToken = fetchAccessTokenWithAuthMethod ClientSecretBasic++-- | 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 TokenResponse+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 TokenResponse+refreshAccessToken = refreshAccessTokenWithAuthMethod ClientSecretBasic++-- | 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 TokenResponse+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.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)++-- | 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)+ ]
+ test/Network/OAuth2/InternalSpec.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE QuasiQuotes #-}++module Network.OAuth2.InternalSpec where++import Control.Monad.IO.Class (MonadIO (..))+import Network.HTTP.Conduit+import Network.OAuth2+import Test.Hspec+import URI.ByteString.QQ++spec :: Spec+spec = do+ describe "uriToRequest" $ do+ it "parse http://localhost:3001/abc/foo?scope=openid&redirect_uri=http://localhost:3001/callback" $ do+ req <- liftIO $ uriToRequest [uri|http://localhost:3001/abc/foo?scope=openid&&redirect_uri=http://localhost:3001/callback|]+ secure req `shouldBe` False+ path req `shouldBe` "/abc/foo"+ port req `shouldBe` 3001+ host req `shouldBe` "localhost"+ queryString req `shouldBe` "?scope=openid&redirect_uri=http%3A%2F%2Flocalhost%3A3001%2Fcallback"+ it "parse http://localhost:3001/abc/foo" $ do+ req <- liftIO $ uriToRequest [uri|http://localhost:3001/abc/foo|]+ secure req `shouldBe` False+ path req `shouldBe` "/abc/foo"+ port req `shouldBe` 3001+ host req `shouldBe` "localhost"+ queryString req `shouldBe` ""+ it "parse http://localhost:3001/" $ do+ req <- liftIO $ uriToRequest [uri|http://localhost:3001/|]+ secure req `shouldBe` False+ path req `shouldBe` "/"+ port req `shouldBe` 3001+ host req `shouldBe` "localhost"+ queryString req `shouldBe` ""+ it "parse https://test.auth0.com/authorize" $ do+ req <- liftIO $ uriToRequest [uri|https://test.auth0.com/authorize|]+ secure req `shouldBe` True+ path req `shouldBe` "/authorize"+ port req `shouldBe` 443+ host req `shouldBe` "test.auth0.com"+ queryString req `shouldBe` ""+ it "parse URL with multiple query parameters" $ do+ req <- liftIO $ uriToRequest [uri|https://api.example.com/oauth2/auth?client_id=123&scope=read,write&state=xyz|]+ secure req `shouldBe` True+ path req `shouldBe` "/oauth2/auth"+ port req `shouldBe` 443+ host req `shouldBe` "api.example.com"+ queryString req `shouldBe` "?client_id=123&scope=read%2Cwrite&state=xyz"+ it "parse URL with special characters in path" $ do+ req <- liftIO $ uriToRequest [uri|https://api.example.com/oauth2/user+info/profile%20data|]+ secure req `shouldBe` True+ path req `shouldBe` "/oauth2/user+info/profile%20data"+ port req `shouldBe` 443+ host req `shouldBe` "api.example.com"+ queryString req `shouldBe` ""+ it "parse URL with fragments (which should be ignored)" $ do+ req <- liftIO $ uriToRequest [uri|https://api.example.com/callback#access_token=xyz|]+ secure req `shouldBe` True+ path req `shouldBe` "/callback"+ port req `shouldBe` 443+ host req `shouldBe` "api.example.com"+ queryString req `shouldBe` ""+ it "parse URL with non-standard HTTPS port" $ do+ req <- liftIO $ uriToRequest [uri|https://api.example.com:8443/oauth/token|]+ secure req `shouldBe` True+ path req `shouldBe` "/oauth/token"+ port req `shouldBe` 8443+ host req `shouldBe` "api.example.com"+ queryString req `shouldBe` ""
+ test/Network/OAuth2/TokenRequestSpec.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE QuasiQuotes #-}++module Network.OAuth2.TokenRequestSpec where++import Data.Aeson qualified as Aeson+import Network.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|]+ }+ )
+ test/Network/OAuth2/TokenResponseSpec.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Network.OAuth2.TokenResponseSpec where++import Data.Aeson qualified as Aeson+import Data.Binary qualified as Binary+import Data.Maybe (fromJust)+import Network.OAuth2 (AccessToken (..), RefreshToken (..), TokenResponse (..))+import Test.Hspec++spec :: Spec+spec = do+ describe "decode as JSON" $ do+ it "parse access token" $ do+ let resp = "{\"access_token\":\"ya29\",\"token_type\":\"Bearer\",\"expires_in\":3600,\"refresh_token\":\"0gk\"}"+ Aeson.eitherDecode resp+ `shouldBe` Right+ ( TokenResponse+ { accessToken = AccessToken "ya29"+ , refreshToken = Just (RefreshToken "0gk")+ , expiresIn = Just 3600+ , tokenType = Just "Bearer"+ , idToken = Nothing+ , scope = Nothing+ , rawResponse = fromJust (Aeson.decode resp)+ }+ )+ it "parse access token with scope" $ do+ let resp = "{\"access_token\":\"ya29\",\"token_type\":\"Bearer\",\"expires_in\":3600,\"refresh_token\":\"0gk\",\"scope\": \"openid profile\"}"+ Aeson.eitherDecode resp+ `shouldBe` Right+ ( TokenResponse+ { accessToken = AccessToken "ya29"+ , refreshToken = Just (RefreshToken "0gk")+ , expiresIn = Just 3600+ , tokenType = Just "Bearer"+ , idToken = Nothing+ , scope = Just "openid profile"+ , rawResponse = fromJust (Aeson.decode resp)+ }+ )+ describe "encode/decode binary" $ do+ it "support binary encoding" $ do+ let resp = "{\"access_token\":\"ya29\",\"token_type\":\"Bearer\",\"expires_in\":3600,\"refresh_token\":\"0gk\"}"+ oauth2Token = fromJust (Aeson.decode @TokenResponse resp)+ Binary.decode @TokenResponse (Binary.encode oauth2Token)+ `shouldBe` oauth2Token
+ test/Spec.hs view
@@ -0,0 +1,2 @@+-- file test/Spec.hs+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}