diff --git a/Yesod/Auth/OAuth2/Github.hs b/Yesod/Auth/OAuth2/Github.hs index 13536b6..ddd5979 100644 --- a/Yesod/Auth/OAuth2/Github.hs +++ b/Yesod/Auth/OAuth2/Github.hs @@ -10,15 +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 @@ -72,6 +74,14 @@ oauth2GithubScoped :: YesodAuth m 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 @@ -118,26 +128,77 @@ oauth2GithubQueried clientId clientSecret scopes credsQuery = 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" - mailResult <- authGetJSON manager token "https://api.github.com/user/emails" + (_, creds) <- queryJSONWithToken "user" (uncurry toGithubCreds) manager token + (_, sessionMap) <- queryJSON "user/emails" toGithubCredsExtraEmail manager token + return $ addSessionMap creds [sessionMap] - 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 +fetchGithubProfileCheckOrg :: Text -> Manager -> AccessToken -> IO (Creds m) +fetchGithubProfileCheckOrg githubOrg manager token = do + ((_token, githubUser), creds) <- queryJSONWithToken "user" (uncurry toGithubCreds) manager token + (_githubUserEmail, sessionMap) <- queryJSON "user/emails" toGithubCredsExtraEmail manager token + queryWoResult ("orgs/" `mappend` githubOrg `mappend` "/members/" `mappend` githubUserLogin githubUser) manager token + return $ addSessionMap creds [sessionMap] -toCreds :: GithubUser -> [GithubUserEmail] -> AccessToken -> Creds m -toCreds user userMail token = Creds "github" - (T.pack $ show $ githubUserId user) - cExtra - where - cExtra = [ ("email", githubUserEmail $ head userMail) - , ("login", githubUserLogin user) - , ("avatar_url", githubUserAvatarUrl user) - , ("access_token", decodeUtf8 $ accessToken token) - ] ++ (maybeName $ githubUserName user) - maybeName Nothing = [] - maybeName (Just name) = [("name", name)] +-- Functions From results of query to Creds or Session map + +toGithubCreds :: AccessToken -> GithubUser -> Creds m +toGithubCreds token user = Creds "github" + (T.pack $ show $ githubUserId user) $ + [ ("login", githubUserLogin user) + , ("avatar_url", githubUserAvatarUrl user) + , ("access_token", decodeUtf8 $ accessToken token) + ] ++ maybe [] (\name -> [("name", name)]) (githubUserName user) + +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 } diff --git a/yesod-auth-oauth2.cabal b/yesod-auth-oauth2.cabal index 111257b..7bd1a4a 100644 --- a/yesod-auth-oauth2.cabal +++ b/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