{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.Wai.Middleware.Auth.OAuth2.Github
( Github(..)
, mkGithubProvider
, githubParser
) where
import Control.Exception.Safe (catchAny)
import Data.Maybe (fromMaybe)
import Data.Aeson
import qualified Data.ByteString as S
import Data.Proxy (Proxy (..))
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Network.HTTP.Simple (getResponseBody,
httpJSON, parseRequest,
setRequestHeaders)
import Network.HTTP.Types
import qualified Network.OAuth.OAuth2 as OA2
import Network.Wai.Auth.Internal (decodeToken)
import Network.Wai.Auth.Tools (getValidEmail)
import Network.Wai.Middleware.Auth.OAuth2
import Network.Wai.Middleware.Auth.Provider
mkGithubProvider
:: T.Text
-> T.Text
-> T.Text
-> [S.ByteString]
-> Maybe ProviderInfo
-> Github
mkGithubProvider :: Text
-> Text -> Text -> [ByteString] -> Maybe ProviderInfo -> Github
mkGithubProvider Text
appName Text
clientId Text
clientSecret [ByteString]
emailWhiteList Maybe ProviderInfo
mProviderInfo =
Text -> Text -> [ByteString] -> OAuth2 -> Github
Github
Text
appName
Text
"https://api.github.com/user/emails"
[ByteString]
emailWhiteList
OAuth2 :: Text
-> Text -> Text -> Text -> Maybe [Text] -> ProviderInfo -> OAuth2
OAuth2
{ oa2ClientId :: Text
oa2ClientId = Text
clientId
, oa2ClientSecret :: Text
oa2ClientSecret = Text
clientSecret
, oa2AuthorizeEndpoint :: Text
oa2AuthorizeEndpoint = Text
"https://github.com/login/oauth/authorize"
, oa2AccessTokenEndpoint :: Text
oa2AccessTokenEndpoint = Text
"https://github.com/login/oauth/access_token"
, oa2Scope :: Maybe [Text]
oa2Scope = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text
"user:email"]
, oa2ProviderInfo :: ProviderInfo
oa2ProviderInfo = ProviderInfo -> Maybe ProviderInfo -> ProviderInfo
forall a. a -> Maybe a -> a
fromMaybe ProviderInfo
defProviderInfo Maybe ProviderInfo
mProviderInfo
}
where
defProviderInfo :: ProviderInfo
defProviderInfo =
ProviderInfo :: Text -> Text -> Text -> ProviderInfo
ProviderInfo
{ providerTitle :: Text
providerTitle = Text
"GitHub"
, providerLogoUrl :: Text
providerLogoUrl =
Text
"https://assets-cdn.github.com/images/modules/logos_page/Octocat.png"
, providerDescr :: Text
providerDescr = Text
"Use your GitHub account to access this page."
}
githubParser :: ProviderParser
githubParser :: ProviderParser
githubParser = Proxy Github -> ProviderParser
forall ap.
(FromJSON ap, AuthProvider ap) =>
Proxy ap -> ProviderParser
mkProviderParser (Proxy Github
forall k (t :: k). Proxy t
Proxy :: Proxy Github)
data Github = Github
{ Github -> Text
githubAppName :: T.Text
, Github -> Text
githubAPIEmailEndpoint :: T.Text
, Github -> [ByteString]
githubEmailWhitelist :: [S.ByteString]
, Github -> OAuth2
githubOAuth2 :: OAuth2
}
instance FromJSON Github where
parseJSON :: Value -> Parser Github
parseJSON =
String -> (Object -> Parser Github) -> Value -> Parser Github
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Github Provider Object" ((Object -> Parser Github) -> Value -> Parser Github)
-> (Object -> Parser Github) -> Value -> Parser Github
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
Text
appName <- Object
obj Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"app_name"
Text
clientId <- Object
obj Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"client_id"
Text
clientSecret <- Object
obj Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"client_secret"
[Text]
emailWhiteList <- Object
obj Object -> Text -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"email_white_list" Parser (Maybe [Text]) -> [Text] -> Parser [Text]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
Maybe ProviderInfo
mProviderInfo <- Object
obj Object -> Text -> Parser (Maybe ProviderInfo)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"provider_info"
Github -> Parser Github
forall (m :: * -> *) a. Monad m => a -> m a
return (Github -> Parser Github) -> Github -> Parser Github
forall a b. (a -> b) -> a -> b
$
Text
-> Text -> Text -> [ByteString] -> Maybe ProviderInfo -> Github
mkGithubProvider
Text
appName
Text
clientId
Text
clientSecret
((Text -> ByteString) -> [Text] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Text -> ByteString
encodeUtf8 [Text]
emailWhiteList)
Maybe ProviderInfo
mProviderInfo
newtype GithubEmail = GithubEmail { GithubEmail -> ByteString
githubEmail :: S.ByteString } deriving Int -> GithubEmail -> ShowS
[GithubEmail] -> ShowS
GithubEmail -> String
(Int -> GithubEmail -> ShowS)
-> (GithubEmail -> String)
-> ([GithubEmail] -> ShowS)
-> Show GithubEmail
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GithubEmail] -> ShowS
$cshowList :: [GithubEmail] -> ShowS
show :: GithubEmail -> String
$cshow :: GithubEmail -> String
showsPrec :: Int -> GithubEmail -> ShowS
$cshowsPrec :: Int -> GithubEmail -> ShowS
Show
instance FromJSON GithubEmail where
parseJSON :: Value -> Parser GithubEmail
parseJSON = String
-> (Object -> Parser GithubEmail) -> Value -> Parser GithubEmail
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Github Verified Email" ((Object -> Parser GithubEmail) -> Value -> Parser GithubEmail)
-> (Object -> Parser GithubEmail) -> Value -> Parser GithubEmail
forall a b. (a -> b) -> a -> b
$ \ Object
obj -> do
Bool
True <- Object
obj Object -> Text -> Parser Bool
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"verified"
Text
email <- Object
obj Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"email"
GithubEmail -> Parser GithubEmail
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> GithubEmail
GithubEmail (ByteString -> GithubEmail) -> ByteString -> GithubEmail
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
email)
retrieveEmails :: T.Text -> T.Text -> S.ByteString -> IO [GithubEmail]
retrieveEmails :: Text -> Text -> ByteString -> IO [GithubEmail]
retrieveEmails Text
appName Text
emailApiEndpoint ByteString
accessToken = do
Request
req <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (Text -> String
T.unpack Text
emailApiEndpoint)
Response [GithubEmail]
resp <- Request -> IO (Response [GithubEmail])
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON (Request -> IO (Response [GithubEmail]))
-> Request -> IO (Response [GithubEmail])
forall a b. (a -> b) -> a -> b
$ RequestHeaders -> Request -> Request
setRequestHeaders RequestHeaders
headers Request
req
[GithubEmail] -> IO [GithubEmail]
forall (m :: * -> *) a. Monad m => a -> m a
return ([GithubEmail] -> IO [GithubEmail])
-> [GithubEmail] -> IO [GithubEmail]
forall a b. (a -> b) -> a -> b
$ Response [GithubEmail] -> [GithubEmail]
forall a. Response a -> a
getResponseBody Response [GithubEmail]
resp
where
headers :: RequestHeaders
headers =
[ (HeaderName
"Accept", ByteString
"application/vnd.github.v3+json")
, (HeaderName
"Authorization", ByteString
"token " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
accessToken)
, (HeaderName
"User-Agent", Text -> ByteString
encodeUtf8 Text
appName)
]
instance AuthProvider Github where
getProviderName :: Github -> Text
getProviderName Github
_ = Text
"github"
getProviderInfo :: Github -> ProviderInfo
getProviderInfo = OAuth2 -> ProviderInfo
forall ap. AuthProvider ap => ap -> ProviderInfo
getProviderInfo (OAuth2 -> ProviderInfo)
-> (Github -> OAuth2) -> Github -> ProviderInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Github -> OAuth2
githubOAuth2
handleLogin :: Github
-> Request
-> [Text]
-> Render ProviderUrl
-> (ByteString -> IO Response)
-> (Status -> ByteString -> IO Response)
-> IO Response
handleLogin Github {[ByteString]
Text
OAuth2
githubOAuth2 :: OAuth2
githubEmailWhitelist :: [ByteString]
githubAPIEmailEndpoint :: Text
githubAppName :: Text
githubOAuth2 :: Github -> OAuth2
githubEmailWhitelist :: Github -> [ByteString]
githubAPIEmailEndpoint :: Github -> Text
githubAppName :: Github -> Text
..} Request
req [Text]
suffix Render ProviderUrl
renderUrl ByteString -> IO Response
onSuccess Status -> ByteString -> IO Response
onFailure = do
let onOAuth2Success :: ByteString -> IO Response
onOAuth2Success ByteString
oauth2Tokens = do
IO Response -> (SomeException -> IO Response) -> IO Response
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
catchAny
(do ByteString
accessToken <-
case ByteString -> Either String OAuth2Token
decodeToken ByteString
oauth2Tokens of
Left String
err -> String -> IO ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
Right OAuth2Token
tokens -> ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ AccessToken -> Text
OA2.atoken (AccessToken -> Text) -> AccessToken -> Text
forall a b. (a -> b) -> a -> b
$ OAuth2Token -> AccessToken
OA2.accessToken OAuth2Token
tokens
[ByteString]
emails <-
(GithubEmail -> ByteString) -> [GithubEmail] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map GithubEmail -> ByteString
githubEmail ([GithubEmail] -> [ByteString])
-> IO [GithubEmail] -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Text -> Text -> ByteString -> IO [GithubEmail]
retrieveEmails
Text
githubAppName
Text
githubAPIEmailEndpoint
ByteString
accessToken
let mEmail :: Maybe ByteString
mEmail = [ByteString] -> [ByteString] -> Maybe ByteString
getValidEmail [ByteString]
githubEmailWhitelist [ByteString]
emails
case Maybe ByteString
mEmail of
Just ByteString
email -> ByteString -> IO Response
onSuccess ByteString
email
Maybe ByteString
Nothing ->
Status -> ByteString -> IO Response
onFailure Status
status403 (ByteString -> IO Response) -> ByteString -> IO Response
forall a b. (a -> b) -> a -> b
$
ByteString
"No valid email was found with permission to access this resource. " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
ByteString
"Please contact the administrator.")
(\SomeException
_err -> Status -> ByteString -> IO Response
onFailure Status
status501 ByteString
"Issue communicating with github")
OAuth2
-> Request
-> [Text]
-> Render ProviderUrl
-> (ByteString -> IO Response)
-> (Status -> ByteString -> IO Response)
-> IO Response
forall ap.
AuthProvider ap =>
ap
-> Request
-> [Text]
-> Render ProviderUrl
-> (ByteString -> IO Response)
-> (Status -> ByteString -> IO Response)
-> IO Response
handleLogin OAuth2
githubOAuth2 Request
req [Text]
suffix Render ProviderUrl
renderUrl ByteString -> IO Response
onOAuth2Success Status -> ByteString -> IO Response
onFailure