haskell/yesod-auth-oauth2
1
0
Fork 0
mirror of https://github.com/freckle/yesod-auth-oauth2.git synced 2026-04-20 09:54:12 +02:00
Code Issues Actions Packages Projects Releases Wiki Activity

Ensure we rescue our exceptions too

Browse Source 
For some reason, I thought tryIO would catch our own exception is we
threw them via throwIO, but that's incorrect. Our own exceptions are not
IOExceptions, so they squeak by. This fixes that.
This commit is contained in:
patrick brisbin 2018-09-18 10:41:17 -04:00
parent dc033e1331
commit e3c61789ba
1 changed files with 10 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
src/Yesod/Auth/OAuth2/Dispatch.hs
View File

@ -3,6 +3,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Yesod.Auth.OAuth2.Dispatch module Yesod.Auth.OAuth2.Dispatch
@ -10,7 +11,7 @@ module Yesod.Auth.OAuth2.Dispatch
, dispatchAuthRequest , dispatchAuthRequest
) where ) where
import Control.Exception.Safe (throwString, tryIO) import Control.Exception.Safe
import Control.Monad (unless, (<=<)) import Control.Monad (unless, (<=<))
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import Data.Text (Text) import Data.Text (Text)
@ -22,6 +23,7 @@ import System.Random (newStdGen, randomRs)
import URI.ByteString.Extension import URI.ByteString.Extension
import Yesod.Auth hiding (ServerError) import Yesod.Auth hiding (ServerError)
import Yesod.Auth.OAuth2.ErrorResponse import Yesod.Auth.OAuth2.ErrorResponse
import Yesod.Auth.OAuth2.Exception
import Yesod.Core hiding (ErrorResponse) import Yesod.Core hiding (ErrorResponse)
-- | How to take an @'OAuth2Token'@ and retrieve user credentials -- | How to take an @'OAuth2Token'@ and retrieve user credentials
@ -66,7 +68,7 @@ dispatchCallback name oauth2 getCreds = do
manager <- authHttpManager manager <- authHttpManager
oauth2' <- withCallbackAndState name oauth2 csrf oauth2' <- withCallbackAndState name oauth2 csrf
token <- errLeft $ fetchAccessToken manager oauth2' $ ExchangeToken code token <- errLeft $ fetchAccessToken manager oauth2' $ ExchangeToken code
creds <- errLeft $ tryIO $ getCreds manager token creds <- errLeft $ tryFetchCreds $ getCreds manager token
setCredsRedirect creds setCredsRedirect creds
where where
errLeft :: Show e => IO (Either e a) -> AuthHandler m a errLeft :: Show e => IO (Either e a) -> AuthHandler m a
@ -83,6 +85,12 @@ redirectMessage msg = do
setMessage $ toHtml msg setMessage $ toHtml msg
redirect $ toParent LoginR 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 :: Text -> OAuth2 -> Text -> AuthHandler m OAuth2
withCallbackAndState name oauth2 csrf = do withCallbackAndState name oauth2 csrf = do
let url = PluginR name ["callback"] let url = PluginR name ["callback"]