{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Network.OAuth2.Provider.Google where

import Crypto.PubKey.RSA.Types
import Data.Aeson
import Data.Aeson qualified as Aeson
import Data.Bifunctor
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.OAuth.OAuth2
import Network.OAuth2.Experiment
import Network.OAuth2.Provider.Utils
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"
-}

data Google = Google deriving (Google -> Google -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Google -> Google -> Bool
$c/= :: Google -> Google -> Bool
== :: Google -> Google -> Bool
$c== :: Google -> Google -> Bool
Eq, Int -> Google -> ShowS
[Google] -> ShowS
Google -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Google] -> ShowS
$cshowList :: [Google] -> ShowS
show :: Google -> String
$cshow :: Google -> String
showsPrec :: Int -> Google -> ShowS
$cshowsPrec :: Int -> Google -> ShowS
Show)

type instance IdpUserInfo Google = GoogleUser

-- * Authorization Code flow

defaultGoogleApp :: IdpApplication 'AuthorizationCode Google
defaultGoogleApp :: IdpApplication 'AuthorizationCode Google
defaultGoogleApp =
  AuthorizationCodeIdpApplication
    { $sel:idpAppClientId:AuthorizationCodeIdpApplication :: ClientId
idpAppClientId = ClientId
""
    , $sel:idpAppClientSecret:AuthorizationCodeIdpApplication :: ClientSecret
idpAppClientSecret = ClientSecret
""
    , $sel:idpAppScope:AuthorizationCodeIdpApplication :: Set Scope
idpAppScope =
        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"
          ]
    , $sel:idpAppAuthorizeState:AuthorizationCodeIdpApplication :: AuthorizeState
idpAppAuthorizeState = AuthorizeState
"CHANGE_ME"
    , $sel:idpAppAuthorizeExtraParams:AuthorizationCodeIdpApplication :: Map Text Text
idpAppAuthorizeExtraParams = forall k a. Map k a
Map.empty
    , $sel:idpAppRedirectUri:AuthorizationCodeIdpApplication :: URI
idpAppRedirectUri = [uri|http://localhost|]
    , $sel:idpAppName:AuthorizationCodeIdpApplication :: Text
idpAppName = Text
"default-google-App"
    , $sel:idpAppTokenRequestAuthenticationMethod:AuthorizationCodeIdpApplication :: ClientAuthenticationMethod
idpAppTokenRequestAuthenticationMethod = ClientAuthenticationMethod
ClientSecretBasic
    , $sel:idp:AuthorizationCodeIdpApplication :: Idp Google
idp = Idp Google
defaultGoogleIdp
    }

-- * Service Account

-- | 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. 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
$cto :: forall x. Rep GoogleServiceAccountKey x -> GoogleServiceAccountKey
$cfrom :: forall x. GoogleServiceAccountKey -> Rep GoogleServiceAccountKey x
Generic)

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

-- * 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 forall a b. (a -> b) -> a -> b
$
          forall a. ToJSON a => a -> ByteString
Aeson.encode forall a b. (a -> b) -> a -> b
$
            [Pair] -> Value
Aeson.object forall a b. (a -> b) -> a -> b
$
              [ Key
"iss" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
iss
              , Key
"scope" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> [Text] -> Text
T.intercalate Text
" " (forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
TL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scope -> Text
unScope) forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set Scope
scopes)
              , Key
"aud" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. Idp a -> URI
idpTokenEndpoint Idp Google
idp
              , Key
"exp" forall kv v. (KeyValue 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UTCTime -> String
tToSeconds UTCTime
now
              ]
                forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
a -> [Key
"sub" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
a]) Maybe Text
muser
  forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadRandom m =>
JwsAlg -> PrivateKey -> ByteString -> m (Either JwtError Jwt)
rsaEncode JwsAlg
RS256 PrivateKey
privateKey ByteString
payload
  where
    tToSeconds :: UTCTime -> String
tToSeconds = 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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case (forall a. KeyPair a => SomeKeyPair -> Maybe a
toKeyPair SomeKeyPair
somePair :: Maybe RSAKeyPair) of
    Just RSAKeyPair
k ->
      forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
        PrivateKey
          { private_pub :: PublicKey
private_pub =
              PublicKey
                { public_size :: Int
public_size = forall k. RSAKey k => k -> Int
rsaSize RSAKeyPair
k
                , public_n :: Integer
public_n = forall k. RSAKey k => k -> Integer
rsaN RSAKeyPair
k
                , public_e :: Integer
public_e = 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 = forall a. a -> Maybe a -> a
fromMaybe Integer
0 (RSAKeyPair -> Maybe Integer
rsaDMP1 RSAKeyPair
k)
          , private_dQ :: Integer
private_dQ = forall a. a -> Maybe a -> a
fromMaybe Integer
0 (RSAKeyPair -> Maybe Integer
rsaDMQ1 RSAKeyPair
k)
          , private_qinv :: Integer
private_qinv = forall a. a -> Maybe a -> a
fromMaybe Integer
0 (RSAKeyPair -> Maybe Integer
rsaIQMP RSAKeyPair
k)
          }
    Maybe RSAKeyPair
Nothing -> forall a b. a -> Either a b
Left String
"unable to parse PEM to RSA key"

defaultServiceAccountApp :: Jwt -> IdpApplication 'JwtBearer Google
defaultServiceAccountApp :: Jwt -> IdpApplication 'JwtBearer Google
defaultServiceAccountApp Jwt
jwt =
  JwtBearerIdpApplication
    { $sel:idpAppName:JwtBearerIdpApplication :: Text
idpAppName = Text
"google-sa-app"
    , $sel:idpAppJwt:JwtBearerIdpApplication :: ByteString
idpAppJwt = Jwt -> ByteString
unJwt Jwt
jwt
    , $sel:idp:JwtBearerIdpApplication :: Idp Google
idp = Idp Google
defaultGoogleIdp
    }

-- * IDP

defaultGoogleIdp :: Idp Google
defaultGoogleIdp :: Idp Google
defaultGoogleIdp =
  Idp
    { $sel:idpFetchUserInfo:Idp :: forall (m :: * -> *).
(FromJSON (IdpUserInfo Google), MonadIO m) =>
Manager
-> AccessToken -> URI -> ExceptT ByteString m (IdpUserInfo Google)
idpFetchUserInfo = forall a (m :: * -> *).
(FromJSON a, MonadIO m) =>
Manager -> AccessToken -> URI -> ExceptT ByteString m a
authGetJSON @(IdpUserInfo Google)
    , $sel:idpAuthorizeEndpoint:Idp :: URI
idpAuthorizeEndpoint = [uri|https://accounts.google.com/o/oauth2/v2/auth|]
    , $sel:idpTokenEndpoint:Idp :: URI
idpTokenEndpoint = [uri|https://oauth2.googleapis.com/token|]
    , $sel:idpUserInfoEndpoint:Idp :: URI
idpUserInfoEndpoint = [uri|https://www.googleapis.com/oauth2/v2/userinfo|]
    }

-- 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 -> ShowS
[GoogleUser] -> ShowS
GoogleUser -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GoogleUser] -> ShowS
$cshowList :: [GoogleUser] -> ShowS
show :: GoogleUser -> String
$cshow :: GoogleUser -> String
showsPrec :: Int -> GoogleUser -> ShowS
$cshowsPrec :: Int -> GoogleUser -> ShowS
Show, 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
$cto :: forall x. Rep GoogleUser x -> GoogleUser
$cfrom :: forall x. GoogleUser -> Rep GoogleUser x
Generic)

instance FromJSON GoogleUser