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

@@ -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
         <a href=@{tm $ oauth2Url name}>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

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

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

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)
+            ]
+        }