Introduce OAuth2Plugin, extracted from GitHub

- Extract generic OAuth2Plugin construct
- Define GitHub in terms of it
- The scopes argument is now in first position
- access_token is now always added to credsExtra

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
+oauth2GithubScoped scopes = oauth2Plugin OAuth2Plugin
-  where
+    { oapName = "github"
-    oauth = OAuth2
+    , oapAuthEndpoint = "https://github.com/login/oauth/authorize?scope=" <> T.intercalate "," scopes
-        { oauthClientId = encodeUtf8 clientId
+    , oapTokenEndpoint = "https://github.com/login/oauth/access_token"
-        , oauthClientSecret = encodeUtf8 clientSecret
+    , oapFetchProfile = fetchProfile
-        , oauthOAuthorizeEndpoint = encodeUtf8 $ "https://github.com/login/oauth/authorize?scope=" <> T.intercalate "," scopes
+    , oapToCredsIdent = githubProfileIdent
-        , oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token"
+    , oapToCredsExtra = toCredsExtra
-        , oauthCallback = Nothing
     }
 
-fetchGithubProfile :: Manager -> AccessToken -> IO (Creds m)
+  where
-fetchGithubProfile manager token = do
+    fetchProfile manager token = do
-    userResult <- authGetJSON manager token "https://api.github.com/user"
+        user <- authGetJSON manager token "https://api.github.com/user"
-    mailResult <- authGetJSON manager token "https://api.github.com/user/emails"
+        emails <- authGetJSON manager token "https://api.github.com/user/emails"
 
-    case (userResult, mailResult) of
+        return $ case emails of
-        (Right _, Right []) -> throwIO $ InvalidProfileResponse "github" "no mail address for user"
+            Right (email:_) -> GithubProfile <$> user <*> pure (Just email)
-        (Right user, Right mails) -> return $ toCreds user mails token
+            _ -> Left "user has no email"
-        (Left err, _) -> throwIO $ InvalidProfileResponse "github" err
-        (_, Left err) -> throwIO $ InvalidProfileResponse "github" err
 
-toCreds :: GithubUser -> [GithubUserEmail] -> AccessToken -> Creds m
+    toCredsExtra (GithubProfile user email) =
-toCreds user userMail token = Creds
+        [ ("login", githubUserLogin user)
-    { credsPlugin = "github"
-    , credsIdent = T.pack $ show $ githubUserId user
-    , credsExtra =
-        [ ("email", githubUserEmail $ head userMail)
-        , ("login", githubUserLogin user)
         , ("avatar_url", githubUserAvatarUrl user)
-        , ("access_token", decodeUtf8 $ accessToken token)
+        ]
-        ] ++ maybeName (githubUserName user)
+        ++ maybeToTuple "name" (githubUserName user)
-    }
+        ++ maybeToTuple "email" (githubUserEmail <$> email)
 
-  where
+    maybeToTuple _ Nothing = []
-    maybeName Nothing = []
+    maybeToTuple k (Just x) = [(k, x)]
-    maybeName (Just name) = [("name", name)]