Re-structure modules

- Extract ...OAuth2.Dispatch
- Extract ...OAuth2.Prelude
- Reduce ...OAuth2 interface
- Re-export ...OAuth2 from Prelude

Incidental improvements:

- Moves a lot of FromJSON interfaces to withObject which will provide
  better de-serialization errors
- Updates Dispatch code to prepare for fetch-creds functions returning
  either instead of maybe, so we can eventually remove exceptions
  entirely
- Replaces (the potentially information-leaking) 500 on OAuth2-related
  errors with a 403 and logged error

package.yaml

@@ -24,9 +24,9 @@ library:
     - http-client >=0.4.0 && <0.6
     - http-conduit >=2.0 && <3.0
     - http-types >=0.8 && <0.10
-    - lifted-base >=0.2 && <0.4
     - microlens
     - random
+    - safe-exceptions
     - text >=0.7 && <2.0
     - transformers >=0.2.2 && <0.6
     - uri-bytestring

src/Yesod/Auth/OAuth2.hs

@@ -1,61 +1,29 @@
-{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TupleSections #-}
 -- |
 --
 -- Generic OAuth2 plugin for Yesod
 --
--- * See Yesod.Auth.OAuth2.GitHub for example usage.
+-- See "Yesod.Auth.OAuth2.GitHub" for example usage.
 --
 module Yesod.Auth.OAuth2
-    ( authOAuth2
+    ( OAuth2(..)
-    , authOAuth2Widget
+    , FetchCreds
+    , Manager
+    , OAuth2Token(..)
+    , Creds(..)
     , oauth2Url
-    , fromProfileURL
+    , authOAuth2
-    , YesodOAuth2Exception(..)
+    , authOAuth2Widget
-    , invalidProfileResponse
-    , scopeParam
-    , maybeExtra
-    , module Network.OAuth.OAuth2
-    , module URI.ByteString
-    , module URI.ByteString.Extension
     ) where
 
-import Control.Exception.Lifted
+import Data.Text (Text)
-import Control.Monad (unless)
-import Control.Monad.IO.Class
-import Data.Aeson (Value(..), encode)
-import Data.ByteString (ByteString)
-import Data.Monoid ((<>))
-import Data.Text (Text, pack)
-import Data.Text.Encoding (encodeUtf8)
-import Data.Typeable
 import Network.HTTP.Conduit (Manager)
-import Network.OAuth.OAuth2 hiding (error)
+import Network.OAuth.OAuth2
-import System.Random
-import URI.ByteString
-import URI.ByteString.Extension
 import Yesod.Auth
-import Yesod.Core
+import Yesod.Auth.OAuth2.Dispatch
-
+import Yesod.Core.Widget
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.Text as T
-
--- | Provider name and Aeson parse error
-data YesodOAuth2Exception = InvalidProfileResponse Text BL.ByteString
-    deriving (Show, Typeable)
-
-instance Exception YesodOAuth2Exception
-
--- | Construct an @'InvalidProfileResponse'@ exception from an @'OAuth2Error'@
---
--- This forces the @e@ in @'OAuth2Error' e@ to parse as a JSON @'Value'@ which
--- is then re-encoded for the exception message.
---
-invalidProfileResponse :: Text -> OAuth2Error Value -> YesodOAuth2Exception
-invalidProfileResponse name = InvalidProfileResponse name . encode
 
 oauth2Url :: Text -> AuthRoute
 oauth2Url name = PluginR name ["forward"]
@@ -64,17 +32,7 @@ oauth2Url name = PluginR name ["forward"]
 --
 -- Presents a generic @"Login via name"@ link
 --
-authOAuth2 :: YesodAuth m
+authOAuth2 :: YesodAuth m => Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
-           => Text   -- ^ Service name
-           -> OAuth2 -- ^ Service details
-           -> (Manager -> OAuth2Token -> IO (Creds m))
-           -- ^ This function defines how to take an @'OAuth2Token'@ and
-           --   retrieve additional information about the user, to be set in the
-           --   session as @'Creds'@. Usually this means a second authorized
-           --   request to @api/me.json@.
-           --
-           --   See @'fromProfileURL'@ for an example.
-           -> AuthPlugin m
 authOAuth2 name = authOAuth2Widget [whamlet|Login via #{name}|] name
 
 -- | Create an @'AuthPlugin'@ for the given OAuth2 provider
@@ -82,81 +40,14 @@ authOAuth2 name = authOAuth2Widget [whamlet|Login via #{name}|] name
 -- Allows passing a custom widget for the login link. See @'oauth2Eve'@ for an
 -- example.
 --
-authOAuth2Widget :: YesodAuth m
+authOAuth2Widget
-                 => WidgetT m IO ()
+    :: YesodAuth m
-                 -> Text
+    => WidgetT m IO ()
-                 -> OAuth2
+    -> Text
-                 -> (Manager -> OAuth2Token -> IO (Creds m))
+    -> OAuth2
-                 -> AuthPlugin m
+    -> FetchCreds m
-authOAuth2Widget widget name oauth getCreds = AuthPlugin name dispatch login
+    -> AuthPlugin m
-
+authOAuth2Widget widget name oauth getCreds =
+    AuthPlugin name (dispatchAuthRequest name oauth getCreds) login
   where
-    url = PluginR name ["callback"]
-
-    withCallback csrfToken = do
-        tm <- getRouteToParent
-        render <- lift getUrlRender
-        return oauth
-            { oauthCallback = Just $ unsafeFromText $ render $ tm url
-            , oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth
-                `withQuery` [("state", encodeUtf8 csrfToken)]
-            }
-
-    dispatch "GET" ["forward"] = do
-        csrfToken <- liftIO generateToken
-        setSession tokenSessionKey csrfToken
-        authUrl <- toText . authorizationUrl <$> withCallback csrfToken
-        lift $ redirect authUrl
-
-    dispatch "GET" ["callback"] = do
-        csrfToken <- requireGetParam "state"
-        oldToken <- lookupSession tokenSessionKey
-        deleteSession tokenSessionKey
-        unless (oldToken == Just csrfToken) $ permissionDenied "Invalid OAuth2 state token"
-        code <- requireGetParam "code"
-        oauth' <- withCallback csrfToken
-        master <- lift getYesod
-        result <- liftIO $ fetchAccessToken (authHttpManager master) oauth' (ExchangeToken code)
-        case result of
-            Left _ -> permissionDenied "Unable to retrieve OAuth2 token"
-            Right token -> do
-                creds <- liftIO $ getCreds (authHttpManager master) token
-                lift $ setCredsRedirect creds
-          where
-              requireGetParam key = do
-                  m <- lookupGetParam key
-                  maybe (permissionDenied $ "'" <> key <> "' parameter not provided") return m
-
-    dispatch _ _ = notFound
-
-    generateToken = pack . take 30 . randomRs ('a', 'z') <$> newStdGen
-
-    tokenSessionKey :: Text
-    tokenSessionKey = "_yesod_oauth2_" <> name
-
     login tm = [whamlet|<a href=@{tm $ oauth2Url name}>^{widget}|]
-
--- | Handle the common case of fetching Profile information from a JSON endpoint
---
--- Throws @'InvalidProfileResponse'@ if JSON parsing fails
---
-fromProfileURL :: FromJSON a
-               => Text           -- ^ Plugin name
-               -> URI            -- ^ Profile URI
-               -> (a -> Creds m) -- ^ Conversion to Creds
-               -> Manager -> OAuth2Token -> IO (Creds m)
-fromProfileURL name url toCreds manager token = do
-    result <- authGetJSON manager (accessToken token) url
-
-    case result of
-        Right profile -> return $ toCreds profile
-        Left err -> throwIO $ invalidProfileResponse name err
-
--- | A tuple of @scope@ and the given scopes separated by a delimiter
-scopeParam :: Text -> [Text] -> (ByteString, ByteString)
-scopeParam d = ("scope",) . encodeUtf8 . T.intercalate d
-
--- | A helper for providing an optional value to credsExtra
-maybeExtra :: Text -> Maybe Text -> [(Text, Text)]
-maybeExtra k (Just v) = [(k, v)]
-maybeExtra _ Nothing  = []

src/Yesod/Auth/OAuth2/BattleNet.hs

@@ -12,17 +12,9 @@ module Yesod.Auth.OAuth2.BattleNet
   ( oAuth2BattleNet
   ) where
 
-import Control.Exception (throwIO)
+import Yesod.Auth.OAuth2.Prelude
-import Control.Monad (mzero)
+
-import Data.Aeson
-import Data.Monoid ((<>))
-import Data.Text (Text)
 import qualified Data.Text as T (pack, toLower)
-import qualified Data.Text.Encoding as E (encodeUtf8)
-import Network.HTTP.Conduit (Manager)
-import Prelude
-import Yesod.Auth
-import Yesod.Auth.OAuth2
 import Yesod.Core.Widget
 
 data BattleNetUser = BattleNetUser
@@ -31,10 +23,9 @@ data BattleNetUser = BattleNetUser
     }
 
 instance FromJSON BattleNetUser where
-    parseJSON (Object o) = BattleNetUser
+    parseJSON = withObject "BattleNetUser" $ \o -> BattleNetUser
         <$> o .: "id"
         <*> o .: "battletag"
-    parseJSON _ = mzero
 
 oAuth2BattleNet
     :: YesodAuth m
@@ -73,8 +64,8 @@ makeCredentials region manager token = do
 
 apiHost :: Text -> Host
 apiHost "cn" = "api.battlenet.com.cn"
-apiHost region = Host $ E.encodeUtf8 $ region <> ".api.battle.net"
+apiHost region = Host $ encodeUtf8 $ region <> ".api.battle.net"
 
 wwwHost :: Text -> Host
 wwwHost "cn" = "www.battlenet.com.cn"
-wwwHost region = Host $ E.encodeUtf8 $ region <> ".battle.net"
+wwwHost region = Host $ encodeUtf8 $ region <> ".battle.net"

src/Yesod/Auth/OAuth2/Bitbucket.hs

@@ -10,19 +10,12 @@
 module Yesod.Auth.OAuth2.Bitbucket
     ( oauth2Bitbucket
     , oauth2BitbucketScoped
-    , module Yesod.Auth.OAuth2
     ) where
 
-import Control.Exception.Lifted (throwIO)
+import Yesod.Auth.OAuth2.Prelude
-import Control.Monad (mzero)
+
-import Data.Aeson (FromJSON, Value(Object), parseJSON, (.:), (.:?))
 import Data.List (find)
 import Data.Maybe (fromMaybe)
-import Data.Text (Text)
-import Network.HTTP.Conduit (Manager)
-import Yesod.Auth (AuthPlugin, Creds(..), YesodAuth)
-import Yesod.Auth.OAuth2
-
 import qualified Data.Text as T
 
 data BitbucketUser = BitbucketUser
@@ -34,57 +27,47 @@ data BitbucketUser = BitbucketUser
     }
 
 instance FromJSON BitbucketUser where
-    parseJSON (Object o) = BitbucketUser
+    parseJSON = withObject "BitbucketUser" $ \o -> BitbucketUser
         <$> o .: "uuid"
         <*> o .:? "display_name"
         <*> o .: "username"
         <*> o .:? "location"
         <*> o .: "links"
 
-    parseJSON _ = mzero
-
 newtype BitbucketUserLinks = BitbucketUserLinks
     { bitbucketAvatarLink :: BitbucketLink
     }
 
 instance FromJSON BitbucketUserLinks where
-    parseJSON (Object o) = BitbucketUserLinks
+    parseJSON = withObject "BitbucketUserLinks" $ \o -> BitbucketUserLinks
         <$> o .: "avatar"
 
-    parseJSON _ = mzero
-
 newtype BitbucketLink = BitbucketLink
     { bitbucketLinkHref :: Text
     }
 
 instance FromJSON BitbucketLink where
-    parseJSON (Object o) = BitbucketLink
+    parseJSON = withObject "BitbucketLink" $ \o -> BitbucketLink
         <$> o .: "href"
 
-    parseJSON _ = mzero
-
 newtype BitbucketEmailSearchResults = BitbucketEmailSearchResults
     { bitbucketEmails :: [BitbucketUserEmail]
     }
 
 instance FromJSON BitbucketEmailSearchResults where
-    parseJSON (Object o) = BitbucketEmailSearchResults
+    parseJSON = withObject "BitbucketEmailSearchResults" $ \o -> BitbucketEmailSearchResults
         <$> o .: "values"
 
-    parseJSON _ = mzero
-
 data BitbucketUserEmail = BitbucketUserEmail
     { bitbucketUserEmailAddress :: Text
     , bitbucketUserEmailPrimary :: Bool
     }
 
 instance FromJSON BitbucketUserEmail where
-    parseJSON (Object o) = BitbucketUserEmail
+    parseJSON = withObject "BitbucketUserEmail" $ \o -> BitbucketUserEmail
         <$> o .: "email"
         <*> o .: "is_primary"
 
-    parseJSON _ = mzero
-
 oauth2Bitbucket :: YesodAuth m
              => Text -- ^ Client ID
              -> Text -- ^ Client Secret

src/Yesod/Auth/OAuth2/Dispatch.hs

@@ -0,0 +1,126 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Yesod.Auth.OAuth2.Dispatch
+    ( FetchCreds
+    , dispatchAuthRequest
+    ) where
+
+import Control.Exception.Safe (tryIO)
+import Control.Monad (unless)
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Network.HTTP.Conduit (Manager)
+import Network.OAuth.OAuth2
+import System.Random (newStdGen, randomRs)
+import URI.ByteString.Extension
+import Yesod.Auth
+import Yesod.Core
+
+-- | How to take an @'OAuth2Token'@ and retrieve user credentials
+--
+-- Usually this means a second authorized request to @api/me.json@. See
+-- @'fromProfileURL'@ for an example.
+--
+type FetchCreds m = Manager -> OAuth2Token -> IO (Creds m)
+
+-- | Dispatch the various OAuth2 handshake routes
+dispatchAuthRequest
+    :: Text             -- ^ Name
+    -> OAuth2           -- ^ Service details
+    -> FetchCreds m     -- ^ How to get credentials
+    -> 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 _ _ _ _ _ = notFound
+
+-- | Handle @GET \/forward@
+--
+-- 1. Set a random CSRF token in our session
+-- 2. Redirect to the Provider's authorization URL
+--
+dispatchForward :: Text -> OAuth2 -> AuthHandler m TypedContent
+dispatchForward name oauth2 = do
+    csrf <- setSessionCSRF $ tokenSessionKey name
+    oauth2' <- withCallbackAndState name oauth2 csrf
+    lift $ redirect $ toText $ authorizationUrl oauth2'
+
+-- | Handle @GET \/callback@
+--
+-- 1. Verify the URL's CSRF token matches our session
+-- 2. Use the code parameter to fetch an AccessToken for the Provider
+-- 3. Use the AccessToken to construct a @'Creds'@ value for the Provider
+--
+dispatchCallback :: Text -> OAuth2 -> FetchCreds m -> AuthHandler m TypedContent
+dispatchCallback name oauth2 getCreds = do
+    csrf <- verifySessionCSRF $ tokenSessionKey name
+    code <- requireGetParam "code"
+    manager <- lift $ getsYesod authHttpManager
+    oauth2' <- withCallbackAndState name oauth2 csrf
+    token <- denyLeft $ fetchAccessToken manager oauth2' $ ExchangeToken code
+    creds <- denyLeft $ tryIO $ getCreds manager token
+    lift $ 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 act = do
+        result <- liftIO act
+        either
+            (\err -> do
+                $(logError) $ T.pack $ "OAuth2 error: " <> show err
+                permissionDenied "Invalid OAuth2 authentication attempt"
+            )
+            return
+            result
+
+withCallbackAndState :: Text -> OAuth2 -> Text -> AuthHandler m OAuth2
+withCallbackAndState name oauth2 csrf = do
+    let url = PluginR name ["callback"]
+    render <- getParentUrlRender
+    return oauth2
+        -- FIXME: an invalid AppRoot can blow this up
+        { oauthCallback = Just $ unsafeFromText $ render url
+        , oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth2
+            `withQuery` [("state", encodeUtf8 csrf)]
+        }
+
+getParentUrlRender :: HandlerT child (HandlerT parent IO) (Route child -> Text)
+getParentUrlRender = (.)
+    <$> lift 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
+
+-- | Verify the callback provided the same CSRF token as in our session
+verifySessionCSRF :: MonadHandler m => Text -> m Text
+verifySessionCSRF sessionKey = do
+    token <- requireGetParam "state"
+    sessionToken <- lookupSession sessionKey
+    deleteSession sessionKey
+
+    unless (sessionToken == Just token)
+        $ permissionDenied "Invalid OAuth2 state token"
+
+    return 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"]
+
+tokenSessionKey :: Text -> Text
+tokenSessionKey name = "_yesod_oauth2_" <> name

src/Yesod/Auth/OAuth2/EveOnline.hs

@@ -12,19 +12,12 @@ module Yesod.Auth.OAuth2.EveOnline
     ( oauth2Eve
     , oauth2EveScoped
     , WidgetType(..)
-    , module Yesod.Auth.OAuth2
     ) where
 
-import Control.Exception.Lifted
+import Yesod.Auth.OAuth2.Prelude
-import Control.Monad (mzero)
-import Data.Aeson
-import Data.Text (Text)
-import Network.HTTP.Conduit (Manager)
-import Yesod.Auth
-import Yesod.Auth.OAuth2
-import Yesod.Core.Widget
 
 import qualified Data.Text as T
+import Yesod.Core.Widget
 
 data WidgetType m
     = Plain -- ^ Simple "Login via eveonline" text
@@ -43,15 +36,13 @@ data EveUser = EveUser
     }
 
 instance FromJSON EveUser where
-    parseJSON (Object o) = EveUser
+    parseJSON = withObject "EveUser" $ \o -> EveUser
         <$> o .: "CharacterName"
         <*> o .: "ExpiresOn"
         <*> o .: "TokenType"
         <*> o .: "CharacterOwnerHash"
         <*> o .: "CharacterID"
 
-    parseJSON _ = mzero
-
 oauth2Eve :: YesodAuth m
           => Text -- ^ Client ID
           -> Text -- ^ Client Secret

src/Yesod/Auth/OAuth2/Github.hs

@@ -10,19 +10,12 @@
 module Yesod.Auth.OAuth2.Github
     ( oauth2Github
     , oauth2GithubScoped
-    , module Yesod.Auth.OAuth2
     ) where
 
-import Control.Exception.Lifted
+import Yesod.Auth.OAuth2.Prelude
-import Control.Monad (mzero)
+
-import Data.Aeson
 import Data.List (find)
 import Data.Maybe (fromMaybe)
-import Data.Text (Text)
-import Network.HTTP.Conduit (Manager)
-import Yesod.Auth
-import Yesod.Auth.OAuth2
-
 import qualified Data.Text as T
 
 data GithubUser = GithubUser
@@ -35,7 +28,7 @@ data GithubUser = GithubUser
     }
 
 instance FromJSON GithubUser where
-    parseJSON (Object o) = GithubUser
+    parseJSON = withObject "GithubUser" $ \o -> GithubUser
         <$> o .: "id"
         <*> o .:? "name"
         <*> o .: "login"
@@ -43,20 +36,16 @@ instance FromJSON GithubUser where
         <*> o .:? "location"
         <*> o .:? "email"
 
-    parseJSON _ = mzero
-
 data GithubUserEmail = GithubUserEmail
     { githubUserEmailAddress :: Text
     , githubUserEmailPrimary :: Bool
     }
 
 instance FromJSON GithubUserEmail where
-    parseJSON (Object o) = GithubUserEmail
+    parseJSON = withObject "GithubUserEmail" $ \o -> GithubUserEmail
         <$> o .: "email"
         <*> o .: "primary"
 
-    parseJSON _ = mzero
-
 oauth2Github :: YesodAuth m
              => Text -- ^ Client ID
              -> Text -- ^ Client Secret

src/Yesod/Auth/OAuth2/Google.hs

@@ -17,17 +17,9 @@ module Yesod.Auth.OAuth2.Google
     , oauth2GoogleScopedWithCustomId
     , googleUid
     , emailUid
-    , module Yesod.Auth.OAuth2
     ) where
 
-import Control.Exception.Lifted
+import Yesod.Auth.OAuth2.Prelude
-import Control.Monad (mzero)
-import Data.Aeson
-import Data.Monoid ((<>))
-import Data.Text (Text)
-import Network.HTTP.Conduit (Manager)
-import Yesod.Auth
-import Yesod.Auth.OAuth2
 
 -- | Auth with Google
 --
@@ -97,7 +89,7 @@ data GoogleUser = GoogleUser
     }
 
 instance FromJSON GoogleUser where
-    parseJSON (Object o) = GoogleUser
+    parseJSON = withObject "GoogleUser" $ \o -> GoogleUser
         <$> o .: "sub"
         <*> o .: "name"
         <*> o .: "email"
@@ -106,8 +98,6 @@ instance FromJSON GoogleUser where
         <*> o .: "family_name"
         <*> o .:? "hd"
 
-    parseJSON _ = mzero
-
 -- | Build a @'Creds'@ using the user's google-uid as the identifier
 googleUid :: GoogleUser -> OAuth2Token -> Creds m
 googleUid = uidBuilder $ ("google-uid:" <>) . googleUserId

src/Yesod/Auth/OAuth2/Nylas.hs

@@ -2,20 +2,14 @@
 
 module Yesod.Auth.OAuth2.Nylas
     ( oauth2Nylas
-    , module Yesod.Auth.OAuth2
     ) where
 
-import Control.Exception.Lifted (throwIO)
+import Yesod.Auth.OAuth2.Prelude
-import Control.Monad (mzero)
+
-import Data.Aeson (FromJSON, Value(..), decode, parseJSON, (.:))
+import qualified Data.ByteString.Lazy.Char8 as BSL8
-import Data.Text (Text)
-import Data.Text.Encoding (encodeUtf8)
 import Network.HTTP.Client
     (applyBasicAuth, httpLbs, parseRequest, responseBody, responseStatus)
-import Network.HTTP.Conduit (Manager)
 import qualified Network.HTTP.Types as HT
-import Yesod.Auth (AuthPlugin, Creds(..), YesodAuth)
-import Yesod.Auth.OAuth2
 
 data NylasAccount = NylasAccount
     { nylasAccountId :: Text
@@ -26,13 +20,12 @@ data NylasAccount = NylasAccount
     }
 
 instance FromJSON NylasAccount where
-    parseJSON (Object o) = NylasAccount
+    parseJSON = withObject "NylasAccount" $ \o -> NylasAccount
         <$> o .: "id"
         <*> o .: "email_address"
         <*> o .: "name"
         <*> o .: "provider"
         <*> o .: "organization_unit"
-    parseJSON _ = mzero
 
 oauth2Nylas :: YesodAuth m
             => Text -- ^ Client ID
@@ -57,13 +50,13 @@ fetchCreds manager token = do
     req <- authorize <$> parseRequest "https://api.nylas.com/account"
     resp <- httpLbs req manager
     if HT.statusIsSuccessful (responseStatus resp)
-        then case decode (responseBody resp) of
+        then case eitherDecode (responseBody resp) of
-            Just ns -> return $ toCreds ns token
+            Right ns -> return $ toCreds ns token
-            Nothing -> throwIO parseFailure
+            Left err -> throwIO $ parseFailure err
         else throwIO requestFailure
   where
     authorize = applyBasicAuth (encodeUtf8 $ atoken $ accessToken token) ""
-    parseFailure = InvalidProfileResponse "nylas" "failed to parse account"
+    parseFailure = InvalidProfileResponse "nylas" . BSL8.pack
     requestFailure = InvalidProfileResponse "nylas" "failed to get account"
 
 toCreds :: NylasAccount -> OAuth2Token -> Creds a

src/Yesod/Auth/OAuth2/Prelude.hs

@@ -0,0 +1,111 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+-- |
+--
+-- Modules and support functions required by most or all provider
+-- implementations. May also be useful for writing local providers.
+--
+module Yesod.Auth.OAuth2.Prelude
+    ( YesodOAuth2Exception(..)
+    , invalidProfileResponse
+
+    -- * Helpers
+    , fromProfileURL
+    , scopeParam
+    , maybeExtra
+
+    -- * Text
+    , Text
+    , decodeUtf8
+    , encodeUtf8
+
+    -- * JSON
+    , (.:)
+    , (.:?)
+    , (.=)
+    , (<>)
+    , FromJSON(..)
+    , ToJSON(..)
+    , eitherDecode
+    , withObject
+
+    -- * Exceptions
+    , throwIO
+    , tryIO
+
+    -- * OAuth2
+    , OAuth2(..)
+    , OAuth2Token(..)
+    , AccessToken(..)
+    , RefreshToken(..)
+
+    -- * HTTP
+    , Manager
+    , authGetJSON
+
+    -- * Yesod
+    , YesodAuth(..)
+    , AuthPlugin(..)
+    , Creds(..)
+
+    -- * Bytestring URI types
+    , Host(..)
+
+    -- * Bytestring URI extensions
+    , module URI.ByteString.Extension
+
+    -- * Temporary, until I finish re-structuring modules
+    , authOAuth2
+    , authOAuth2Widget
+    ) where
+
+import Control.Exception.Safe
+import Data.Aeson
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy as BSL
+import Data.Semigroup ((<>))
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding
+import Network.HTTP.Conduit
+import Network.OAuth.OAuth2
+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.
+--
+data YesodOAuth2Exception = InvalidProfileResponse Text BSL.ByteString
+    deriving (Show, Typeable)
+instance Exception YesodOAuth2Exception
+
+-- | Construct an @'InvalidProfileResponse'@ exception from an @'OAuth2Error'@
+--
+-- This forces the @e@ in @'OAuth2Error' e@ to parse as a JSON @'Value'@ which
+-- is then re-encoded for the exception message.
+--
+invalidProfileResponse :: Text -> OAuth2Error Value -> YesodOAuth2Exception
+invalidProfileResponse name = InvalidProfileResponse name . encode
+
+-- | Handle the common case of fetching Profile information from a JSON endpoint
+--
+-- Throws @'InvalidProfileResponse'@ if JSON parsing fails
+--
+fromProfileURL :: FromJSON a => Text -> URI -> (a -> Creds m) -> FetchCreds m
+fromProfileURL name url toCreds manager token = do
+    result <- authGetJSON manager (accessToken token) url
+    either (throwIO . invalidProfileResponse name) (return . toCreds) result
+
+-- | A tuple of @scope@ and the given scopes separated by a delimiter
+scopeParam :: Text -> [Text] -> (ByteString, ByteString)
+scopeParam d = ("scope",) . encodeUtf8 . T.intercalate d
+
+-- | A helper for providing an optional value to credsExtra
+maybeExtra :: Text -> Maybe Text -> [(Text, Text)]
+maybeExtra k (Just v) = [(k, v)]
+maybeExtra _ Nothing  = []

src/Yesod/Auth/OAuth2/Salesforce.hs

@@ -13,17 +13,11 @@ module Yesod.Auth.OAuth2.Salesforce
     , oauth2SalesforceScoped
     , oauth2SalesforceSandbox
     , oauth2SalesforceSandboxScoped
-    , module Yesod.Auth.OAuth2
     ) where
 
-import Control.Exception.Lifted
+import Yesod.Auth.OAuth2.Prelude
-import Control.Monad (mzero)
+
-import Data.Aeson
-import Data.Text (Text)
 import qualified Data.Text as T
-import Network.HTTP.Conduit (Manager)
-import Yesod.Auth
-import Yesod.Auth.OAuth2
 
 oauth2Salesforce :: YesodAuth m
                  => Text -- ^ Client ID
@@ -109,7 +103,7 @@ data User = User
     }
 
 instance FromJSON User where
-    parseJSON (Object o) = do
+    parseJSON = withObject "User" $ \o -> do
         userId          <- o .: "user_id"
         userOrg         <- o .: "organization_id"
         userNickname    <- o .: "nickname"
@@ -124,8 +118,6 @@ instance FromJSON User where
         userRestUrl     <- urls .: "rest"
         return User{..}
 
-    parseJSON _ = mzero
-
 toCreds :: Text -> User -> OAuth2Token -> Creds m
 toCreds name user token = Creds
     { credsPlugin = name

src/Yesod/Auth/OAuth2/Slack.hs

@@ -12,16 +12,9 @@ module Yesod.Auth.OAuth2.Slack
     , oauth2SlackScoped
     ) where
 
-import Data.Aeson
+import Yesod.Auth.OAuth2.Prelude
-import Yesod.Auth
-import Yesod.Auth.OAuth2
 
-import Control.Exception.Lifted (throwIO)
 import Data.Maybe (catMaybes)
-import Data.Text (Text)
-import Data.Text.Encoding (encodeUtf8)
-import Network.HTTP.Conduit (Manager)
-
 import qualified Network.HTTP.Conduit as HTTP
 
 data SlackScope

src/Yesod/Auth/OAuth2/Spotify.hs

@@ -5,17 +5,12 @@
 --
 module Yesod.Auth.OAuth2.Spotify
     ( oauth2Spotify
-    , module Yesod.Auth.OAuth2
     ) where
 
-import Control.Monad (mzero)
+import Yesod.Auth.OAuth2.Prelude
-import Data.Aeson
+
 import Data.Maybe
-import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
-import Yesod.Auth
-import Yesod.Auth.OAuth2
 
 data SpotifyUserImage = SpotifyUserImage
     { spotifyUserImageHeight :: Maybe Int
@@ -24,13 +19,11 @@ data SpotifyUserImage = SpotifyUserImage
     }
 
 instance FromJSON SpotifyUserImage where
-    parseJSON (Object v) = SpotifyUserImage
+    parseJSON = withObject "SpotifyUserImage" $ \v -> SpotifyUserImage
         <$> v .:? "height"
         <*> v .:? "width"
         <*> v .: "url"
 
-    parseJSON _ = mzero
-
 data SpotifyUser = SpotifyUser
     { spotifyUserId :: Text
     , spotifyUserHref :: Text
@@ -43,7 +36,7 @@ data SpotifyUser = SpotifyUser
     }
 
 instance FromJSON SpotifyUser where
-    parseJSON (Object v) = SpotifyUser
+    parseJSON = withObject "SpotifyUser" $ \v -> SpotifyUser
         <$> v .: "id"
         <*> v .: "href"
         <*> v .: "uri"
@@ -53,8 +46,6 @@ instance FromJSON SpotifyUser where
         <*> v .:? "email"
         <*> v .:? "images"
 
-    parseJSON _ = mzero
-
 oauth2Spotify :: YesodAuth m
               => Text -- ^ Client ID
               -> Text -- ^ Client Secret

src/Yesod/Auth/OAuth2/Upcase.hs

@@ -9,15 +9,11 @@
 --
 module Yesod.Auth.OAuth2.Upcase
     ( oauth2Upcase
-    , module Yesod.Auth.OAuth2
     ) where
 
-import Control.Monad (mzero)
+import Yesod.Auth.OAuth2.Prelude
-import Data.Aeson
+
-import Data.Text (Text)
 import qualified Data.Text as T
-import Yesod.Auth
-import Yesod.Auth.OAuth2
 
 data UpcaseUser = UpcaseUser
     { upcaseUserId :: Int
@@ -27,22 +23,18 @@ data UpcaseUser = UpcaseUser
     }
 
 instance FromJSON UpcaseUser where
-    parseJSON (Object o) = UpcaseUser
+    parseJSON = withObject "UpcaseUser" $ \o -> UpcaseUser
         <$> o .: "id"
         <*> o .: "first_name"
         <*> o .: "last_name"
         <*> o .: "email"
 
-    parseJSON _ = mzero
-
 newtype UpcaseResponse = UpcaseResponse UpcaseUser
 
 instance FromJSON UpcaseResponse where
-    parseJSON (Object o) = UpcaseResponse
+    parseJSON = withObject "UpcaseResponse" $ \o -> UpcaseResponse
         <$> o .: "user"
 
-    parseJSON _ = mzero
-
 oauth2Upcase :: YesodAuth m
              => Text -- ^ Client ID
              -> Text -- ^ Client Secret