yesod-auth-oauth2 0.6.2.3 → 0.6.3.0

raw patch · 7 files changed

+183/−107 lines, 7 filesdep +mtldep +unliftioPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl, unliftio

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−1
• src/UnliftIO/Except.hs +12/−0
• src/Yesod/Auth/OAuth2/Dispatch.hs +43/−103
• src/Yesod/Auth/OAuth2/DispatchError.hs +81/−0
• src/Yesod/Auth/OAuth2/Google.hs +12/−2
• src/Yesod/Auth/OAuth2/Random.hs +19/−0
• yesod-auth-oauth2.cabal +6/−1

@@ -1,6 +1,15 @@-## [_Unreleased_](https://github.com/thoughtbot/yesod-auth-oauth2/compare/v0.6.2.3...main)+## [_Unreleased_](https://github.com/thoughtbot/yesod-auth-oauth2/compare/v0.6.3.0...main)  None++## [v0.6.3.0](https://github.com/thoughtbot/yesod-auth-oauth2/compare/v0.6.2.3...v0.6.3.0)++- Expose `onDispatchError` and generic `OtherDispatchError` for passthrough log+- Don't throw exceptions; handle all errors through the set-message-redirect+  path+- Respect `onErrorHtml` for said error-handling+- Support custom widget in Google plugin+  [@jmorag](https://github.com/freckle/yesod-auth-oauth2/pull/149)  ## [v0.6.2.3](https://github.com/thoughtbot/yesod-auth-oauth2/compare/v0.6.2.2...v0.6.2.3) 

@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module UnliftIO.Except+    () where++import Control.Monad.Except+import UnliftIO++instance (MonadUnliftIO m, Exception e) => MonadUnliftIO (ExceptT e m) where+    withRunInIO exceptToIO = ExceptT $ try $ do+        withRunInIO $ \runInIO ->+            exceptToIO (runInIO . (either throwIO pure <=< runExceptT))

@@ -1,36 +1,30 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+ module Yesod.Auth.OAuth2.Dispatch     ( FetchToken     , fetchAccessToken     , fetchAccessToken2     , FetchCreds     , dispatchAuthRequest-    )-where+    ) where -import Control.Exception.Safe-import Control.Monad (unless, (<=<))-import Crypto.Random (getRandomBytes)-import Data.ByteArray.Encoding (Base(Base64), convertToBase)-import Data.ByteString (ByteString)+import Control.Monad.Except import Data.Text (Text) import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Text.Encoding (encodeUtf8) import Network.HTTP.Conduit (Manager) import Network.OAuth.OAuth2 import Network.OAuth.OAuth2.TokenRequest (Errors) import URI.ByteString.Extension+import UnliftIO.Exception import Yesod.Auth hiding (ServerError)+import Yesod.Auth.OAuth2.DispatchError import Yesod.Auth.OAuth2.ErrorResponse-import Yesod.Auth.OAuth2.Exception+import Yesod.Auth.OAuth2.Random import Yesod.Core hiding (ErrorResponse)  -- | How to fetch an @'OAuth2Token'@@@ -53,9 +47,9 @@     -> [Text]           -- ^ Path pieces     -> AuthHandler m TypedContent dispatchAuthRequest name oauth2 _ _ "GET" ["forward"] =-    dispatchForward name oauth2+    handleDispatchError $ dispatchForward name oauth2 dispatchAuthRequest name oauth2 getToken getCreds "GET" ["callback"] =-    dispatchCallback name oauth2 getToken getCreds+    handleDispatchError $ dispatchCallback name oauth2 getToken getCreds dispatchAuthRequest _ _ _ _ _ _ = notFound  -- | Handle @GET \/forward@@@ -63,7 +57,11 @@ -- 1. Set a random CSRF token in our session -- 2. Redirect to the Provider's authorization URL ---dispatchForward :: Text -> OAuth2 -> AuthHandler m TypedContent+dispatchForward+    :: (MonadError DispatchError m, MonadAuthHandler site m)+    => Text+    -> OAuth2+    -> m TypedContent dispatchForward name oauth2 = do     csrf <- setSessionCSRF $ tokenSessionKey name     oauth2' <- withCallbackAndState name oauth2 csrf@@ -76,76 +74,35 @@ -- 3. Use the AccessToken to construct a @'Creds'@ value for the Provider -- dispatchCallback-    :: Text+    :: (MonadError DispatchError m, MonadAuthHandler site m)+    => Text     -> OAuth2     -> FetchToken-    -> FetchCreds m-    -> AuthHandler m TypedContent+    -> FetchCreds site+    -> m TypedContent dispatchCallback name oauth2 getToken getCreds = do+    onErrorResponse $ throwError . OAuth2HandshakeError     csrf <- verifySessionCSRF $ tokenSessionKey name-    onErrorResponse $ oauth2HandshakeError name     code <- requireGetParam "code"     manager <- authHttpManager     oauth2' <- withCallbackAndState name oauth2 csrf-    token <- errLeft $ getToken manager oauth2' $ ExchangeToken code-    creds <- errLeft $ tryFetchCreds $ getCreds manager token+    token <- either (throwError . OAuth2ResultError) pure+        =<< liftIO (getToken manager oauth2' $ ExchangeToken code)+    creds <-+        liftIO (getCreds manager token)+        `catch` (throwError . FetchCredsIOException)+        `catch` (throwError . FetchCredsYesodOAuth2Exception)     setCredsRedirect creds-  where-    errLeft :: Show e => IO (Either e a) -> AuthHandler m a-    errLeft = either (unexpectedError name) pure <=< liftIO --- | Handle an OAuth2 @'ErrorResponse'@------ These are things coming from the OAuth2 provider such an Invalid Grant or--- Invalid Scope and /may/ be user-actionable. We've coded them to have an--- @'erUserMessage'@ that we are comfortable displaying to the user as part of--- the redirect, just in case.----oauth2HandshakeError :: Text -> ErrorResponse -> AuthHandler m a-oauth2HandshakeError name err = do-    $(logError) $ "Handshake failure in " <> name <> " plugin: " <> tshow err-    redirectMessage $ "OAuth2 handshake failure: " <> erUserMessage err---- | Handle an unexpected error------ This would be some unexpected exception while processing the callback.--- Therefore, the user should see an opaque message and the details go only to--- the server logs.----unexpectedError :: Show e => Text -> e -> AuthHandler m a-unexpectedError name err = do-    $(logError) $ "Error in " <> name <> " OAuth2 plugin: " <> tshow err-    redirectMessage "Unexpected error logging in with OAuth2"--redirectMessage :: Text -> AuthHandler m a-redirectMessage msg = do-    toParent <- getRouteToParent-    setMessage $ toHtml msg-    redirect $ toParent LoginR--tryFetchCreds :: IO a -> IO (Either SomeException a)-tryFetchCreds f =-    (Right <$> f)-        `catch` (\(ex :: IOException) -> pure $ Left $ toException ex)-        `catch` (\(ex :: YesodOAuth2Exception) -> pure $ Left $ toException ex)--withCallbackAndState :: Text -> OAuth2 -> Text -> AuthHandler m OAuth2+withCallbackAndState+    :: (MonadError DispatchError m, MonadAuthHandler site m)+    => Text+    -> OAuth2+    -> Text+    -> m OAuth2 withCallbackAndState name oauth2 csrf = do-    let url = PluginR name ["callback"]-    render <- getParentUrlRender-    let callbackText = render url--    callback <--        maybe-                (liftIO-                $ throwString-                $ "Invalid callback URI: "-                <> T.unpack callbackText-                <> ". Not using an absolute Approot?"-                )-                pure-            $ fromText callbackText-+    uri <- ($ PluginR name ["callback"]) <$> getParentUrlRender+    callback <- maybe (throwError $ InvalidCallbackUri uri) pure $ fromText uri     pure oauth2         { oauthCallback = Just callback         , oauthOAuthorizeEndpoint =@@ -169,40 +126,23 @@ setSessionCSRF sessionKey = do     csrfToken <- liftIO randomToken     csrfToken <$ setSession sessionKey csrfToken-  where-    randomToken =-        T.filter (/= '+')-            . decodeUtf8-            . convertToBase @ByteString Base64-            <$> getRandomBytes 64+    where randomToken = T.filter (/= '+') <$> randomText 64  -- | Verify the callback provided the same CSRF token as in our session-verifySessionCSRF :: MonadHandler m => Text -> m Text+verifySessionCSRF+    :: (MonadError DispatchError m, MonadHandler m) => Text -> m Text verifySessionCSRF sessionKey = do     token <- requireGetParam "state"     sessionToken <- lookupSession sessionKey     deleteSession sessionKey--    unless (sessionToken == Just token) $ do-        $(logError)-            $ "state token does not match. "-            <> "Param: "-            <> tshow token-            <> "State: "-            <> tshow sessionToken-        permissionDenied "Invalid OAuth2 state token"--    return token+    token <$ unless+        (sessionToken == Just token)+        (throwError $ InvalidStateToken sessionToken token) -requireGetParam :: MonadHandler m => Text -> m Text-requireGetParam key = do-    m <- lookupGetParam key-    maybe errInvalidArgs return m-  where-    errInvalidArgs = invalidArgs ["The '" <> key <> "' parameter is required"]+requireGetParam+    :: (MonadError DispatchError m, MonadHandler m) => Text -> m Text+requireGetParam key =+    maybe (throwError $ MissingParameter key) pure =<< lookupGetParam key  tokenSessionKey :: Text -> Text tokenSessionKey name = "_yesod_oauth2_" <> name--tshow :: Show a => a -> Text-tshow = T.pack . show

@@ -0,0 +1,81 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Yesod.Auth.OAuth2.DispatchError+    ( DispatchError(..)+    , handleDispatchError+    , onDispatchError+    ) where++import Control.Monad.Except+import Data.Text (Text, pack)+import Network.OAuth.OAuth2+import Network.OAuth.OAuth2.TokenRequest (Errors)+import UnliftIO.Except ()+import UnliftIO.Exception+import Yesod.Auth hiding (ServerError)+import Yesod.Auth.OAuth2.ErrorResponse+import Yesod.Auth.OAuth2.Exception+import Yesod.Auth.OAuth2.Random+import Yesod.Core hiding (ErrorResponse)++data DispatchError+    = MissingParameter Text+    | InvalidStateToken (Maybe Text) Text+    | InvalidCallbackUri Text+    | OAuth2HandshakeError ErrorResponse+    | OAuth2ResultError (OAuth2Error Errors)+    | FetchCredsIOException IOException+    | FetchCredsYesodOAuth2Exception YesodOAuth2Exception+    | OtherDispatchError Text+    deriving stock Show+    deriving anyclass Exception++-- | User-friendly message for any given 'DispatchError'+--+-- Most of these are opaque to the user. The exception details are present for+-- the server logs.+--+dispatchErrorMessage :: DispatchError -> Text+dispatchErrorMessage = \case+    MissingParameter name ->+        "Parameter '" <> name <> "' is required, but not present in the URL"+    InvalidStateToken{} -> "State token is invalid, please try again"+    InvalidCallbackUri{}+        -> "Callback URI was not valid, this server may be misconfigured (no approot)"+    OAuth2HandshakeError er -> "OAuth2 handshake failure: " <> erUserMessage er+    OAuth2ResultError{} -> "Login failed, please try again"+    FetchCredsIOException{} -> "Login failed, please try again"+    FetchCredsYesodOAuth2Exception{} -> "Login failed, please try again"+    OtherDispatchError{} -> "Login failed, please try again"++handleDispatchError+    :: MonadAuthHandler site m+    => ExceptT DispatchError m TypedContent+    -> m TypedContent+handleDispatchError f = do+    result <- runExceptT f+    either onDispatchError pure result++onDispatchError :: MonadAuthHandler site m => DispatchError -> m TypedContent+onDispatchError err = do+    errorId <- liftIO $ randomText 16+    let suffix = " [errorId=" <> errorId <> "]"+    $(logError) $ pack (displayException err) <> suffix++    let message = dispatchErrorMessage err <> suffix+        messageValue =+            object ["error" .= object ["id" .= errorId, "message" .= message]]++    loginR <- ($ LoginR) <$> getRouteToParent++    selectRep $ do+        provideRep @_ @Html $ onErrorHtml loginR message+        provideRep @_ @Value $ pure messageValue

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} -- | -- -- OAuth2 plugin for http://www.google.com@@ -25,11 +26,14 @@ -- module Yesod.Auth.OAuth2.Google     ( oauth2Google+    , oauth2GoogleWidget     , oauth2GoogleScoped+    , oauth2GoogleScopedWidget     ) where  import Yesod.Auth.OAuth2.Prelude+import Yesod.Core (WidgetFor, whamlet)  newtype User = User Text @@ -48,9 +52,15 @@ oauth2Google :: YesodAuth m => Text -> Text -> AuthPlugin m oauth2Google = oauth2GoogleScoped defaultScopes +oauth2GoogleWidget :: YesodAuth m => WidgetFor m () -> Text -> Text -> AuthPlugin m+oauth2GoogleWidget widget = oauth2GoogleScopedWidget widget defaultScopes+ oauth2GoogleScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m-oauth2GoogleScoped scopes clientId clientSecret =-    authOAuth2 pluginName oauth2 $ \manager token -> do+oauth2GoogleScoped = oauth2GoogleScopedWidget [whamlet|Login via #{pluginName}|]++oauth2GoogleScopedWidget :: YesodAuth m => WidgetFor m () -> [Text] -> Text -> Text -> AuthPlugin m+oauth2GoogleScopedWidget widget scopes clientId clientSecret =+    authOAuth2Widget widget pluginName oauth2 $ \manager token -> do         (User userId, userResponse) <- authGetProfile             pluginName             manager

@@ -0,0 +1,19 @@+{-# LANGUAGE TypeApplications #-}++module Yesod.Auth.OAuth2.Random+    ( randomText+    ) where++import Crypto.Random (MonadRandom, getRandomBytes)+import Data.ByteArray.Encoding (Base(Base64), convertToBase)+import Data.ByteString (ByteString)+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8)++randomText+    :: MonadRandom m+    => Int+    -- ^ Size in Bytes (note necessarily characters)+    -> m Text+randomText size =+    decodeUtf8 . convertToBase @ByteString Base64 <$> getRandomBytes size

@@ -1,6 +1,6 @@ cabal-version:      1.12 name:               yesod-auth-oauth2-version:            0.6.2.3+version:            0.6.3.0 license:            MIT license-file:       LICENSE maintainer:         engineering@freckle.com@@ -31,6 +31,7 @@  library     exposed-modules:+        UnliftIO.Except         URI.ByteString.Extension         Yesod.Auth.OAuth2         Yesod.Auth.OAuth2.AzureAD@@ -38,6 +39,7 @@         Yesod.Auth.OAuth2.Bitbucket         Yesod.Auth.OAuth2.ClassLink         Yesod.Auth.OAuth2.Dispatch+        Yesod.Auth.OAuth2.DispatchError         Yesod.Auth.OAuth2.ErrorResponse         Yesod.Auth.OAuth2.EveOnline         Yesod.Auth.OAuth2.Exception@@ -46,6 +48,7 @@         Yesod.Auth.OAuth2.Google         Yesod.Auth.OAuth2.Nylas         Yesod.Auth.OAuth2.Prelude+        Yesod.Auth.OAuth2.Random         Yesod.Auth.OAuth2.Salesforce         Yesod.Auth.OAuth2.Slack         Yesod.Auth.OAuth2.Spotify@@ -68,8 +71,10 @@         http-types >=0.8 && <0.13,         memory >=0.15.0 && <0.16,         microlens >=0.4.11.2 && <0.5,+        mtl >=2.2.2 && <2.3,         safe-exceptions >=0.1.7.1 && <0.2,         text >=0.7 && <2.0,+        unliftio >=0.2.14 && <0.3,         uri-bytestring >=0.3.3.0 && <0.4,         yesod-auth >=1.6.0 && <1.7,         yesod-core >=1.6.0 && <1.7