mirror of
https://github.com/freckle/yesod-auth-oauth2.git
synced 2026-09-10 19:34:56 +02:00
205 lines
8.0 KiB
Haskell
205 lines
8.0 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
-- |
|
|
--
|
|
-- OAuth2 plugin for http://github.com
|
|
--
|
|
-- * Authenticates against github
|
|
-- * Uses github user id as credentials identifier
|
|
-- * Returns first_name, last_name, and email as extras
|
|
--
|
|
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, 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
|
|
import Yesod.Auth.OAuth2
|
|
import Yesod.Core
|
|
import Yesod.Form
|
|
import Network.HTTP.Conduit(Manager)
|
|
import Data.UUID (toString)
|
|
import Data.UUID.V4 (nextRandom)
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.Text as T
|
|
|
|
data GithubUser = GithubUser
|
|
{ githubUserId :: Int
|
|
, githubUserName :: Maybe Text
|
|
, githubUserLogin :: Text
|
|
, githubUserAvatarUrl :: Text
|
|
}
|
|
|
|
instance FromJSON GithubUser where
|
|
parseJSON (Object o) =
|
|
GithubUser <$> o .: "id"
|
|
<*> o .:? "name"
|
|
<*> o .: "login"
|
|
<*> o .: "avatar_url"
|
|
|
|
parseJSON _ = mzero
|
|
|
|
data GithubUserEmail = GithubUserEmail
|
|
{ githubUserEmail :: Text
|
|
}
|
|
|
|
instance FromJSON GithubUserEmail where
|
|
parseJSON (Object o) =
|
|
GithubUserEmail <$> o .: "email"
|
|
|
|
parseJSON _ = mzero
|
|
|
|
oauth2Github :: YesodAuth m
|
|
=> Text -- ^ Client ID
|
|
-> Text -- ^ Client Secret
|
|
-> AuthPlugin m
|
|
oauth2Github clientId clientSecret = oauth2GithubScoped clientId clientSecret ["user:email"]
|
|
|
|
oauth2GithubScoped :: YesodAuth m
|
|
=> Text -- ^ Client ID
|
|
-> Text -- ^ Client Secret
|
|
-> [Text] -- ^ List of scopes to request
|
|
-> AuthPlugin 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
|
|
-> [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
|
|
, oauthClientSecret = encodeUtf8 clientSecret
|
|
, oauthOAuthorizeEndpoint = encodeUtf8 $ "https://github.com/login/oauth/authorize?scope=" `T.append` T.intercalate "," scopes
|
|
, oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token"
|
|
, oauthCallback = Nothing
|
|
}
|
|
|
|
withState state = authOAuth2 "github"
|
|
(oauth {oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth `BS.append` "&state=" `BS.append` encodeUtf8 state})
|
|
credsQuery -- this argument is only used to type-check
|
|
|
|
basicPlugin = authOAuth2 "github" oauth credsQuery
|
|
|
|
dispatch "GET" ["forward"] = do
|
|
state <- liftIO $ fmap (T.pack . toString) nextRandom
|
|
setSession "githubState" state
|
|
apDispatch (withState state) "GET" ["forward"]
|
|
|
|
dispatch "GET" ["callback"] = do
|
|
state <- lift $ runInputGet $ ireq textField "state"
|
|
savedState <- lookupSession "githubState"
|
|
_ <- apDispatch basicPlugin "GET" ["callback"]
|
|
case savedState of
|
|
Just saved | saved == state -> apDispatch basicPlugin "GET" ["callback"]
|
|
Just saved -> invalidArgs ["state: " `mappend` state `mappend` ", and not: " `mappend` saved]
|
|
_ -> invalidArgs ["state: " `mappend` state]
|
|
|
|
dispatch method ps = apDispatch basicPlugin method ps
|
|
|
|
-- the queries
|
|
|
|
fetchGithubProfile :: Manager -> AccessToken -> IO (Creds m)
|
|
fetchGithubProfile manager token = do
|
|
(_, creds) <- queryJSONWithToken "user" (uncurry toGithubCreds) manager token
|
|
(_, sessionMap) <- queryJSON "user/emails" toGithubCredsExtraEmail manager token
|
|
return $ addSessionMap creds [sessionMap]
|
|
|
|
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]
|
|
|
|
-- 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 }
|