{-# 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 = 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 = 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. 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 :: String -> String
fieldLabelModifier = Char -> String -> String
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 e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
iss
              , Key
"scope" forall e kv v. (KeyValue e 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 e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall k (i :: k). Idp i -> URI
idpTokenEndpoint Idp 'Google
idp
              , Key
"exp" 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" forall e kv v. (KeyValue e 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 e kv v. (KeyValue e 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"

-- * 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 = 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 = 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
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [GoogleUser] -> String -> String
$cshowList :: [GoogleUser] -> String -> String
show :: GoogleUser -> String
$cshow :: GoogleUser -> String
showsPrec :: Int -> GoogleUser -> String -> String
$cshowsPrec :: Int -> GoogleUser -> String -> String
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