diff --git a/.circleci/config.yml b/.circleci/config.yml index 205237d..f300544 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -4,20 +4,27 @@ version: 2.0 references: stack_build: &stack_build docker: - - image: fpco/stack-build:lts + # https://github.com/haskell-works/stack-build/blob/master/minimal/Dockerfile + - image: quay.io/haskell_works/stack-build-minimal steps: - checkout + - run: + name: Upgrade Stack + command: stack upgrade - run: name: Digest command: | - echo -- "$STACK_ARGUMENTS" > rdigest + { + stack --version + echo -- "$STACK_YAML/$STACK_ARGUMENTS" + } > rdigest git ls-files | xargs md5sum > sdigest - restore_cache: keys: - - 1-{{ .Branch }}-{{ checksum "rdigest" }}-{{ checksum "sdigest" }} - - 1-{{ .Branch }}-{{ checksum "rdigest" }}- - - 1-{{ .Branch }}- - - 1-master- + - v2-{{ .Branch }}-{{ checksum "rdigest" }}-{{ checksum "sdigest" }} + - v2-{{ .Branch }}-{{ checksum "rdigest" }}- + - v2-{{ .Branch }}- + - v2-master- - run: name: Dependencies command: make setup @@ -25,7 +32,8 @@ references: name: Build command: make build - save_cache: - key: 1-{{ .Branch }}-{{ checksum "rdigest" }}-{{ checksum "sdigest" }} + # yamllint disable-line rule:line-length + key: v2-{{ .Branch }}-{{ checksum "rdigest" }}-{{ checksum "sdigest" }} paths: - ~/.stack - ./.stack-work @@ -34,25 +42,32 @@ references: command: make test - run: name: Lint - command: make lint + command: | + if [ "${LINT:-1}" = 1 ]; then + make lint + fi jobs: build_8.2.2: <<: *stack_build environment: - # Set this one via ENV var so that weeder respects it too. See - # https://github.com/ndmitchell/weeder/issues/41. + STACK_ARGUMENTS: --no-terminal STACK_YAML: stack-lts-11.18.yaml build_8.4.3: <<: *stack_build environment: - STACK_ARGUMENTS: --stack-yaml stack-lts-12.2.yaml + STACK_ARGUMENTS: --no-terminal + STACK_YAML: stack-lts-12.2.yaml build: <<: *stack_build build_nightly: <<: *stack_build environment: - STACK_ARGUMENTS: --resolver nightly --stack-yaml stack-nightly.yaml + # weeder is not happy, again + # https://circleci.com/gh/thoughtbot/yesod-auth-oauth2/375 + LINT: 0 + STACK_ARGUMENTS: --resolver nightly --no-terminal + STACK_YAML: stack-nightly.yaml workflows: version: 2 diff --git a/CHANGELOG.md b/CHANGELOG.md index 6ab9092..8ab61a4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,16 @@ -## [*Unreleased*](https://github.com/thoughtbot/yesod-auth-oauth2/compare/v0.5.1.0...master) +## [*Unreleased*](https://github.com/thoughtbot/yesod-auth-oauth2/compare/v0.5.2.0...master) None +## [v0.5.2.0](https://github.com/thoughtbot/yesod-auth-oauth2/compare/v0.5.1.0...v0.5.2.0) + +- `InvalidProfileResponse` was replaced with different, situation-specific + constructors; the exception type is considered internal API, but end-users may + see them in logs, or if they (unexpectedly) escape our error-handling +- Errors during log-in no longer result in 4XX or 5XX responses; they now + redirect to `LoginR` with the exception details logged and something + user-appropriate displayed via `setMessage` + ## [v0.5.1.0](https://github.com/thoughtbot/yesod-auth-oauth2/compare/v0.5.0.0...v0.5.1.0) - Added GitLab provider diff --git a/Makefile b/Makefile index d2e08f6..0d44d82 100644 --- a/Makefile +++ b/Makefile @@ -3,6 +3,8 @@ all: setup build test lint .PHONY: setup setup: stack setup $(STACK_ARGUMENTS) + # Avoid ExitFailure (-9) (THIS MAY INDICATE OUT OF MEMORY) + stack build $(STACK_ARGUMENTS) -j 1 haskell-src-exts stack build $(STACK_ARGUMENTS) \ --flag yesod-auth-oauth2:example \ --dependencies-only --test --no-run-tests diff --git a/package.yaml b/package.yaml index 593ec4a..1a3a06b 100644 --- a/package.yaml +++ b/package.yaml @@ -1,6 +1,6 @@ --- name: yesod-auth-oauth2 -version: '0.5.1.0' # N.B. PVP-compliant Semver: 0.MAJOR.MINOR.PATCH +version: '0.5.2.0' # N.B. PVP-compliant Semver: 0.MAJOR.MINOR.PATCH synopsis: OAuth 2.0 authentication plugins description: Library to authenticate with OAuth 2.0 for Yesod web applications. category: Web diff --git a/src/Yesod/Auth/OAuth2/Dispatch.hs b/src/Yesod/Auth/OAuth2/Dispatch.hs index 8f0b372..4e5ccab 100644 --- 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 @@ module Yesod.Auth.OAuth2.Dispatch , 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.HTTP.Conduit (Manager) 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 @@ dispatchAuthRequest -> 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,18 +67,29 @@ dispatchCallback name oauth2 getCreds = do 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 @@ -81,32 +97,33 @@ withCallbackAndState name oauth2 csrf = do 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 @@ requireGetParam key = do 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 index de1770a..85561bd 100644 --- 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_) @@ -32,6 +34,25 @@ data ErrorResponse = ErrorResponse } 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 -- -- The action is expected to use a short-circuit response function like diff --git a/src/Yesod/Auth/OAuth2/Exception.hs b/src/Yesod/Auth/OAuth2/Exception.hs new file mode 100644 index 0000000..ac9da44 --- /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 index 63f4be2..25c93a4 100644 --- a/src/Yesod/Auth/OAuth2/Nylas.hs +++ b/src/Yesod/Auth/OAuth2/Nylas.hs @@ -10,6 +10,7 @@ import Control.Monad (unless) 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 @@ oauth2Nylas clientId clientSecret = -- 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 index 0dcb178..c7e52c9 100644 --- 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 Control.Exception.Safe 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 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,26 +78,36 @@ instance Exception YesodOAuth2Exception -- @'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'@ -- @@ -128,4 +125,4 @@ setExtra token userResponse = [ ("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 index af18a70..fc7e8bb 100644 --- a/src/Yesod/Auth/OAuth2/Slack.hs +++ b/src/Yesod/Auth/OAuth2/Slack.hs @@ -15,6 +15,7 @@ import Yesod.Auth.OAuth2.Prelude import Network.HTTP.Client (httpLbs, parseUrlThrow, responseBody, setQueryString) +import Yesod.Auth.OAuth2.Exception as YesodOAuth2Exception data SlackScope = SlackBasicScope @@ -53,21 +54,20 @@ oauth2SlackScoped scopes clientId clientSecret = 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 }