Merge a63bdcf3b9 into 95afd6f8dd

Yesod/Auth/OAuth2/Github.hs

@@ -10,14 +10,17 @@
 module Yesod.Auth.OAuth2.Github
     ( oauth2Github
     , oauth2GithubScoped
+    , oauth2GithubCheckOrg
+    , oauth2GithubQueried
     , module Yesod.Auth.OAuth2
     ) where
 
 import Control.Applicative ((<$>), (<*>))
 import Control.Exception.Lifted
-import Control.Monad (mzero)
+import Control.Monad (mzero, void)
 import Data.Aeson
 import Data.Text (Text)
+import Data.Map as M
 import Data.Monoid (mappend)
 import Data.Text.Encoding (encodeUtf8, decodeUtf8)
 import Yesod.Auth
@@ -67,7 +70,33 @@ oauth2GithubScoped :: YesodAuth m
              -> Text -- ^ Client Secret
              -> [Text] -- ^ List of scopes to request
              -> AuthPlugin m
-oauth2GithubScoped clientId clientSecret scopes = basicPlugin {apDispatch = dispatch}
+
+oauth2GithubScoped clientId clientSecret scopes =
+    oauth2GithubQueried clientId clientSecret scopes fetchGithubProfile
+
+oauth2GithubCheckOrg :: YesodAuth m
+             => Text -- ^ Client ID
+             -> Text -- ^ Client Secret
+             -> Text -- ^ GitHub Org whose membership the user will be checked against
+             -> AuthPlugin m
+oauth2GithubCheckOrg clientId clientSecret githubOrg =
+    oauth2GithubQueried clientId clientSecret ["user:email", "read:org"]
+                        (fetchGithubProfileCheckOrg githubOrg)
+oauth2GithubQueried :: YesodAuth m
+                          => Text -- ^ Client ID
+                          -> Text -- ^ Client Secret
+                          -> [Text] -- ^ List of scopes to request
+                          -> (Manager -> AccessToken -> IO (Creds m))
+                          -- ^ These functions define how to take an @'AccessToken'@ 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@.
+                          --   It can fail the login by throwing the @'IOException'@
+                          --   @'InvalidProfileResponse'@
+                          -> AuthPlugin m
+
+oauth2GithubQueried clientId clientSecret scopes credsQuery =
+    basicPlugin {apDispatch = dispatch}
     where
         oauth = OAuth2
                 { oauthClientId            = encodeUtf8 clientId
@@ -79,9 +108,9 @@ oauth2GithubScoped clientId clientSecret scopes = basicPlugin {apDispatch = disp
 
         withState state = authOAuth2 "github"
             (oauth {oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth `BS.append` "&state=" `BS.append` encodeUtf8 state})
-            fetchGithubProfile
+            credsQuery  -- this argument is only used to type-check
 
-        basicPlugin = authOAuth2 "github" oauth fetchGithubProfile
+        basicPlugin = authOAuth2 "github" oauth credsQuery
 
         dispatch "GET" ["forward"] = do
             state <- liftIO $ fmap (T.pack . toString) nextRandom
@@ -99,26 +128,77 @@ oauth2GithubScoped clientId clientSecret scopes = basicPlugin {apDispatch = disp
 
         dispatch method ps = apDispatch basicPlugin method ps
 
+-- the queries
+
 fetchGithubProfile :: Manager -> AccessToken -> IO (Creds m)
 fetchGithubProfile manager token = do
-    userResult <- authGetJSON manager token "https://api.github.com/user"
+  (_, creds) <- queryJSONWithToken "user" (uncurry toGithubCreds) manager token
-    mailResult <- authGetJSON manager token "https://api.github.com/user/emails"
+  (_, sessionMap) <- queryJSON "user/emails" toGithubCredsExtraEmail manager token
+  return $ addSessionMap creds [sessionMap]
 
-    case (userResult, mailResult) of
+fetchGithubProfileCheckOrg :: Text -> Manager -> AccessToken -> IO (Creds m)
-        (Right _, Right []) -> throwIO $ InvalidProfileResponse "github" "no mail address for user"
+fetchGithubProfileCheckOrg githubOrg manager token = do
-        (Right user, Right mails) -> return $ toCreds user mails token
+  ((_token, githubUser), creds) <- queryJSONWithToken "user" (uncurry toGithubCreds) manager token
-        (Left err, _) -> throwIO $ InvalidProfileResponse "github" err
+  (_githubUserEmail, sessionMap) <- queryJSON "user/emails" toGithubCredsExtraEmail manager token
-        (_, Left err) -> throwIO $ InvalidProfileResponse "github" err
+  queryWoResult ("orgs/" `mappend` githubOrg `mappend` "/members/"  `mappend` githubUserLogin githubUser) manager token
+  return $ addSessionMap creds [sessionMap]
 
-toCreds :: GithubUser -> [GithubUserEmail] -> AccessToken -> Creds m
+-- Functions From results of query to Creds or Session map
-toCreds user userMail token = Creds "github"
+
-    (T.pack $ show $ githubUserId user)
+toGithubCreds :: AccessToken -> GithubUser -> Creds m
-    cExtra
+toGithubCreds token user = Creds "github"
-    where
+               (T.pack $ show $ githubUserId user) $
-        cExtra = [ ("email", githubUserEmail $ head userMail)
+               [ ("login", githubUserLogin user)
-                 , ("login", githubUserLogin user)
                , ("avatar_url", githubUserAvatarUrl user)
                , ("access_token", decodeUtf8 $ accessToken token)
-                 ] ++ (maybeName $ githubUserName user)
+               ] ++ maybe [] (\name -> [("name", name)]) (githubUserName user)
-        maybeName Nothing     = []
+
-        maybeName (Just name) = [("name", name)]
+toGithubCredsExtraEmail :: [GithubUserEmail] -> M.Map Text Text
+toGithubCredsExtraEmail [] = throw $ InvalidProfileResponse "github" "no mail address for user"
+toGithubCredsExtraEmail (mail:_) = M.singleton "email" $ githubUserEmail mail
+
+-- utilities to create a query
+
+githubApiEndPoint :: Text
+githubApiEndPoint = "https://api.github.com"
+
+queryWoResult :: Text -> Manager -> AccessToken -> IO()
+queryWoResult url manager token = do
+  _ <- query url (const ()) githubAuthGetBS manager token
+  return ()
+
+queryJSON :: FromJSON b => Text -> (b -> c) -> Manager -> AccessToken -> IO (b, c)
+queryJSON url toResult = query url toResult githubAuthGetJson
+
+queryJSONWithToken :: FromJSON b => Text -> ((AccessToken, b) -> c) -> Manager -> AccessToken -> IO ((AccessToken, b), c)
+queryJSONWithToken url toResult manager token =
+    let githubAuthGetJsonWithToken argUrl argManager argToken = do
+          result <- githubAuthGetJson argUrl argManager argToken
+          return $ fmap (\res -> (argToken, res)) result
+    in
+    query url toResult githubAuthGetJsonWithToken manager token
+
+githubAuthGetJson :: FromJSON b => Text -> Manager -> AccessToken -> IO (OAuth2Result b)
+githubAuthGetJson url manager token =
+    authGetJSON manager token (encodeUtf8 url)
+
+githubAuthGetBS :: Text -> Manager -> AccessToken -> IO (OAuth2Result ())
+githubAuthGetBS url manager token = do
+    result <- authGetBS manager token (encodeUtf8 url)
+    return $ void result
+
+query :: FromJSON b
+      => Text
+      -> (b -> c)
+      -> (Text -> Manager -> AccessToken  -> IO (OAuth2Result b))
+      -> Manager -> AccessToken -> IO (b, c)
+query  url toResult fQuery manager token = do
+  jsonResult <- fQuery (githubApiEndPoint `mappend` "/" `mappend` url) manager token
+  either
+    (throwIO . InvalidProfileResponse "github")
+    (\b -> return (b, toResult b))
+    jsonResult
+
+addSessionMap :: Creds m -> [M.Map Text Text] -> Creds m
+addSessionMap creds credsExtraMap =
+    creds { credsExtra = M.toList $ M.unions credsExtraMap }

yesod-auth-oauth2.cabal

@@ -43,6 +43,7 @@ library
                    , hoauth2                 >= 0.4.1     && < 0.5
                    , lifted-base             >= 0.2       && < 0.4
                    , uuid                    >= 1.3       && < 1.4
+                   , containers              >= 0.5.5     && < 0.6
 
     exposed-modules: Yesod.Auth.OAuth2
                      Yesod.Auth.OAuth2.Google