diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,21 @@ -Copyright (c)2012-present, Haisheng Wu - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: +MIT License - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. +Copyright (c) 2022 Haisheng Wu - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: - * Neither the name of Haisheng Wu nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,25 +1,11 @@ -[![Build Status](https://secure.travis-ci.org/freizl/hoauth2.svg?branch=master)](http://travis-ci.org/freizl/hoauth2) -[![Hackage](https://img.shields.io/hackage/v/hoauth2.svg)](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 - -## 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) diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/example/App.hs b/example/App.hs deleted file mode 100644 --- a/example/App.hs +++ /dev/null @@ -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) diff --git a/example/IDP.hs b/example/IDP.hs deleted file mode 100644 --- a/example/IDP.hs +++ /dev/null @@ -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) diff --git a/example/IDP/Auth0.hs b/example/IDP/Auth0.hs deleted file mode 100644 --- a/example/IDP/Auth0.hs +++ /dev/null @@ -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} diff --git a/example/IDP/AzureAD.hs b/example/IDP/AzureAD.hs deleted file mode 100644 --- a/example/IDP/AzureAD.hs +++ /dev/null @@ -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 } diff --git a/example/IDP/Douban.hs b/example/IDP/Douban.hs deleted file mode 100644 --- a/example/IDP/Douban.hs +++ /dev/null @@ -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 } - diff --git a/example/IDP/Dropbox.hs b/example/IDP/Dropbox.hs deleted file mode 100644 --- a/example/IDP/Dropbox.hs +++ /dev/null @@ -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 } diff --git a/example/IDP/Facebook.hs b/example/IDP/Facebook.hs deleted file mode 100644 --- a/example/IDP/Facebook.hs +++ /dev/null @@ -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 } diff --git a/example/IDP/Fitbit.hs b/example/IDP/Fitbit.hs deleted file mode 100644 --- a/example/IDP/Fitbit.hs +++ /dev/null @@ -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 } diff --git a/example/IDP/Github.hs b/example/IDP/Github.hs deleted file mode 100644 --- a/example/IDP/Github.hs +++ /dev/null @@ -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 } diff --git a/example/IDP/Google.hs b/example/IDP/Google.hs deleted file mode 100644 --- a/example/IDP/Google.hs +++ /dev/null @@ -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 } - diff --git a/example/IDP/Linkedin.hs b/example/IDP/Linkedin.hs deleted file mode 100644 --- a/example/IDP/Linkedin.hs +++ /dev/null @@ -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 - } --} diff --git a/example/IDP/Okta.hs b/example/IDP/Okta.hs deleted file mode 100644 --- a/example/IDP/Okta.hs +++ /dev/null @@ -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 } - diff --git a/example/IDP/StackExchange.hs b/example/IDP/StackExchange.hs deleted file mode 100644 --- a/example/IDP/StackExchange.hs +++ /dev/null @@ -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 diff --git a/example/IDP/Weibo.hs b/example/IDP/Weibo.hs deleted file mode 100644 --- a/example/IDP/Weibo.hs +++ /dev/null @@ -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} diff --git a/example/IDP/ZOHO.hs b/example/IDP/ZOHO.hs deleted file mode 100644 --- a/example/IDP/ZOHO.hs +++ /dev/null @@ -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 } - diff --git a/example/Keys.hs b/example/Keys.hs deleted file mode 100644 --- a/example/Keys.hs +++ /dev/null @@ -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|] - } diff --git a/example/Keys.hs.sample b/example/Keys.hs.sample deleted file mode 100644 --- a/example/Keys.hs.sample +++ /dev/null @@ -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|] - } diff --git a/example/README.org b/example/README.org deleted file mode 100644 --- a/example/README.org +++ /dev/null @@ -1,26 +0,0 @@ -* IDPs - -- Auth0: -- AzureAD: -- Douban: -- DropBox: -- Facebook: -- Fitbit: -- Github: -- Google: -- Okta: https://developer.okta.com/docs/reference/api/oidc/ -- StackExchange: - - StackExchange Apps page: -- Weibo: -- ZOHO: https://www.zoho.com/crm/developer/docs/api/v2/oauth-overview.html - -* WIP: Linkedin - - - - -* 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 diff --git a/example/Session.hs b/example/Session.hs deleted file mode 100644 --- a/example/Session.hs +++ /dev/null @@ -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 diff --git a/example/Types.hs b/example/Types.hs deleted file mode 100644 --- a/example/Types.hs +++ /dev/null @@ -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' - ] diff --git a/example/Utils.hs b/example/Utils.hs deleted file mode 100644 --- a/example/Utils.hs +++ /dev/null @@ -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 diff --git a/example/Views.hs b/example/Views.hs deleted file mode 100644 --- a/example/Views.hs +++ /dev/null @@ -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" diff --git a/example/assets/main.css b/example/assets/main.css deleted file mode 100644 --- a/example/assets/main.css +++ /dev/null @@ -1,11 +0,0 @@ -body { - padding: 10px 50px; -} - -.login-with { - margin: 10px 0; - padding: 10px; - border: 1px solid grey; - border-radius: 5px; - width: 500px; -} diff --git a/example/main.hs b/example/main.hs deleted file mode 100644 --- a/example/main.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import App (app) - -main :: IO () -main = app diff --git a/example/templates/index.mustache b/example/templates/index.mustache deleted file mode 100644 --- a/example/templates/index.mustache +++ /dev/null @@ -1,31 +0,0 @@ - - - - - -

Hello OAuth2

- {{#idps}} - - {{/idps}} -

Notes

-
    -
  1. for StackExchange, the callback domain is localhost, have manually add port 9988.
    2. -
-

- - diff --git a/hoauth2.cabal b/hoauth2.cabal --- a/hoauth2.cabal +++ b/hoauth2.cabal @@ -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 +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: - . - * Google: - . - * Github: - . - * Facebook: - . - * Fitbit: - . - * StackExchange: - . - * DropBox: - . - * Weibo: - . - * Douban: +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 -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 diff --git a/src/Network/HTTP/Client/Contrib.hs b/src/Network/HTTP/Client/Contrib.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Client/Contrib.hs @@ -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 diff --git a/src/Network/OAuth/OAuth2.hs b/src/Network/OAuth/OAuth2.hs deleted file mode 100644 --- a/src/Network/OAuth/OAuth2.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Network/OAuth/OAuth2/AuthorizationRequest.hs b/src/Network/OAuth/OAuth2/AuthorizationRequest.hs deleted file mode 100644 --- a/src/Network/OAuth/OAuth2/AuthorizationRequest.hs +++ /dev/null @@ -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) diff --git a/src/Network/OAuth/OAuth2/HttpClient.hs b/src/Network/OAuth/OAuth2/HttpClient.hs deleted file mode 100644 --- a/src/Network/OAuth/OAuth2/HttpClient.hs +++ /dev/null @@ -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 } diff --git a/src/Network/OAuth/OAuth2/Internal.hs b/src/Network/OAuth/OAuth2/Internal.hs deleted file mode 100644 --- a/src/Network/OAuth/OAuth2/Internal.hs +++ /dev/null @@ -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. -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 #-} diff --git a/src/Network/OAuth/OAuth2/TokenRequest.hs b/src/Network/OAuth/OAuth2/TokenRequest.hs deleted file mode 100644 --- a/src/Network/OAuth/OAuth2/TokenRequest.hs +++ /dev/null @@ -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) diff --git a/src/Network/OAuth2.hs b/src/Network/OAuth2.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2.hs @@ -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 diff --git a/src/Network/OAuth2/AuthorizationRequest.hs b/src/Network/OAuth2/AuthorizationRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/AuthorizationRequest.hs @@ -0,0 +1,88 @@ +-- | Bindings Authorization part of The OAuth 2.0 Authorization Framework +-- 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) + ] diff --git a/src/Network/OAuth2/Experiment.hs b/src/Network/OAuth2/Experiment.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment.hs @@ -0,0 +1,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) diff --git a/src/Network/OAuth2/Experiment/Flows.hs b/src/Network/OAuth2/Experiment/Flows.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows.hs @@ -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 +-- . +-- +-- 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 +-- . +-- +-- 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 +-- . +-- 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 +-- . +-- +-- 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 +-- . +-- +-- 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 diff --git a/src/Network/OAuth2/Experiment/Flows/AuthorizationRequest.hs b/src/Network/OAuth2/Experiment/Flows/AuthorizationRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows/AuthorizationRequest.hs @@ -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 + ] diff --git a/src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs b/src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs @@ -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 + ] diff --git a/src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs b/src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs @@ -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 diff --git a/src/Network/OAuth2/Experiment/Flows/TokenRequest.hs b/src/Network/OAuth2/Experiment/Flows/TokenRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows/TokenRequest.hs @@ -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 diff --git a/src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs b/src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs @@ -0,0 +1,7 @@ +module Network.OAuth2.Experiment.Flows.UserInfoRequest where + +------------------------------------------------------------------------------- +-- User Info Request -- +------------------------------------------------------------------------------- + +class HasUserInfoRequest a diff --git a/src/Network/OAuth2/Experiment/Grants.hs b/src/Network/OAuth2/Experiment/Grants.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants.hs @@ -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 (..)) diff --git a/src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs b/src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs @@ -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 + } diff --git a/src/Network/OAuth2/Experiment/Grants/ClientCredentials.hs b/src/Network/OAuth2/Experiment/Grants/ClientCredentials.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants/ClientCredentials.hs @@ -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 diff --git a/src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs b/src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs @@ -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 diff --git a/src/Network/OAuth2/Experiment/Grants/JwtBearer.hs b/src/Network/OAuth2/Experiment/Grants/JwtBearer.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants/JwtBearer.hs @@ -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 diff --git a/src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs b/src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs @@ -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 + } diff --git a/src/Network/OAuth2/Experiment/Pkce.hs b/src/Network/OAuth2/Experiment/Pkce.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Pkce.hs @@ -0,0 +1,82 @@ +module Network.OAuth2.Experiment.Pkce ( + mkPkceParam, + CodeChallenge (..), + CodeVerifier (..), + CodeChallengeMethod (..), + PkceRequestParam (..), +) where + +import Control.Monad.IO.Class +import Crypto.Hash qualified as H +import Crypto.Random qualified as Crypto +import Data.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] diff --git a/src/Network/OAuth2/Experiment/Types.hs b/src/Network/OAuth2/Experiment/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Types.hs @@ -0,0 +1,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" diff --git a/src/Network/OAuth2/Experiment/Utils.hs b/src/Network/OAuth2/Experiment/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Utils.hs @@ -0,0 +1,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' diff --git a/src/Network/OAuth2/HttpClient.hs b/src/Network/OAuth2/HttpClient.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/HttpClient.hs @@ -0,0 +1,245 @@ +-- | Bindings for The OAuth 2.0 Authorization Framework: Bearer Token Usage +-- 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)] diff --git a/src/Network/OAuth2/Internal.hs b/src/Network/OAuth2/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Internal.hs @@ -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' diff --git a/src/Network/OAuth2/TokenRequest.hs b/src/Network/OAuth2/TokenRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/TokenRequest.hs @@ -0,0 +1,362 @@ +-- | Bindings Access Token and Refresh Token part of The OAuth 2.0 Authorization Framework +-- 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) + ] diff --git a/test/Network/OAuth2/InternalSpec.hs b/test/Network/OAuth2/InternalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/OAuth2/InternalSpec.hs @@ -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` "" diff --git a/test/Network/OAuth2/TokenRequestSpec.hs b/test/Network/OAuth2/TokenRequestSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/OAuth2/TokenRequestSpec.hs @@ -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|] + } + ) diff --git a/test/Network/OAuth2/TokenResponseSpec.hs b/test/Network/OAuth2/TokenResponseSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/OAuth2/TokenResponseSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +-- file test/Spec.hs +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}