diff --git a/package.yaml b/package.yaml index d0a8056..972bddb 100644 --- a/package.yaml +++ b/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 diff --git a/src/Yesod/Auth/OAuth2.hs b/src/Yesod/Auth/OAuth2.hs index 0785eb4..0c44225 100644 --- a/src/Yesod/Auth/OAuth2.hs +++ b/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 - , authOAuth2Widget + ( OAuth2(..) + , FetchCreds + , Manager + , OAuth2Token(..) + , Creds(..) , oauth2Url - , fromProfileURL - , YesodOAuth2Exception(..) - , invalidProfileResponse - , scopeParam - , maybeExtra - , module Network.OAuth.OAuth2 - , module URI.ByteString - , module URI.ByteString.Extension + , authOAuth2 + , authOAuth2Widget ) where -import Control.Exception.Lifted -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 Data.Text (Text) import Network.HTTP.Conduit (Manager) -import Network.OAuth.OAuth2 hiding (error) -import System.Random -import URI.ByteString -import URI.ByteString.Extension +import Network.OAuth.OAuth2 import Yesod.Auth -import Yesod.Core - -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 +import Yesod.Auth.OAuth2.Dispatch +import Yesod.Core.Widget 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 - => 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 :: YesodAuth m => Text -> OAuth2 -> FetchCreds m -> 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 - => WidgetT m IO () - -> Text - -> OAuth2 - -> (Manager -> OAuth2Token -> IO (Creds m)) - -> AuthPlugin m -authOAuth2Widget widget name oauth getCreds = AuthPlugin name dispatch login - +authOAuth2Widget + :: YesodAuth m + => WidgetT m IO () + -> Text + -> OAuth2 + -> FetchCreds m + -> 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|^{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 = [] diff --git a/src/Yesod/Auth/OAuth2/BattleNet.hs b/src/Yesod/Auth/OAuth2/BattleNet.hs index becea0d..3a1b548 100644 --- a/src/Yesod/Auth/OAuth2/BattleNet.hs +++ b/src/Yesod/Auth/OAuth2/BattleNet.hs @@ -12,17 +12,9 @@ module Yesod.Auth.OAuth2.BattleNet ( oAuth2BattleNet ) where -import Control.Exception (throwIO) -import Control.Monad (mzero) -import Data.Aeson -import Data.Monoid ((<>)) -import Data.Text (Text) +import Yesod.Auth.OAuth2.Prelude + 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" diff --git a/src/Yesod/Auth/OAuth2/Bitbucket.hs b/src/Yesod/Auth/OAuth2/Bitbucket.hs index 0064af8..4900e66 100644 --- a/src/Yesod/Auth/OAuth2/Bitbucket.hs +++ b/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 Control.Monad (mzero) -import Data.Aeson (FromJSON, Value(Object), parseJSON, (.:), (.:?)) +import Yesod.Auth.OAuth2.Prelude + 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 diff --git a/src/Yesod/Auth/OAuth2/Dispatch.hs b/src/Yesod/Auth/OAuth2/Dispatch.hs new file mode 100644 index 0000000..d9b7be5 --- /dev/null +++ b/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 diff --git a/src/Yesod/Auth/OAuth2/EveOnline.hs b/src/Yesod/Auth/OAuth2/EveOnline.hs index 002c430..c4b3449 100644 --- a/src/Yesod/Auth/OAuth2/EveOnline.hs +++ b/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 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 Yesod.Auth.OAuth2.Prelude 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 diff --git a/src/Yesod/Auth/OAuth2/Github.hs b/src/Yesod/Auth/OAuth2/Github.hs index fde58a6..815fb59 100644 --- a/src/Yesod/Auth/OAuth2/Github.hs +++ b/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 Control.Monad (mzero) -import Data.Aeson +import Yesod.Auth.OAuth2.Prelude + 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 diff --git a/src/Yesod/Auth/OAuth2/Google.hs b/src/Yesod/Auth/OAuth2/Google.hs index 906c935..1750483 100644 --- a/src/Yesod/Auth/OAuth2/Google.hs +++ b/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 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 +import Yesod.Auth.OAuth2.Prelude -- | 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 diff --git a/src/Yesod/Auth/OAuth2/Nylas.hs b/src/Yesod/Auth/OAuth2/Nylas.hs index 209b50e..55bd921 100644 --- a/src/Yesod/Auth/OAuth2/Nylas.hs +++ b/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 Control.Monad (mzero) -import Data.Aeson (FromJSON, Value(..), decode, parseJSON, (.:)) -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) +import Yesod.Auth.OAuth2.Prelude + +import qualified Data.ByteString.Lazy.Char8 as BSL8 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 - Just ns -> return $ toCreds ns token - Nothing -> throwIO parseFailure + then case eitherDecode (responseBody resp) of + Right ns -> return $ toCreds ns token + 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 diff --git a/src/Yesod/Auth/OAuth2/Prelude.hs b/src/Yesod/Auth/OAuth2/Prelude.hs new file mode 100644 index 0000000..18bc0fc --- /dev/null +++ b/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 = [] diff --git a/src/Yesod/Auth/OAuth2/Salesforce.hs b/src/Yesod/Auth/OAuth2/Salesforce.hs index ed1107a..ce55678 100644 --- a/src/Yesod/Auth/OAuth2/Salesforce.hs +++ b/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 Control.Monad (mzero) -import Data.Aeson -import Data.Text (Text) +import Yesod.Auth.OAuth2.Prelude + 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 diff --git a/src/Yesod/Auth/OAuth2/Slack.hs b/src/Yesod/Auth/OAuth2/Slack.hs index 1a06edf..886a4c9 100644 --- a/src/Yesod/Auth/OAuth2/Slack.hs +++ b/src/Yesod/Auth/OAuth2/Slack.hs @@ -12,16 +12,9 @@ module Yesod.Auth.OAuth2.Slack , oauth2SlackScoped ) where -import Data.Aeson -import Yesod.Auth -import Yesod.Auth.OAuth2 +import Yesod.Auth.OAuth2.Prelude -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 diff --git a/src/Yesod/Auth/OAuth2/Spotify.hs b/src/Yesod/Auth/OAuth2/Spotify.hs index e72a1b2..8c6bf1e 100644 --- a/src/Yesod/Auth/OAuth2/Spotify.hs +++ b/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 Data.Aeson +import Yesod.Auth.OAuth2.Prelude + 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 diff --git a/src/Yesod/Auth/OAuth2/Upcase.hs b/src/Yesod/Auth/OAuth2/Upcase.hs index 5202b99..fd38e52 100644 --- a/src/Yesod/Auth/OAuth2/Upcase.hs +++ b/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 Data.Aeson -import Data.Text (Text) +import Yesod.Auth.OAuth2.Prelude + 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