hyperbole-oauth2 (empty) → 0.7.0
raw patch · 3 files changed
+352/−0 lines, 3 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, casing, containers, data-default, effectful, http-client, http-client-tls, http-types, hyperbole, random, string-conversions, text
Files
- README.md +0/−0
- hyperbole-oauth2.cabal +59/−0
- src/Web/Hyperbole/OAuth2.hs +293/−0
+ README.md view
+ hyperbole-oauth2.cabal view
@@ -0,0 +1,59 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.39.5.+--+-- see: https://github.com/sol/hpack++name: hyperbole-oauth2+version: 0.7.0+synopsis: OAuth2 Support for Hyperbole+description: OAuth2 Support for the Hyperbole framework+category: Web, Network+homepage: https://github.com/seanhess/hyperbole+bug-reports: https://github.com/seanhess/hyperbole/issues+author: Sean Hess+maintainer: seanhess@gmail.com+license: BSD-3-Clause+build-type: Simple+extra-doc-files:+ README.md++source-repository head+ type: git+ location: https://github.com/seanhess/hyperbole++library+ exposed-modules:+ Web.Hyperbole.OAuth2+ other-modules:+ Paths_hyperbole_oauth2+ autogen-modules:+ Paths_hyperbole_oauth2+ hs-source-dirs:+ src+ default-extensions:+ OverloadedStrings+ OverloadedRecordDot+ DuplicateRecordFields+ NoFieldSelectors+ TypeFamilies+ DataKinds+ DerivingStrategies+ DeriveAnyClass+ ghc-options: -Wall -fdefer-typed-holes+ build-depends:+ aeson >=2.1.2.1 && <2.4+ , base >=4.16 && <5+ , bytestring >=0.11 && <0.13+ , casing >=0.1.2 && <0.2+ , containers >=0.6 && <1+ , data-default ==0.8.*+ , effectful >=2.4 && <3+ , http-client ==0.7.*+ , http-client-tls >=0.3 && <0.5+ , http-types ==0.12.*+ , hyperbole >=0.6 && <1+ , random >=1.2 && <2+ , string-conversions ==0.4.*+ , text >=1.2 && <3+ default-language: GHC2021
+ src/Web/Hyperbole/OAuth2.hs view
@@ -0,0 +1,293 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LambdaCase #-}++{- |+Module: Web.Hyperbole.OAuth2+Copyright: (c) 2024 Sean Hess+License: BSD3+Maintainer: Sean Hess <seanhess@gmail.com>+Stability: experimental+Portability: portable++OAuth2 support for [Hyperbole](https://hackage.haskell.org/package/hyperbole)++* [hyperbole.live](https://hyperbole.live) - documentation and examples+* [github](https://github.com/seanhess/hyperbole) - issues and source code+-}+module Web.Hyperbole.OAuth2+ ( OAuth2 (..)+ , authUrl+ , validateCode+ , exchangeAuth+ , exchangeRefresh+ , runOAuth2+ , getConfigEnv+ , Scopes (..)+ , AuthFlow (..)+ , Config (..)+ , TokenType (..)+ , Authenticated (..)+ , Token (..)+ , ClientId+ , ClientSecret+ , Code+ , Access+ , Refresh+ , State+ , Auth+ , OAuth2Error (..)+ ) where++import Control.Monad (unless, when)+import Data.Aeson (FromJSON (..), Options (..), ToJSON (..), Value (..), defaultOptions, eitherDecode, genericParseJSON, genericToJSON)+import Data.ByteString.Lazy qualified as BL+import Data.Default+import Data.Maybe (isJust)+import Data.String (IsString (..))+import Data.String.Conversions (cs)+import Data.Text (Text)+import Data.Text qualified as T+import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Environment+import Effectful.Exception+import GHC.Generics (Generic)+import Network.HTTP.Client (HttpException, Request (..), RequestBody (..))+import Network.HTTP.Client qualified as HTTP+import Network.HTTP.Types (hAccept, hContentType)+import Text.Casing (quietSnake)+import Web.Hyperbole.Data.URI+import Web.Hyperbole.Effect.GenRandom+import Web.Hyperbole.Effect.Hyperbole+import Web.Hyperbole.Effect.Query+import Web.Hyperbole.Effect.Response (respondError)+import Web.Hyperbole.Effect.Session (Session (..), deleteSession, saveSession, session)+import Web.Hyperbole.Types.Response+++authUrl :: (OAuth2 :> es) => URI -> Scopes -> Eff es URI+authUrl redirectUrl scopes = send $ AuthUrl redirectUrl scopes+++validateCode :: (OAuth2 :> es) => Eff es (Token Code)+validateCode = send ValidateCode+++exchangeAuth :: (OAuth2 :> es) => Token Code -> Eff es Authenticated+exchangeAuth authCode = send $ ExchangeAuth authCode+++exchangeRefresh :: (OAuth2 :> es) => Token Refresh -> Eff es Authenticated+exchangeRefresh refToken = send $ ExchangeRefresh refToken+++data OAuth2 :: Effect where+ AuthUrl :: URI -> Scopes -> OAuth2 m URI+ ValidateCode :: OAuth2 m (Token Code)+ ExchangeAuth :: Token Code -> OAuth2 m Authenticated+ ExchangeRefresh :: Token Refresh -> OAuth2 m Authenticated+++type instance DispatchOf OAuth2 = 'Dynamic+++runOAuth2+ :: (GenRandom :> es, IOE :> es, Hyperbole :> es)+ => Config+ -> HTTP.Manager+ -> Eff (OAuth2 : es) a+ -> Eff es a+runOAuth2 cfg mgr = interpret $ \_ -> \case+ AuthUrl red scopes -> do+ state <- genRandomToken 6+ let url = authorizationUrl cfg.authorize cfg.clientId red scopes state+ saveSession $ AuthFlow red state+ pure url+ ValidateCode -> do+ flow <- session @AuthFlow+ validateRedirectParams flow+ ExchangeAuth authCode -> do+ flow <- session @AuthFlow+ let params = tokenParams cfg.clientId cfg.clientSecret flow.redirect authCode+ auth <- sendTokenRequest cfg mgr params+ deleteSession @AuthFlow+ pure auth+ ExchangeRefresh refToken -> do+ let params = refreshParams cfg.clientId cfg.clientSecret refToken+ sendTokenRequest cfg mgr params+++{- | read oauth config from env. This is not required, you can obtain these secrets another way+and configure the app however you please. Just pass the results into runOAuth2 in your app+-}+getConfigEnv :: (Environment :> es) => Eff es Config+getConfigEnv = do+ clientId <- Token . cs <$> getEnv "OAUTH2_CLIENT_ID"+ clientSecret <- Token . cs <$> getEnv "OAUTH2_CLIENT_SECRET"+ authorize <- Endpoint <$> getEnvURI "OAUTH2_AUTHORIZE_ENDPOINT"+ token <- Endpoint <$> getEnvURI "OAUTH2_TOKEN_ENDPOINT"+ pure $ Config{clientId, clientSecret, authorize, token}+ where+ getEnvURI n = do+ str <- getEnv n+ case parseURI str of+ Nothing -> throwIO $ OAuth2BadEnv n str+ Just u -> pure u+++-- Types -------------------------------------------------++newtype Scopes = Scopes [Text]+ deriving (Show, Generic)+instance ToJSON Scopes where+ toJSON (Scopes ss) = String $ T.unwords ss+instance FromJSON Scopes where+ parseJSON v = do+ t <- parseJSON @String v+ pure $ fromString t+instance IsString Scopes where+ fromString s = Scopes $ T.words $ cs s+++data ClientId+data ClientSecret+data Code+data Refresh+data Access+data State+data Auth++#if (!MIN_VERSION_aeson(2,2,0))+instance FromJSON URI+instance ToJSON URI+instance FromJSON URIAuth+instance ToJSON URIAuth+#endif+++data AuthFlow = AuthFlow+ { redirect :: URI+ , state :: Token State+ }+ deriving (Generic, FromJSON, ToJSON)+instance Session AuthFlow where+ sessionKey = "OAuth2AuthFlow"+ cookiePath = Just "/"+instance Default AuthFlow where+ def = AuthFlow (pathUri "/") (Token mempty)+++data Config = Config+ { clientId :: Token ClientId+ , clientSecret :: Token ClientSecret+ , authorize :: Endpoint Auth+ , token :: Endpoint (Token ())+ }+++data TokenType+ = Bearer+ deriving (Show, Read, Generic)+instance ToJSON TokenType where+ toJSON s = toJSON $ show s+instance FromJSON TokenType where+ parseJSON (String ttyp) | T.toLower ttyp == "bearer" = pure Bearer+ parseJSON val = fail $ "expected TokenType but got " <> show val+++data Authenticated = Authenticated+ { tokenType :: TokenType+ , expiresIn :: Maybe Int+ , scope :: Maybe Scopes+ , accessToken :: Token Access+ , refreshToken :: Maybe (Token Refresh)+ }+ deriving (Generic, Show)+instance FromJSON Authenticated where+ parseJSON = genericParseJSON defaultOptions{fieldLabelModifier = quietSnake}+instance ToJSON Authenticated where+ toJSON = genericToJSON defaultOptions{fieldLabelModifier = quietSnake}+instance Session Authenticated where+ sessionKey = "OAuth2Authenticated"+ cookiePath = Just "/"+++data OAuth2Error+ = OAuth2BadResponse String BL.ByteString+ | OAuth2TokenRequest HttpException+ | OAuth2BadEnv String String+ deriving (Show, Exception)+++-- Lower level --------------------------------------------------++authorizationUrl :: Endpoint Auth -> Token ClientId -> URI -> Scopes -> Token State -> URI+authorizationUrl (Endpoint auth) (Token cid) redUrl (Scopes scopes) (Token state) =+ auth{uriQuery = cs $ renderQuery True authParams}+ where+ authParams =+ [ ("response_type", Just "code")+ , ("client_id", Just $ cs cid)+ , ("redirect_uri", Just $ cs $ uriToText redUrl)+ , ("scope", Just $ cs $ T.intercalate " " scopes)+ , ("state", Just $ cs state)+ ]+++tokenParams :: Token ClientId -> Token ClientSecret -> URI -> Token Code -> Query+tokenParams (Token cid) (Token sec) redUrl (Token ac) =+ [ ("grant_type", Just "authorization_code")+ , ("client_id", Just $ cs cid)+ , ("client_secret", Just $ cs sec)+ , ("redirect_uri", Just $ cs $ uriToText redUrl)+ , ("code", Just $ cs ac)+ ]+++refreshParams :: Token ClientId -> Token ClientSecret -> Token Refresh -> Query+refreshParams (Token cid) (Token sec) (Token ref) =+ [ ("grant_type", Just "refresh_token")+ , ("client_id", Just $ cs cid)+ , ("client_secret", Just $ cs sec)+ , ("refresh_token", Just $ cs ref)+ ]+++validateRedirectParams :: (Hyperbole :> es) => AuthFlow -> Eff es (Token Code)+validateRedirectParams flow = do+ err <- lookupParam @Text "error"++ when (isJust err) $ do+ desc <- param "error_description"+ respondError $ ErrAuth desc++ authState <- param @(Token State) "state"+ authCode <- param @(Token Code) "code"++ unless (flow.state == authState) $ do+ respondError $ ErrAuth "Oauth2 State mismatch"++ pure authCode+++sendTokenRequest :: (IOE :> es) => Config -> HTTP.Manager -> Query -> Eff es Authenticated+sendTokenRequest cfg mgr params = do+ baseReq <- HTTP.requestFromURI cfg.token.uri++ let req =+ baseReq+ { method = "POST"+ , requestBody = RequestBodyBS $ renderQuery False params+ , requestHeaders =+ [ (hContentType, "application/x-www-form-urlencoded")+ , (hAccept, "application/json")+ ]+ }++ res <- liftIO (HTTP.httpLbs req mgr) `catch` (throwIO . OAuth2TokenRequest)++ let body = HTTP.responseBody res+ case eitherDecode @Authenticated body of+ Left e -> throwIO $ OAuth2BadResponse e body+ Right tr -> pure tr