diff --git a/src/Yesod/Auth/OAuth2/Dispatch.hs b/src/Yesod/Auth/OAuth2/Dispatch.hs --- a/src/Yesod/Auth/OAuth2/Dispatch.hs +++ b/src/Yesod/Auth/OAuth2/Dispatch.hs @@ -1,7 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Yesod.Auth.OAuth2.Dispatch @@ -9,7 +11,7 @@ , dispatchAuthRequest ) where -import Control.Exception.Safe (throwString, tryIO) +import Control.Exception.Safe import Control.Monad (unless, (<=<)) import Data.Monoid ((<>)) import Data.Text (Text) @@ -19,9 +21,10 @@ import Network.OAuth.OAuth2 import System.Random (newStdGen, randomRs) import URI.ByteString.Extension -import Yesod.Auth -import Yesod.Auth.OAuth2.ErrorResponse (onErrorResponse) -import Yesod.Core +import Yesod.Auth hiding (ServerError) +import Yesod.Auth.OAuth2.ErrorResponse +import Yesod.Auth.OAuth2.Exception +import Yesod.Core hiding (ErrorResponse) -- | How to take an @'OAuth2Token'@ and retrieve user credentials type FetchCreds m = Manager -> OAuth2Token -> IO (Creds m) @@ -34,8 +37,10 @@ -> Text -- ^ Method -> [Text] -- ^ Path pieces -> AuthHandler m TypedContent -dispatchAuthRequest name oauth2 _ "GET" ["forward"] = dispatchForward name oauth2 -dispatchAuthRequest name oauth2 getCreds "GET" ["callback"] = dispatchCallback name oauth2 getCreds +dispatchAuthRequest name oauth2 _ "GET" ["forward"] = + dispatchForward name oauth2 +dispatchAuthRequest name oauth2 getCreds "GET" ["callback"] = + dispatchCallback name oauth2 getCreds dispatchAuthRequest _ _ _ _ _ = notFound -- | Handle @GET \/forward@ @@ -62,51 +67,63 @@ code <- requireGetParam "code" manager <- authHttpManager oauth2' <- withCallbackAndState name oauth2 csrf - token <- denyLeft $ fetchAccessToken manager oauth2' $ ExchangeToken code - creds <- denyLeft $ tryIO $ getCreds manager token + token <- errLeft $ fetchAccessToken manager oauth2' $ ExchangeToken code + creds <- errLeft $ tryFetchCreds $ getCreds manager token setCredsRedirect creds where - -- On a Left result, log it and return an opaque permission-denied - denyLeft :: (MonadHandler m, MonadLogger m, Show e) => IO (Either e a) -> m a - denyLeft = either errInvalidOAuth pure <=< liftIO + errLeft :: Show e => IO (Either e a) -> AuthHandler m a + errLeft = either (errInvalidOAuth . unknownError . tshow) pure <=< liftIO - errInvalidOAuth :: (MonadHandler m, MonadLogger m, Show e) => e -> m a + errInvalidOAuth :: ErrorResponse -> AuthHandler m a errInvalidOAuth err = do - $(logError) $ T.pack $ "OAuth2 error: " <> show err - permissionDenied "Invalid OAuth2 authentication attempt" + $(logError) $ "OAuth2 error (" <> name <> "): " <> tshow err + redirectMessage $ "Unable to log in with OAuth2: " <> erUserMessage err +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 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 + callback <- + maybe + (liftIO + $ throwString + $ "Invalid callback URI: " + <> T.unpack callbackText + <> ". Not using an absolute Approot?" + ) + pure + $ fromText callbackText pure oauth2 { oauthCallback = Just callback - , oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth2 - `withQuery` [("state", encodeUtf8 csrf)] + , oauthOAuthorizeEndpoint = + oauthOAuthorizeEndpoint oauth2 + `withQuery` [("state", encodeUtf8 csrf)] } getParentUrlRender :: MonadHandler m => m (Route (SubHandlerSite m) -> Text) -getParentUrlRender = (.) - <$> getUrlRender - <*> getRouteToParent +getParentUrlRender = (.) <$> getUrlRender <*> getRouteToParent -- | Set a random, 30-character value in the session setSessionCSRF :: MonadHandler m => Text -> m Text setSessionCSRF sessionKey = do csrfToken <- liftIO randomToken csrfToken <$ setSession sessionKey csrfToken - where - randomToken = T.pack . take 30 . randomRs ('a', 'z') <$> newStdGen + where randomToken = T.pack . take 30 . randomRs ('a', 'z') <$> newStdGen -- | Verify the callback provided the same CSRF token as in our session verifySessionCSRF :: MonadHandler m => Text -> m Text @@ -129,3 +146,6 @@ tokenSessionKey :: Text -> Text tokenSessionKey name = "_yesod_oauth2_" <> name + +tshow :: Show a => a -> Text +tshow = T.pack . show diff --git a/src/Yesod/Auth/OAuth2/ErrorResponse.hs b/src/Yesod/Auth/OAuth2/ErrorResponse.hs --- a/src/Yesod/Auth/OAuth2/ErrorResponse.hs +++ b/src/Yesod/Auth/OAuth2/ErrorResponse.hs @@ -5,8 +5,10 @@ -- module Yesod.Auth.OAuth2.ErrorResponse ( ErrorResponse(..) + , erUserMessage , ErrorName(..) , onErrorResponse + , unknownError ) where import Data.Foldable (traverse_) @@ -31,6 +33,25 @@ , erURI :: Maybe Text } deriving Show + +-- | Textual value suitable for display to a User +erUserMessage :: ErrorResponse -> Text +erUserMessage err = case erName err of + InvalidRequest -> "Invalid request" + UnauthorizedClient -> "Unauthorized client" + AccessDenied -> "Access denied" + UnsupportedResponseType -> "Unsupported response type" + InvalidScope -> "Invalid scope" + ServerError -> "Server error" + TemporarilyUnavailable -> "Temporarily unavailable" + Unknown _ -> "Unknown error" + +unknownError :: Text -> ErrorResponse +unknownError x = ErrorResponse + { erName = Unknown x + , erDescription = Nothing + , erURI = Nothing + } -- | Check query parameters for an error, if found run the given action -- diff --git a/src/Yesod/Auth/OAuth2/Exception.hs b/src/Yesod/Auth/OAuth2/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Auth/OAuth2/Exception.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Yesod.Auth.OAuth2.Exception + ( YesodOAuth2Exception(..) + ) where + +import Control.Exception.Safe +import Data.ByteString.Lazy (ByteString) +import Data.Text (Text) + +data YesodOAuth2Exception + = OAuth2Error Text ByteString + -- ^ HTTP error during OAuth2 handshake + -- + -- Plugin name and JSON-encoded @OAuth2Error@ from @hoauth2@. + -- + | JSONDecodingError Text String + -- ^ User profile was not as expected + -- + -- Plugin name and Aeson parse error message. + -- + | GenericError Text String + -- ^ Other error conditions + -- + -- Plugin name and error message. + -- + deriving (Show, Typeable) + +instance Exception YesodOAuth2Exception diff --git a/src/Yesod/Auth/OAuth2/Nylas.hs b/src/Yesod/Auth/OAuth2/Nylas.hs --- a/src/Yesod/Auth/OAuth2/Nylas.hs +++ b/src/Yesod/Auth/OAuth2/Nylas.hs @@ -10,6 +10,7 @@ import qualified Data.ByteString.Lazy.Char8 as BL8 import Network.HTTP.Client import qualified Network.HTTP.Types as HT +import qualified Yesod.Auth.OAuth2.Exception as YesodOAuth2Exception newtype User = User Text @@ -34,31 +35,34 @@ -- FIXME: was this working? I'm 95% sure that the client will throw its -- own exception on unsuccessful status codes. unless (HT.statusIsSuccessful $ responseStatus resp) - $ throwIO $ InvalidProfileResponse pluginName - $ "Unsuccessful HTTP response: " <> userResponse - + $ throwIO + $ YesodOAuth2Exception.GenericError pluginName + $ "Unsuccessful HTTP response: " + <> BL8.unpack userResponse either - (throwIO . InvalidProfileResponse pluginName . BL8.pack) - (\(User userId) -> pure Creds - { credsPlugin = pluginName - , credsIdent = userId - , credsExtra = setExtra token userResponse - } - ) + (throwIO . YesodOAuth2Exception.JSONDecodingError pluginName) + (\(User userId) -> pure Creds + { credsPlugin = pluginName + , credsIdent = userId + , credsExtra = setExtra token userResponse + } + ) $ eitherDecode userResponse where oauth = OAuth2 { oauthClientId = clientId , oauthClientSecret = clientSecret - , oauthOAuthorizeEndpoint = "https://api.nylas.com/oauth/authorize" `withQuery` - [ ("response_type", "code") - , ("client_id", encodeUtf8 clientId) + , oauthOAuthorizeEndpoint = "https://api.nylas.com/oauth/authorize" + `withQuery` [ ("response_type", "code") + , ( "client_id" + , encodeUtf8 clientId + ) -- N.B. The scopes delimeter is unknown/untested. Verify that before -- extracting this to an argument and offering a Scoped function. In -- its current state, it doesn't matter because it's only one scope. - , scopeParam "," defaultScopes - ] + , scopeParam "," defaultScopes + ] , oauthAccessTokenEndpoint = "https://api.nylas.com/oauth/token" , oauthCallback = Nothing } diff --git a/src/Yesod/Auth/OAuth2/Prelude.hs b/src/Yesod/Auth/OAuth2/Prelude.hs --- a/src/Yesod/Auth/OAuth2/Prelude.hs +++ b/src/Yesod/Auth/OAuth2/Prelude.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} -- | @@ -8,10 +6,9 @@ -- implementations. May also be useful for writing local providers. -- module Yesod.Auth.OAuth2.Prelude - ( YesodOAuth2Exception(..) - - -- * Provider helpers - , authGetProfile + ( + -- * Provider helpers + authGetProfile , scopeParam , setExtra @@ -63,7 +60,6 @@ import Data.Aeson import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.Semigroup ((<>)) import Data.Text (Text) import qualified Data.Text as T @@ -74,16 +70,7 @@ import URI.ByteString.Extension import Yesod.Auth import Yesod.Auth.OAuth2 - --- | Provider name and error --- --- The error is a lazy bytestring because it's most often encoded JSON. --- --- Deprecated. Eventually, we'll return @Either@s all the way up. --- -data YesodOAuth2Exception = InvalidProfileResponse Text BL.ByteString - deriving (Show, Typeable) -instance Exception YesodOAuth2Exception +import qualified Yesod.Auth.OAuth2.Exception as YesodOAuth2Exception -- | Retrieve a user's profile as JSON -- @@ -91,27 +78,37 @@ -- @'credsIdent'@. Additional information should either be re-parsed by or -- fetched via additional requests by consumers. -- -authGetProfile :: FromJSON a => Text -> Manager -> OAuth2Token -> URI -> IO (a, BL.ByteString) +authGetProfile + :: FromJSON a + => Text + -> Manager + -> OAuth2Token + -> URI + -> IO (a, BL.ByteString) authGetProfile name manager token url = do resp <- fromAuthGet name =<< authGetBS manager (accessToken token) url decoded <- fromAuthJSON name resp pure (decoded, resp) --- | Throws a @Left@ result as an @'InvalidProfileResponse'@ -fromAuthGet :: Text -> Either (OAuth2Error Value) BL.ByteString -> IO BL.ByteString +-- | Throws a @Left@ result as an @'YesodOAuth2Exception'@ +fromAuthGet + :: Text -> Either (OAuth2Error Value) BL.ByteString -> IO BL.ByteString fromAuthGet _ (Right bs) = pure bs -- nice -fromAuthGet name (Left err) = throwIO $ InvalidProfileResponse name $ encode err +fromAuthGet name (Left err) = + throwIO $ YesodOAuth2Exception.OAuth2Error name $ encode err --- | Throws a decoding error as an @'InvalidProfileResponse'@ +-- | Throws a decoding error as an @'YesodOAuth2Exception'@ fromAuthJSON :: FromJSON a => Text -> BL.ByteString -> IO a fromAuthJSON name = - -- FIXME: unique exception constructors - either (throwIO . InvalidProfileResponse name . BL8.pack) pure . eitherDecode + either (throwIO . YesodOAuth2Exception.JSONDecodingError name) pure + . eitherDecode -- | A tuple of @\"scope\"@ and the given scopes separated by a delimiter scopeParam :: Text -> [Text] -> (ByteString, ByteString) -scopeParam d = ("scope",) . encodeUtf8 . T.intercalate d +scopeParam d = ("scope", ) . encodeUtf8 . T.intercalate d +-- brittany-disable-next-binding + -- | Construct part of @'credsExtra'@ -- -- Always the following keys: @@ -128,4 +125,4 @@ [ ("accessToken", atoken $ accessToken token) , ("userResponse", decodeUtf8 $ BL.toStrict userResponse) ] - <> maybe [] (pure . ("refreshToken",) . rtoken) (refreshToken token) + <> maybe [] (pure . ("refreshToken", ) . rtoken) (refreshToken token) diff --git a/src/Yesod/Auth/OAuth2/Slack.hs b/src/Yesod/Auth/OAuth2/Slack.hs --- a/src/Yesod/Auth/OAuth2/Slack.hs +++ b/src/Yesod/Auth/OAuth2/Slack.hs @@ -15,6 +15,7 @@ import Network.HTTP.Client (httpLbs, parseUrlThrow, responseBody, setQueryString) +import Yesod.Auth.OAuth2.Exception as YesodOAuth2Exception data SlackScope = SlackBasicScope @@ -53,21 +54,20 @@ userResponse <- responseBody <$> httpLbs req manager either - (const $ throwIO $ InvalidProfileResponse pluginName userResponse) - (\(User userId) -> pure Creds - { credsPlugin = pluginName - , credsIdent = userId - , credsExtra = setExtra token userResponse - } - ) + (throwIO . YesodOAuth2Exception.JSONDecodingError pluginName) + (\(User userId) -> pure Creds + { credsPlugin = pluginName + , credsIdent = userId + , credsExtra = setExtra token userResponse + } + ) $ eitherDecode userResponse where oauth2 = OAuth2 { oauthClientId = clientId , oauthClientSecret = clientSecret - , oauthOAuthorizeEndpoint = "https://slack.com/oauth/authorize" `withQuery` - [ scopeParam "," $ map scopeText scopes - ] + , oauthOAuthorizeEndpoint = "https://slack.com/oauth/authorize" + `withQuery` [scopeParam "," $ map scopeText scopes] , oauthAccessTokenEndpoint = "https://slack.com/api/oauth.access" , oauthCallback = Nothing } diff --git a/yesod-auth-oauth2.cabal b/yesod-auth-oauth2.cabal --- a/yesod-auth-oauth2.cabal +++ b/yesod-auth-oauth2.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: d660ecb1d27952349257ee5fad10d3bef5734b4e11646d20bec923fd77b1ae62 +-- hash: 836f5ffe241a2e028ddd2e67244782536c9625183e274372c0c10708f2c13cc4 name: yesod-auth-oauth2 -version: 0.5.1.0 +version: 0.5.2.0 synopsis: OAuth 2.0 authentication plugins description: Library to authenticate with OAuth 2.0 for Yesod web applications. category: Web @@ -55,6 +55,7 @@ Yesod.Auth.OAuth2.Dispatch Yesod.Auth.OAuth2.ErrorResponse Yesod.Auth.OAuth2.EveOnline + Yesod.Auth.OAuth2.Exception Yesod.Auth.OAuth2.GitHub Yesod.Auth.OAuth2.Github Yesod.Auth.OAuth2.GitLab