.circleci/config.yml

@@ -4,28 +4,36 @@ 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
       - run:
           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

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

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

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

src/Yesod/Auth/OAuth2/Dispatch.hs

@@ -1,15 +1,17 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 module Yesod.Auth.OAuth2.Dispatch
     ( FetchCreds
     , 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,51 +67,63 @@ 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
     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 @@ requireGetParam key = do
 
 tokenSessionKey :: Text -> Text
 tokenSessionKey name = "_yesod_oauth2_" <> name
+
+tshow :: Show a => a -> Text
+tshow = T.pack . show

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

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

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
         }

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,43 +70,44 @@ 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
 --
 -- The response should be parsed only far enough to read the required
 -- @'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)

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
         }