{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
module Network.Wai.Middleware.Auth.OAuth2.Google
    ( Google(..)
    , mkGoogleProvider
    , googleParser
    ) where
import           Control.Exception.Safe               (catchAny)
import           Control.Monad                        (guard)
import           Data.Aeson
import qualified Data.ByteString                      as S
import           Data.Maybe                           (fromMaybe)
import           Data.Proxy                           (Proxy (..))
import qualified Data.Text                            as T
import           Data.Text.Encoding                   (encodeUtf8)
import           Network.HTTP.Simple                  (getResponseBody,
                                                       httpJSON, parseRequestThrow,
                                                       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
import           System.IO                            (hPutStrLn, stderr)


-- | Create a google authentication provider
--
-- @since 0.1.0
mkGoogleProvider
  :: T.Text -- ^ @client_id@ from google
  -> T.Text -- ^ @client_secret@ from google
  -> [S.ByteString] -- ^ White list of posix regular expressions for emails
  -- attached to github account.
  -> Maybe ProviderInfo -- ^ Replacement for default info
  -> Google
mkGoogleProvider :: Text -> Text -> [ByteString] -> Maybe ProviderInfo -> Google
mkGoogleProvider Text
clientId Text
clientSecret [ByteString]
emailWhiteList Maybe ProviderInfo
mProviderInfo =
  Text -> [ByteString] -> OAuth2 -> Google
Google
    Text
"https://www.googleapis.com/oauth2/v3/userinfo"
    [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://accounts.google.com/o/oauth2/v2/auth"
    , oa2AccessTokenEndpoint :: Text
oa2AccessTokenEndpoint = Text
"https://www.googleapis.com/oauth2/v4/token"
    , oa2Scope :: Maybe [Text]
oa2Scope = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text
"https://www.googleapis.com/auth/userinfo.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
"Google"
      , providerLogoUrl :: Text
providerLogoUrl =
          Text
"https://upload.wikimedia.org/wikipedia/commons/thumb/5/53/Google_%22G%22_Logo.svg/200px-Google_%22G%22_Logo.svg.png"
      , providerDescr :: Text
providerDescr = Text
"Use your Google account to access this page."
      }

-- | Aeson parser for `Google` provider.
--
-- @since 0.1.0
googleParser :: ProviderParser
googleParser :: ProviderParser
googleParser = Proxy Google -> ProviderParser
forall ap.
(FromJSON ap, AuthProvider ap) =>
Proxy ap -> ProviderParser
mkProviderParser (Proxy Google
forall k (t :: k). Proxy t
Proxy :: Proxy Google)


data Google = Google
  { Google -> Text
googleAPIEmailEndpoint :: T.Text
  , Google -> [ByteString]
googleEmailWhitelist   :: [S.ByteString]
  , Google -> OAuth2
googleOAuth2           :: OAuth2
  }

instance FromJSON Google where
  parseJSON :: Value -> Parser Google
parseJSON =
    String -> (Object -> Parser Google) -> Value -> Parser Google
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Google Provider Object" ((Object -> Parser Google) -> Value -> Parser Google)
-> (Object -> Parser Google) -> Value -> Parser Google
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
      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"
      Google -> Parser Google
forall (m :: * -> *) a. Monad m => a -> m a
return (Google -> Parser Google) -> Google -> Parser Google
forall a b. (a -> b) -> a -> b
$
        Text -> Text -> [ByteString] -> Maybe ProviderInfo -> Google
mkGoogleProvider
          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 GoogleEmail = GoogleEmail { GoogleEmail -> ByteString
googleEmail :: S.ByteString } deriving Int -> GoogleEmail -> ShowS
[GoogleEmail] -> ShowS
GoogleEmail -> String
(Int -> GoogleEmail -> ShowS)
-> (GoogleEmail -> String)
-> ([GoogleEmail] -> ShowS)
-> Show GoogleEmail
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GoogleEmail] -> ShowS
$cshowList :: [GoogleEmail] -> ShowS
show :: GoogleEmail -> String
$cshow :: GoogleEmail -> String
showsPrec :: Int -> GoogleEmail -> ShowS
$cshowsPrec :: Int -> GoogleEmail -> ShowS
Show

instance FromJSON GoogleEmail where
  parseJSON :: Value -> Parser GoogleEmail
parseJSON = String
-> (Object -> Parser GoogleEmail) -> Value -> Parser GoogleEmail
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Google Verified Email" ((Object -> Parser GoogleEmail) -> Value -> Parser GoogleEmail)
-> (Object -> Parser GoogleEmail) -> Value -> Parser GoogleEmail
forall a b. (a -> b) -> a -> b
$ \ Object
obj -> do
    Bool
verified <- Object
obj Object -> Text -> Parser Bool
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"email_verified"
    Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
verified
    Text
email <- Object
obj Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"email"
    GoogleEmail -> Parser GoogleEmail
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> GoogleEmail
GoogleEmail (ByteString -> GoogleEmail) -> ByteString -> GoogleEmail
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
email)



-- | Makes a call to google API and retrieves user's main email.
retrieveEmail :: T.Text -> S.ByteString -> IO GoogleEmail
retrieveEmail :: Text -> ByteString -> IO GoogleEmail
retrieveEmail Text
emailApiEndpoint ByteString
accessToken = do
  Request
req <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequestThrow (Text -> String
T.unpack Text
emailApiEndpoint)
  Response GoogleEmail
resp <- Request -> IO (Response GoogleEmail)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON (Request -> IO (Response GoogleEmail))
-> Request -> IO (Response GoogleEmail)
forall a b. (a -> b) -> a -> b
$ RequestHeaders -> Request -> Request
setRequestHeaders RequestHeaders
headers Request
req
  GoogleEmail -> IO GoogleEmail
forall (m :: * -> *) a. Monad m => a -> m a
return (GoogleEmail -> IO GoogleEmail) -> GoogleEmail -> IO GoogleEmail
forall a b. (a -> b) -> a -> b
$ Response GoogleEmail -> GoogleEmail
forall a. Response a -> a
getResponseBody Response GoogleEmail
resp
  where
    headers :: RequestHeaders
headers = [(HeaderName
"Authorization", ByteString
"Bearer " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
accessToken)]


instance AuthProvider Google where
  getProviderName :: Google -> Text
getProviderName Google
_ = Text
"google"
  getProviderInfo :: Google -> ProviderInfo
getProviderInfo = OAuth2 -> ProviderInfo
forall ap. AuthProvider ap => ap -> ProviderInfo
getProviderInfo (OAuth2 -> ProviderInfo)
-> (Google -> OAuth2) -> Google -> ProviderInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Google -> OAuth2
googleOAuth2
  handleLogin :: Google
-> Request
-> [Text]
-> Render ProviderUrl
-> (ByteString -> IO Response)
-> (Status -> ByteString -> IO Response)
-> IO Response
handleLogin Google {[ByteString]
Text
OAuth2
googleOAuth2 :: OAuth2
googleEmailWhitelist :: [ByteString]
googleAPIEmailEndpoint :: Text
googleOAuth2 :: Google -> OAuth2
googleEmailWhitelist :: Google -> [ByteString]
googleAPIEmailEndpoint :: Google -> 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
email <-
                  GoogleEmail -> ByteString
googleEmail (GoogleEmail -> ByteString) -> IO GoogleEmail -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                  Text -> ByteString -> IO GoogleEmail
retrieveEmail Text
googleAPIEmailEndpoint ByteString
accessToken
                let mEmail :: Maybe ByteString
mEmail = [ByteString] -> [ByteString] -> Maybe ByteString
getValidEmail [ByteString]
googleEmailWhitelist [ByteString
email]
                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
"No valid email with permission to access was found.") ((SomeException -> IO Response) -> IO Response)
-> (SomeException -> IO Response) -> IO Response
forall a b. (a -> b) -> a -> b
$ \SomeException
err -> do
            Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Issue communicating with Google: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
err
            Status -> ByteString -> IO Response
onFailure Status
status501 ByteString
"Issue communicating with Google."
    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
googleOAuth2 Request
req [Text]
suffix Render ProviderUrl
renderUrl ByteString -> IO Response
onOAuth2Success Status -> ByteString -> IO Response
onFailure