{-# 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


-- | Create a github authentication provider
--
-- @since 0.1.0
mkGithubProvider
  :: T.Text -- ^ Name of the application as it is registered on github
  -> T.Text -- ^ @client_id@ from github
  -> T.Text -- ^ @client_secret@ from github
  -> [S.ByteString] -- ^ White list of posix regular expressions for emails
  -- attached to github account.
  -> Maybe ProviderInfo -- ^ Replacement for default info
  -> 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."
      }

-- | Aeson parser for `Github` provider.
--
-- @since 0.1.0
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)


-- | Github authentication provider
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 wrapper for a github verified email
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)


-- | Makes an API call to github and retrieves all user's verified emails.
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