From 2d3d1d2a8e4f406b9f28a8f8148ba90ff44726d0 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Fri, 3 Apr 2015 17:43:56 -0400 Subject: [PATCH] Add fromProfileResponse Handles the common case of fetching profile information from a single JSON endpoint. Throws InvalidProfileResponse if JSON parsing fails. --- Yesod/Auth/OAuth2.hs | 20 ++++++++++++++++++ Yesod/Auth/OAuth2/Github.hs | 2 +- Yesod/Auth/OAuth2/Spotify.hs | 11 +--------- Yesod/Auth/OAuth2/Upcase.hs | 40 +++++++++++++----------------------- 4 files changed, 36 insertions(+), 37 deletions(-) diff --git a/Yesod/Auth/OAuth2.hs b/Yesod/Auth/OAuth2.hs index 63e9800..fe58afa 100644 --- a/Yesod/Auth/OAuth2.hs +++ b/Yesod/Auth/OAuth2.hs @@ -12,6 +12,7 @@ module Yesod.Auth.OAuth2 ( authOAuth2 , oauth2Url + , fromProfileURL , YesodOAuth2Exception(..) , module Network.OAuth.OAuth2 ) where @@ -54,6 +55,9 @@ authOAuth2 :: YesodAuth m -- 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 oauth getCreds = AuthPlugin name dispatch login @@ -104,5 +108,21 @@ authOAuth2 name oauth getCreds = AuthPlugin name dispatch login Login via #{name} |] +-- | Handle the common case of fetching Profile information 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 -> AccessToken -> IO (Creds m) +fromProfileURL name url toCreds manager token = do + result <- authGetJSON manager token url + + case result of + Right profile -> return $ toCreds profile + Left err -> throwIO $ InvalidProfileResponse name err + bsToText :: ByteString -> Text bsToText = decodeUtf8With lenientDecode diff --git a/Yesod/Auth/OAuth2/Github.hs b/Yesod/Auth/OAuth2/Github.hs index 1c41acf..4d48ff3 100644 --- a/Yesod/Auth/OAuth2/Github.hs +++ b/Yesod/Auth/OAuth2/Github.hs @@ -15,7 +15,7 @@ module Yesod.Auth.OAuth2.Github ) where #if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<*>), pure) +import Control.Applicative ((<$>), (<*>)) #endif import Control.Exception.Lifted diff --git a/Yesod/Auth/OAuth2/Spotify.hs b/Yesod/Auth/OAuth2/Spotify.hs index e1acfce..e6dffbe 100644 --- a/Yesod/Auth/OAuth2/Spotify.hs +++ b/Yesod/Auth/OAuth2/Spotify.hs @@ -13,14 +13,12 @@ module Yesod.Auth.OAuth2.Spotify import Control.Applicative ((<$>), (<*>), pure) #endif -import Control.Exception.Lifted import Control.Monad (mzero) import Data.Aeson import Data.ByteString (ByteString) import Data.Maybe import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) -import Network.HTTP.Conduit(Manager) import Yesod.Auth import Yesod.Auth.OAuth2 @@ -78,14 +76,7 @@ oauth2Spotify clientId clientSecret scope = authOAuth2 "spotify" , oauthAccessTokenEndpoint = "https://accounts.spotify.com/api/token" , oauthCallback = Nothing } - fetchSpotifyProfile - -fetchSpotifyProfile :: Manager -> AccessToken -> IO (Creds m) -fetchSpotifyProfile manager token = do - result <- authGetJSON manager token "https://api.spotify.com/v1/me" - case result of - Right user -> return $ toCreds user - Left err -> throwIO $ InvalidProfileResponse "spotify" err + $ fromProfileURL "spotify" "https://api.spotify.com/v1/me" toCreds toCreds :: SpotifyUser -> Creds m toCreds user = Creds diff --git a/Yesod/Auth/OAuth2/Upcase.hs b/Yesod/Auth/OAuth2/Upcase.hs index ef0b823..32ec588 100644 --- a/Yesod/Auth/OAuth2/Upcase.hs +++ b/Yesod/Auth/OAuth2/Upcase.hs @@ -14,17 +14,15 @@ module Yesod.Auth.OAuth2.Upcase ) where #if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<*>), pure) +import Control.Applicative ((<$>), (<*>)) #endif -import Control.Exception.Lifted import Control.Monad (mzero) import Data.Aeson import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Yesod.Auth import Yesod.Auth.OAuth2 -import Network.HTTP.Conduit(Manager) import qualified Data.Text as T data UpcaseUser = UpcaseUser @@ -52,9 +50,9 @@ instance FromJSON UpcaseResponse where parseJSON _ = mzero oauth2Upcase :: YesodAuth m - => Text -- ^ Client ID - -> Text -- ^ Client Secret - -> AuthPlugin m + => Text -- ^ Client ID + -> Text -- ^ Client Secret + -> AuthPlugin m oauth2Upcase clientId clientSecret = authOAuth2 "upcase" OAuth2 { oauthClientId = encodeUtf8 clientId @@ -63,23 +61,13 @@ oauth2Upcase clientId clientSecret = authOAuth2 "upcase" , oauthAccessTokenEndpoint = "http://upcase.com/oauth/token" , oauthCallback = Nothing } - fetchUpcaseProfile - -fetchUpcaseProfile :: Manager -> AccessToken -> IO (Creds m) -fetchUpcaseProfile manager token = do - result <- authGetJSON manager token "http://upcase.com/api/v1/me.json" - - case result of - Right (UpcaseResponse user) -> return $ toCreds user - Left err -> throwIO $ InvalidProfileResponse "upcase" err - -toCreds :: UpcaseUser -> Creds m -toCreds user = Creds - { credsPlugin = "upcase" - , credsIdent = T.pack $ show $ upcaseUserId user - , credsExtra = - [ ("first_name", upcaseUserFirstName user) - , ("last_name" , upcaseUserLastName user) - , ("email" , upcaseUserEmail user) - ] - } + $ fromProfileURL "upcase" "http://upcase.com/api/v1/me.json" + $ \user -> Creds + { credsPlugin = "upcase" + , credsIdent = T.pack $ show $ upcaseUserId user + , credsExtra = + [ ("first_name", upcaseUserFirstName user) + , ("last_name", upcaseUserLastName user) + , ("email", upcaseUserEmail user) + ] + }