{-# LANGUAGE QuasiQuotes #-}

-- | [Google build oauth2 web server application](https://developers.google.com/identity/protocols/oauth2/web-server)
module Network.OAuth2.Provider.Google where

import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Except (ExceptT (..))
import Crypto.PubKey.RSA.Types
import Data.Aeson
import Data.Aeson qualified as Aeson
import Data.Bifunctor
import Data.ByteString.Contrib
import Data.ByteString.Lazy.Char8 qualified as BSL
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Text.Lazy (Text)
import Data.Text.Lazy qualified as TL
import Data.Time
import GHC.Generics
import Jose.Jwa
import Jose.Jws
import Jose.Jwt
import Network.HTTP.Conduit (Manager)
import Network.OAuth.OAuth2
import Network.OAuth2.Experiment
import Network.OAuth2.Provider
import OpenSSL.EVP.PKey (toKeyPair)
import OpenSSL.PEM (
  PemPasswordSupply (PwNone),
  readPrivateKey,
 )
import OpenSSL.RSA
import URI.ByteString.QQ

{-
To test at google playground, set redirect uri to "https://developers.google.com/oauthplayground"
-}

-- * Authorization Code flow

sampleGoogleAuthorizationCodeApp :: AuthorizationCodeApplication
sampleGoogleAuthorizationCodeApp :: AuthorizationCodeApplication
sampleGoogleAuthorizationCodeApp =
  AuthorizationCodeApplication
    { acName :: Text
acName = Text
"sample-google-authorization-code-app"
    , acClientId :: ClientId
acClientId = ClientId
""
    , acClientSecret :: ClientSecret
acClientSecret = ClientSecret
""
    , acScope :: Set Scope
acScope = [Scope] -> Set Scope
forall a. Ord a => [a] -> Set a
Set.fromList [Scope
"https://www.googleapis.com/auth/userinfo.email", Scope
"https://www.googleapis.com/auth/userinfo.profile"]
    , acAuthorizeState :: AuthorizeState
acAuthorizeState = AuthorizeState
"CHANGE_ME"
    , acRedirectUri :: URI
acRedirectUri = [uri|http://localhost|]
    , acAuthorizeRequestExtraParams :: Map Text Text
acAuthorizeRequestExtraParams = Map Text Text
forall k a. Map k a
Map.empty
    , acTokenRequestAuthenticationMethod :: ClientAuthenticationMethod
acTokenRequestAuthenticationMethod = ClientAuthenticationMethod
ClientSecretBasic
    }

-- * Service Account

sampleServiceAccountApp :: Jwt -> JwtBearerApplication
sampleServiceAccountApp :: Jwt -> JwtBearerApplication
sampleServiceAccountApp Jwt
jwt =
  JwtBearerApplication
    { jbName :: Text
jbName = Text
"sample-google-service-account-app"
    , jbJwtAssertion :: ByteString
jbJwtAssertion = Jwt -> ByteString
unJwt Jwt
jwt
    }

-- | Service account key (in JSON format) that download from google
data GoogleServiceAccountKey = GoogleServiceAccountKey
  { GoogleServiceAccountKey -> String
privateKey :: String
  , GoogleServiceAccountKey -> Text
clientEmail :: Text
  , GoogleServiceAccountKey -> Text
projectId :: Text
  , GoogleServiceAccountKey -> Text
privateKeyId :: Text
  , GoogleServiceAccountKey -> Text
clientId :: Text
  , GoogleServiceAccountKey -> Text
authUri :: Text
  , GoogleServiceAccountKey -> Text
tokenUri :: Text
  , GoogleServiceAccountKey -> Text
authProviderX509CertUrl :: Text
  , GoogleServiceAccountKey -> Text
clientX509CertUrl :: Text
  }
  deriving ((forall x.
 GoogleServiceAccountKey -> Rep GoogleServiceAccountKey x)
-> (forall x.
    Rep GoogleServiceAccountKey x -> GoogleServiceAccountKey)
-> Generic GoogleServiceAccountKey
forall x. Rep GoogleServiceAccountKey x -> GoogleServiceAccountKey
forall x. GoogleServiceAccountKey -> Rep GoogleServiceAccountKey x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GoogleServiceAccountKey -> Rep GoogleServiceAccountKey x
from :: forall x. GoogleServiceAccountKey -> Rep GoogleServiceAccountKey x
$cto :: forall x. Rep GoogleServiceAccountKey x -> GoogleServiceAccountKey
to :: forall x. Rep GoogleServiceAccountKey x -> GoogleServiceAccountKey
Generic)

instance FromJSON GoogleServiceAccountKey where
  parseJSON :: Value -> Parser GoogleServiceAccountKey
parseJSON = Options -> Value -> Parser GoogleServiceAccountKey
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
defaultOptions {fieldLabelModifier = camelTo2 '_'}

-- * Service Account

mkJwt ::
  PrivateKey ->
  -- | Private key
  Text ->
  -- | Issuer
  Maybe Text ->
  -- | impersonate user
  Set.Set Scope ->
  -- | Scope
  Idp Google ->
  IO (Either String Jwt)
mkJwt :: PrivateKey
-> Text
-> Maybe Text
-> Set Scope
-> Idp 'Google
-> IO (Either String Jwt)
mkJwt PrivateKey
privateKey Text
iss Maybe Text
muser Set Scope
scopes Idp 'Google
idp = do
  UTCTime
now <- IO UTCTime
getCurrentTime
  let payload :: ByteString
payload =
        ByteString -> ByteString
bsToStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
          Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$
            [Pair] -> Value
Aeson.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
              [ Key
"iss" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
iss
              , Key
"scope" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> [Text] -> Text
T.intercalate Text
" " ((Scope -> Text) -> [Scope] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
TL.toStrict (Text -> Text) -> (Scope -> Text) -> Scope -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scope -> Text
unScope) ([Scope] -> [Text]) -> [Scope] -> [Text]
forall a b. (a -> b) -> a -> b
$ Set Scope -> [Scope]
forall a. Set a -> [a]
Set.toList Set Scope
scopes)
              , Key
"aud" Key -> URI -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Idp 'Google -> URI
forall k (i :: k). Idp i -> URI
idpTokenEndpoint Idp 'Google
idp
              , Key
"exp" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTCTime -> String
tToSeconds (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (Pico -> NominalDiffTime
secondsToNominalDiffTime Pico
300) UTCTime
now) -- 5 minutes expiration time
              , Key
"iat" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTCTime -> String
tToSeconds UTCTime
now
              ]
                [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair] -> (Text -> [Pair]) -> Maybe Text -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
a -> [Key
"sub" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
a]) Maybe Text
muser
  (JwtError -> String) -> Either JwtError Jwt -> Either String Jwt
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first JwtError -> String
forall a. Show a => a -> String
show (Either JwtError Jwt -> Either String Jwt)
-> IO (Either JwtError Jwt) -> IO (Either String Jwt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JwsAlg -> PrivateKey -> ByteString -> IO (Either JwtError Jwt)
forall (m :: * -> *).
MonadRandom m =>
JwsAlg -> PrivateKey -> ByteString -> m (Either JwtError Jwt)
rsaEncode JwsAlg
RS256 PrivateKey
privateKey ByteString
payload
  where
    tToSeconds :: UTCTime -> String
tToSeconds = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%s"

-- | Read private RSA Key in PEM format
readPemRsaKey ::
  -- | PEM content
  String ->
  IO (Either String PrivateKey)
readPemRsaKey :: String -> IO (Either String PrivateKey)
readPemRsaKey String
pemStr = do
  SomeKeyPair
somePair <- String -> PemPasswordSupply -> IO SomeKeyPair
readPrivateKey String
pemStr PemPasswordSupply
PwNone
  Either String PrivateKey -> IO (Either String PrivateKey)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String PrivateKey -> IO (Either String PrivateKey))
-> Either String PrivateKey -> IO (Either String PrivateKey)
forall a b. (a -> b) -> a -> b
$ case (SomeKeyPair -> Maybe RSAKeyPair
forall a. KeyPair a => SomeKeyPair -> Maybe a
toKeyPair SomeKeyPair
somePair :: Maybe RSAKeyPair) of
    Just RSAKeyPair
k ->
      PrivateKey -> Either String PrivateKey
forall a b. b -> Either a b
Right (PrivateKey -> Either String PrivateKey)
-> PrivateKey -> Either String PrivateKey
forall a b. (a -> b) -> a -> b
$
        PrivateKey
          { private_pub :: PublicKey
private_pub =
              PublicKey
                { public_size :: Int
public_size = RSAKeyPair -> Int
forall k. RSAKey k => k -> Int
rsaSize RSAKeyPair
k
                , public_n :: Integer
public_n = RSAKeyPair -> Integer
forall k. RSAKey k => k -> Integer
rsaN RSAKeyPair
k
                , public_e :: Integer
public_e = RSAKeyPair -> Integer
forall k. RSAKey k => k -> Integer
rsaE RSAKeyPair
k
                }
          , private_d :: Integer
private_d = RSAKeyPair -> Integer
rsaD RSAKeyPair
k
          , private_p :: Integer
private_p = RSAKeyPair -> Integer
rsaP RSAKeyPair
k
          , private_q :: Integer
private_q = RSAKeyPair -> Integer
rsaQ RSAKeyPair
k
          , private_dP :: Integer
private_dP = Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe Integer
0 (RSAKeyPair -> Maybe Integer
rsaDMP1 RSAKeyPair
k)
          , private_dQ :: Integer
private_dQ = Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe Integer
0 (RSAKeyPair -> Maybe Integer
rsaDMQ1 RSAKeyPair
k)
          , private_qinv :: Integer
private_qinv = Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe Integer
0 (RSAKeyPair -> Maybe Integer
rsaIQMP RSAKeyPair
k)
          }
    Maybe RSAKeyPair
Nothing -> String -> Either String PrivateKey
forall a b. a -> Either a b
Left String
"unable to parse PEM to RSA key"

-- * IDP

fetchUserInfo ::
  (MonadIO m, HasUserInfoRequest a, FromJSON b) =>
  IdpApplication i a ->
  Manager ->
  AccessToken ->
  ExceptT BSL.ByteString m b
fetchUserInfo :: forall {k} (m :: * -> *) a b (i :: k).
(MonadIO m, HasUserInfoRequest a, FromJSON b) =>
IdpApplication i a
-> Manager -> AccessToken -> ExceptT ByteString m b
fetchUserInfo = IdpApplication i a
-> Manager -> AccessToken -> ExceptT ByteString m b
forall {k} (m :: * -> *) a b (i :: k).
(MonadIO m, HasUserInfoRequest a, FromJSON b) =>
IdpApplication i a
-> Manager -> AccessToken -> ExceptT ByteString m b
conduitUserInfoRequest

defaultGoogleIdp :: Idp Google
defaultGoogleIdp :: Idp 'Google
defaultGoogleIdp =
  Idp
    { idpAuthorizeEndpoint :: URI
idpAuthorizeEndpoint = [uri|https://accounts.google.com/o/oauth2/v2/auth|]
    , idpTokenEndpoint :: URI
idpTokenEndpoint = [uri|https://oauth2.googleapis.com/token|]
    , idpUserInfoEndpoint :: URI
idpUserInfoEndpoint = [uri|https://www.googleapis.com/oauth2/v2/userinfo|]
    , idpDeviceAuthorizationEndpoint :: Maybe URI
idpDeviceAuthorizationEndpoint = URI -> Maybe URI
forall a. a -> Maybe a
Just [uri|https://oauth2.googleapis.com/device/code|]
    }

-- requires scope "https://www.googleapis.com/auth/userinfo.profile" to obtain "name".
-- requires scopes "https://www.googleapis.com/auth/userinfo.email" to obtain "email".
data GoogleUser = GoogleUser
  { GoogleUser -> Text
name :: Text
  , GoogleUser -> Text
id :: Text
  , GoogleUser -> Text
email :: Text
  }
  deriving (Int -> GoogleUser -> String -> String
[GoogleUser] -> String -> String
GoogleUser -> String
(Int -> GoogleUser -> String -> String)
-> (GoogleUser -> String)
-> ([GoogleUser] -> String -> String)
-> Show GoogleUser
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> GoogleUser -> String -> String
showsPrec :: Int -> GoogleUser -> String -> String
$cshow :: GoogleUser -> String
show :: GoogleUser -> String
$cshowList :: [GoogleUser] -> String -> String
showList :: [GoogleUser] -> String -> String
Show, (forall x. GoogleUser -> Rep GoogleUser x)
-> (forall x. Rep GoogleUser x -> GoogleUser) -> Generic GoogleUser
forall x. Rep GoogleUser x -> GoogleUser
forall x. GoogleUser -> Rep GoogleUser x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GoogleUser -> Rep GoogleUser x
from :: forall x. GoogleUser -> Rep GoogleUser x
$cto :: forall x. Rep GoogleUser x -> GoogleUser
to :: forall x. Rep GoogleUser x -> GoogleUser
Generic)

instance FromJSON GoogleUser