Merge 46f6a9118d into 6d547b157c

Yesod/Auth/OAuth2.hs

@@ -10,8 +10,10 @@
 -- * See Yesod.Auth.OAuth2.GitHub for example usage.
 --
 module Yesod.Auth.OAuth2
-    ( authOAuth2
+    ( OAuth2Plugin(..)
     , oauth2Url
+    , oauth2Plugin
+    , authOAuth2
     , YesodOAuth2Exception(..)
     , module Network.OAuth.OAuth2
     ) where
@@ -43,9 +45,45 @@ data YesodOAuth2Exception = InvalidProfileResponse Text BL.ByteString
 
 instance Exception YesodOAuth2Exception
 
+data OAuth2Plugin a = OAuth2Plugin
+    { oapName :: Text
+    , oapAuthEndpoint :: Text
+    , oapTokenEndpoint :: Text
+    , oapFetchProfile :: Manager -> AccessToken -> IO (Either BL.ByteString a)
+    , oapToCredsIdent :: a -> Text
+    , oapToCredsExtra :: a -> [(Text, Text)]
+    }
+
 oauth2Url :: Text -> AuthRoute
 oauth2Url name = PluginR name ["forward"]
 
+oauth2Plugin :: YesodAuth m
+             => OAuth2Plugin a
+             -> Text -- ^ Client ID
+             -> Text -- ^ Client Secret
+             -> AuthPlugin m
+oauth2Plugin oap clientId clientSecret =
+    authOAuth2 (oapName oap) oapOauth $ \manager token -> do
+        result <- oapFetchProfile oap manager token
+
+        case result of
+            Left err -> throwIO $ InvalidProfileResponse (oapName oap) err
+            Right user -> return Creds
+                { credsIdent = oapToCredsIdent oap user
+                , credsPlugin = oapName oap
+                , credsExtra = oapToCredsExtra oap user
+                }
+
+  where
+    oapOauth :: OAuth2
+    oapOauth = OAuth2
+        { oauthClientId = encodeUtf8 clientId
+        , oauthClientSecret = encodeUtf8 clientSecret
+        , oauthOAuthorizeEndpoint = encodeUtf8 $ oapAuthEndpoint oap
+        , oauthAccessTokenEndpoint = encodeUtf8 $ oapTokenEndpoint oap
+        , oauthCallback = Nothing
+        }
+
 authOAuth2 :: YesodAuth m
            => Text   -- ^ Service name
            -> OAuth2 -- ^ Service details
@@ -89,7 +127,7 @@ authOAuth2 name oauth getCreds = AuthPlugin name dispatch login
                     Left _ -> permissionDenied "Unable to retreive OAuth2 token"
                     Right token -> do
                         creds <- liftIO $ getCreds (authHttpManager master) token
-                        lift $ setCredsRedirect creds
+                        lift $ setCredsRedirect $ addAccessToken token creds
             _ ->
                 permissionDenied "Invalid OAuth2 state token"
 
@@ -104,5 +142,10 @@ authOAuth2 name oauth getCreds = AuthPlugin name dispatch login
         <a href=@{tm $ oauth2Url name}>Login via #{name}
         |]
 
+    addAccessToken token creds = creds
+        { credsExtra =
+            ("access_token", bsToText $ accessToken token) : credsExtra creds
+        }
+
 bsToText :: ByteString -> Text
 bsToText = decodeUtf8With lenientDecode

Yesod/Auth/OAuth2/Github.hs

@@ -18,13 +18,10 @@ module Yesod.Auth.OAuth2.Github
 import Control.Applicative ((<$>), (<*>), pure)
 #endif
 
-import Control.Exception.Lifted
 import Control.Monad (mzero)
 import Data.Aeson
 import Data.Monoid ((<>))
 import Data.Text (Text)
-import Data.Text.Encoding (encodeUtf8, decodeUtf8)
-import Network.HTTP.Conduit (Manager)
 import Yesod.Auth
 import Yesod.Auth.OAuth2
 
@@ -56,50 +53,46 @@ instance FromJSON GithubUserEmail where
 
     parseJSON _ = mzero
 
+data GithubProfile = GithubProfile GithubUser (Maybe GithubUserEmail)
+
+githubProfileIdent :: GithubProfile -> Text
+githubProfileIdent (GithubProfile user _) = T.pack $ show $ githubUserId user
+
 oauth2Github :: YesodAuth m
              => Text -- ^ Client ID
              -> Text -- ^ Client Secret
              -> AuthPlugin m
-oauth2Github clientId clientSecret = oauth2GithubScoped clientId clientSecret ["user:email"]
+oauth2Github = oauth2GithubScoped ["user:email"]
 
 oauth2GithubScoped :: YesodAuth m
-             => Text -- ^ Client ID
+                   => [Text]  -- ^ Scopes to request
+                   -> Text    -- ^ Client ID
                    -> Text    -- ^ Client Secret
-             -> [Text] -- ^ List of scopes to request
                    -> AuthPlugin m
-oauth2GithubScoped clientId clientSecret scopes = authOAuth2 "github" oauth fetchGithubProfile
-  where
-    oauth = OAuth2
-        { oauthClientId = encodeUtf8 clientId
-        , oauthClientSecret = encodeUtf8 clientSecret
-        , oauthOAuthorizeEndpoint = encodeUtf8 $ "https://github.com/login/oauth/authorize?scope=" <> T.intercalate "," scopes
-        , oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token"
-        , oauthCallback = Nothing
+oauth2GithubScoped scopes = oauth2Plugin OAuth2Plugin
+    { oapName = "github"
+    , oapAuthEndpoint = "https://github.com/login/oauth/authorize?scope=" <> T.intercalate "," scopes
+    , oapTokenEndpoint = "https://github.com/login/oauth/access_token"
+    , oapFetchProfile = fetchProfile
+    , oapToCredsIdent = githubProfileIdent
+    , oapToCredsExtra = toCredsExtra
     }
 
-fetchGithubProfile :: Manager -> AccessToken -> IO (Creds m)
-fetchGithubProfile manager token = do
-    userResult <- authGetJSON manager token "https://api.github.com/user"
-    mailResult <- authGetJSON manager token "https://api.github.com/user/emails"
+  where
+    fetchProfile manager token = do
+        user <- authGetJSON manager token "https://api.github.com/user"
+        emails <- authGetJSON manager token "https://api.github.com/user/emails"
 
-    case (userResult, mailResult) of
-        (Right _, Right []) -> throwIO $ InvalidProfileResponse "github" "no mail address for user"
-        (Right user, Right mails) -> return $ toCreds user mails token
-        (Left err, _) -> throwIO $ InvalidProfileResponse "github" err
-        (_, Left err) -> throwIO $ InvalidProfileResponse "github" err
+        return $ case emails of
+            Right (email:_) -> GithubProfile <$> user <*> pure (Just email)
+            _ -> Left "user has no email"
 
-toCreds :: GithubUser -> [GithubUserEmail] -> AccessToken -> Creds m
-toCreds user userMail token = Creds
-    { credsPlugin = "github"
-    , credsIdent = T.pack $ show $ githubUserId user
-    , credsExtra =
-        [ ("email", githubUserEmail $ head userMail)
-        , ("login", githubUserLogin user)
+    toCredsExtra (GithubProfile user email) =
+        [ ("login", githubUserLogin user)
         , ("avatar_url", githubUserAvatarUrl user)
-        , ("access_token", decodeUtf8 $ accessToken token)
-        ] ++ maybeName (githubUserName user)
-    }
+        ]
+        ++ maybeToTuple "name" (githubUserName user)
+        ++ maybeToTuple "email" (githubUserEmail <$> email)
 
-  where
-    maybeName Nothing = []
-    maybeName (Just name) = [("name", name)]
+    maybeToTuple _ Nothing = []
+    maybeToTuple k (Just x) = [(k, x)]

Yesod/Auth/OAuth2/Spotify.hs

@@ -10,21 +10,17 @@ module Yesod.Auth.OAuth2.Spotify
     ) 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.ByteString (ByteString)
 import Data.Maybe
+import Data.Monoid ((<>))
 import Data.Text (Text)
-import Data.Text.Encoding (encodeUtf8)
-import Network.HTTP.Conduit(Manager)
 import Yesod.Auth
 import Yesod.Auth.OAuth2
 
-import qualified Data.ByteString as B
 import qualified Data.Text as T
 
 data SpotifyUserImage = SpotifyUserImage
@@ -66,33 +62,22 @@ instance FromJSON SpotifyUser where
     parseJSON _ = mzero
 
 oauth2Spotify :: YesodAuth m
-              => Text -- ^ Client ID
+              => [Text] -- ^ Scopes
+              -> Text -- ^ Client ID
               -> Text -- ^ Client Secret
-              -> [ByteString] -- ^ Scopes
               -> AuthPlugin m
-oauth2Spotify clientId clientSecret scope = authOAuth2 "spotify"
-    OAuth2
-        { oauthClientId = encodeUtf8 clientId
-        , oauthClientSecret = encodeUtf8 clientSecret
-        , oauthOAuthorizeEndpoint = B.append "https://accounts.spotify.com/authorize?scope=" (B.intercalate "%20" scope)
-        , oauthAccessTokenEndpoint = "https://accounts.spotify.com/api/token"
-        , oauthCallback = Nothing
+oauth2Spotify scopes = oauth2Plugin OAuth2Plugin
+    { oapName = "spotify"
+    , oapAuthEndpoint = "https://accounts.spotify.com/authorize?scope=" <> T.intercalate "%20" scopes
+    , oapTokenEndpoint = "https://accounts.spotify.com/api/token"
+    , oapFetchProfile = \manager token ->
+        authGetJSON manager token "https://api.spotify.com/v1/me"
+    , oapToCredsIdent = spotifyUserId
+    , oapToCredsExtra = toCredsExtra
     }
-    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
-
-toCreds :: SpotifyUser -> Creds m
-toCreds user = Creds
-    { credsPlugin = "spotify"
-    , credsIdent = spotifyUserId user
-    , credsExtra = mapMaybe getExtra extrasTemplate
-    }
+toCredsExtra :: SpotifyUser -> [(Text, Text)]
+toCredsExtra user = mapMaybe getExtra extrasTemplate
 
   where
     userImage :: Maybe SpotifyUserImage

Yesod/Auth/OAuth2/Upcase.hs

@@ -14,17 +14,14 @@ 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
@@ -55,31 +52,19 @@ oauth2Upcase :: YesodAuth m
             => Text -- ^ Client ID
             -> Text -- ^ Client Secret
             -> AuthPlugin m
-oauth2Upcase clientId clientSecret = authOAuth2 "upcase"
-    OAuth2
-        { oauthClientId = encodeUtf8 clientId
-        , oauthClientSecret = encodeUtf8 clientSecret
-        , oauthOAuthorizeEndpoint = "http://upcase.com/oauth/authorize"
-        , oauthAccessTokenEndpoint = "http://upcase.com/oauth/token"
-        , oauthCallback = Nothing
+oauth2Upcase = oauth2Plugin OAuth2Plugin
+    { oapName = "upcase"
+    , oapAuthEndpoint = "http://upcase.com/oauth/authorize"
+    , oapTokenEndpoint = "http://upcase.com/oauth/token"
+    , oapFetchProfile = \manager token ->
+        authGetJSON manager token "http://upcase.com/api/v1/me.json"
+    , oapToCredsIdent = T.pack . show . upcaseUserId
+    , oapToCredsExtra = toCredsExtra
     }
-    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 =
+toCredsExtra :: UpcaseUser -> [(Text, Text)]
+toCredsExtra user =
     [ ("first_name", upcaseUserFirstName user)
     , ("last_name" , upcaseUserLastName user)
     , ("email"     , upcaseUserEmail user)
     ]
-    }