{-# LANGUAGE CPP #-}
-- | Create a signed JWT needed to make the access token request
-- to gain access to Google APIs for server to server applications.
--
-- For all usage details, see https://developers.google.com/identity/protocols/OAuth2ServiceAccount
--
-- This module is borrowed from google-oauth2-jwt package.
module Google.JWT
  ( JWT
  , HasJWT(..)
  , readServiceKeyFile
  , SignedJWT(..)
  , Email(..)
  , Scope(..)
  , getSignedJWT
  ) where

import Codec.Crypto.RSA.Pure
  ( PrivateKey(..)
  , PublicKey(..)
  , hashSHA256
  , rsassa_pkcs1_v1_5_sign
  )
import Control.Monad (unless)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Data.Aeson ((.:), decode)
import Data.Aeson.Types (parseMaybe)
import Data.ByteString (ByteString)
import Data.ByteString.Base64.URL (encode)
import qualified Data.ByteString.Lazy as LBS
import Data.ByteString.Lazy (fromStrict, toStrict)
import Data.Maybe (fromJust, fromMaybe)
#if !MIN_VERSION_base(4, 11, 0)
import Data.Monoid ((<>))
#endif
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.UnixTime (getUnixTime, utSeconds)
import Foreign.C.Types (CTime(..))
import OpenSSL.EVP.PKey (toKeyPair)
import OpenSSL.PEM (PemPasswordSupply(PwNone), readPrivateKey)
import OpenSSL.RSA (rsaD, rsaE, rsaN, rsaP, rsaQ, rsaSize)

class HasJWT a where
  getJwt :: a -> JWT

instance HasJWT JWT where
  getJwt :: JWT -> JWT
  getJwt :: JWT -> JWT
getJwt = JWT -> JWT
forall a. a -> a
id

data JWT = JWT
  { JWT -> Email
clientEmail :: Email
  , JWT -> PrivateKey
privateKey :: PrivateKey
  } deriving (JWT -> JWT -> Bool
(JWT -> JWT -> Bool) -> (JWT -> JWT -> Bool) -> Eq JWT
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JWT -> JWT -> Bool
$c/= :: JWT -> JWT -> Bool
== :: JWT -> JWT -> Bool
$c== :: JWT -> JWT -> Bool
Eq, Int -> JWT -> ShowS
[JWT] -> ShowS
JWT -> String
(Int -> JWT -> ShowS)
-> (JWT -> String) -> ([JWT] -> ShowS) -> Show JWT
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JWT] -> ShowS
$cshowList :: [JWT] -> ShowS
show :: JWT -> String
$cshow :: JWT -> String
showsPrec :: Int -> JWT -> ShowS
$cshowsPrec :: Int -> JWT -> ShowS
Show, ReadPrec [JWT]
ReadPrec JWT
Int -> ReadS JWT
ReadS [JWT]
(Int -> ReadS JWT)
-> ReadS [JWT] -> ReadPrec JWT -> ReadPrec [JWT] -> Read JWT
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [JWT]
$creadListPrec :: ReadPrec [JWT]
readPrec :: ReadPrec JWT
$creadPrec :: ReadPrec JWT
readList :: ReadS [JWT]
$creadList :: ReadS [JWT]
readsPrec :: Int -> ReadS JWT
$creadsPrec :: Int -> ReadS JWT
Read)

readServiceKeyFile :: FilePath -> IO (Maybe JWT)
readServiceKeyFile :: String -> IO (Maybe JWT)
readServiceKeyFile String
fp = do
  ByteString
content <- String -> IO ByteString
LBS.readFile String
fp
  MaybeT IO JWT -> IO (Maybe JWT)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO JWT -> IO (Maybe JWT))
-> MaybeT IO JWT -> IO (Maybe JWT)
forall a b. (a -> b) -> a -> b
$ do
    Object
result <- IO (Maybe Object) -> MaybeT IO Object
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe Object) -> MaybeT IO Object)
-> (ByteString -> IO (Maybe Object))
-> ByteString
-> MaybeT IO Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Object -> IO (Maybe Object)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Object -> IO (Maybe Object))
-> (ByteString -> Maybe Object) -> ByteString -> IO (Maybe Object)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe Object
forall a. FromJSON a => ByteString -> Maybe a
decode (ByteString -> MaybeT IO Object) -> ByteString -> MaybeT IO Object
forall a b. (a -> b) -> a -> b
$ ByteString
content
    (String
pkey, Text
clientEmail) <-
      IO (Maybe (String, Text)) -> MaybeT IO (String, Text)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe (String, Text)) -> MaybeT IO (String, Text))
-> ((Object -> Parser (String, Text)) -> IO (Maybe (String, Text)))
-> (Object -> Parser (String, Text))
-> MaybeT IO (String, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (String, Text) -> IO (Maybe (String, Text))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (String, Text) -> IO (Maybe (String, Text)))
-> ((Object -> Parser (String, Text)) -> Maybe (String, Text))
-> (Object -> Parser (String, Text))
-> IO (Maybe (String, Text))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Object -> Parser (String, Text))
 -> Object -> Maybe (String, Text))
-> Object
-> (Object -> Parser (String, Text))
-> Maybe (String, Text)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Object -> Parser (String, Text)) -> Object -> Maybe (String, Text)
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Object
result ((Object -> Parser (String, Text)) -> MaybeT IO (String, Text))
-> (Object -> Parser (String, Text)) -> MaybeT IO (String, Text)
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
        String
pkey <- Object
obj Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"private_key"
        Text
clientEmail <- Object
obj Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"client_email"
        (String, Text) -> Parser (String, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
pkey, Text
clientEmail)
    IO JWT -> MaybeT IO JWT
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO JWT -> MaybeT IO JWT) -> IO JWT -> MaybeT IO JWT
forall a b. (a -> b) -> a -> b
$ Email -> PrivateKey -> JWT
JWT (Email -> PrivateKey -> JWT) -> IO Email -> IO (PrivateKey -> JWT)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Email -> IO Email
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Email -> IO Email) -> Email -> IO Email
forall a b. (a -> b) -> a -> b
$ Text -> Email
Email Text
clientEmail) IO (PrivateKey -> JWT) -> IO PrivateKey -> IO JWT
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> IO PrivateKey
fromPEMString String
pkey)

newtype SignedJWT = SignedJWT
  { SignedJWT -> ByteString
unSignedJWT :: ByteString
  } deriving (SignedJWT -> SignedJWT -> Bool
(SignedJWT -> SignedJWT -> Bool)
-> (SignedJWT -> SignedJWT -> Bool) -> Eq SignedJWT
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SignedJWT -> SignedJWT -> Bool
$c/= :: SignedJWT -> SignedJWT -> Bool
== :: SignedJWT -> SignedJWT -> Bool
$c== :: SignedJWT -> SignedJWT -> Bool
Eq, Int -> SignedJWT -> ShowS
[SignedJWT] -> ShowS
SignedJWT -> String
(Int -> SignedJWT -> ShowS)
-> (SignedJWT -> String)
-> ([SignedJWT] -> ShowS)
-> Show SignedJWT
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SignedJWT] -> ShowS
$cshowList :: [SignedJWT] -> ShowS
show :: SignedJWT -> String
$cshow :: SignedJWT -> String
showsPrec :: Int -> SignedJWT -> ShowS
$cshowsPrec :: Int -> SignedJWT -> ShowS
Show, ReadPrec [SignedJWT]
ReadPrec SignedJWT
Int -> ReadS SignedJWT
ReadS [SignedJWT]
(Int -> ReadS SignedJWT)
-> ReadS [SignedJWT]
-> ReadPrec SignedJWT
-> ReadPrec [SignedJWT]
-> Read SignedJWT
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SignedJWT]
$creadListPrec :: ReadPrec [SignedJWT]
readPrec :: ReadPrec SignedJWT
$creadPrec :: ReadPrec SignedJWT
readList :: ReadS [SignedJWT]
$creadList :: ReadS [SignedJWT]
readsPrec :: Int -> ReadS SignedJWT
$creadsPrec :: Int -> ReadS SignedJWT
Read, Eq SignedJWT
Eq SignedJWT
-> (SignedJWT -> SignedJWT -> Ordering)
-> (SignedJWT -> SignedJWT -> Bool)
-> (SignedJWT -> SignedJWT -> Bool)
-> (SignedJWT -> SignedJWT -> Bool)
-> (SignedJWT -> SignedJWT -> Bool)
-> (SignedJWT -> SignedJWT -> SignedJWT)
-> (SignedJWT -> SignedJWT -> SignedJWT)
-> Ord SignedJWT
SignedJWT -> SignedJWT -> Bool
SignedJWT -> SignedJWT -> Ordering
SignedJWT -> SignedJWT -> SignedJWT
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SignedJWT -> SignedJWT -> SignedJWT
$cmin :: SignedJWT -> SignedJWT -> SignedJWT
max :: SignedJWT -> SignedJWT -> SignedJWT
$cmax :: SignedJWT -> SignedJWT -> SignedJWT
>= :: SignedJWT -> SignedJWT -> Bool
$c>= :: SignedJWT -> SignedJWT -> Bool
> :: SignedJWT -> SignedJWT -> Bool
$c> :: SignedJWT -> SignedJWT -> Bool
<= :: SignedJWT -> SignedJWT -> Bool
$c<= :: SignedJWT -> SignedJWT -> Bool
< :: SignedJWT -> SignedJWT -> Bool
$c< :: SignedJWT -> SignedJWT -> Bool
compare :: SignedJWT -> SignedJWT -> Ordering
$ccompare :: SignedJWT -> SignedJWT -> Ordering
$cp1Ord :: Eq SignedJWT
Ord)

newtype Email = Email
  { Email -> Text
unEmail :: Text
  } deriving (Email -> Email -> Bool
(Email -> Email -> Bool) -> (Email -> Email -> Bool) -> Eq Email
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Email -> Email -> Bool
$c/= :: Email -> Email -> Bool
== :: Email -> Email -> Bool
$c== :: Email -> Email -> Bool
Eq, Int -> Email -> ShowS
[Email] -> ShowS
Email -> String
(Int -> Email -> ShowS)
-> (Email -> String) -> ([Email] -> ShowS) -> Show Email
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Email] -> ShowS
$cshowList :: [Email] -> ShowS
show :: Email -> String
$cshow :: Email -> String
showsPrec :: Int -> Email -> ShowS
$cshowsPrec :: Int -> Email -> ShowS
Show, ReadPrec [Email]
ReadPrec Email
Int -> ReadS Email
ReadS [Email]
(Int -> ReadS Email)
-> ReadS [Email]
-> ReadPrec Email
-> ReadPrec [Email]
-> Read Email
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Email]
$creadListPrec :: ReadPrec [Email]
readPrec :: ReadPrec Email
$creadPrec :: ReadPrec Email
readList :: ReadS [Email]
$creadList :: ReadS [Email]
readsPrec :: Int -> ReadS Email
$creadsPrec :: Int -> ReadS Email
Read, Eq Email
Eq Email
-> (Email -> Email -> Ordering)
-> (Email -> Email -> Bool)
-> (Email -> Email -> Bool)
-> (Email -> Email -> Bool)
-> (Email -> Email -> Bool)
-> (Email -> Email -> Email)
-> (Email -> Email -> Email)
-> Ord Email
Email -> Email -> Bool
Email -> Email -> Ordering
Email -> Email -> Email
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Email -> Email -> Email
$cmin :: Email -> Email -> Email
max :: Email -> Email -> Email
$cmax :: Email -> Email -> Email
>= :: Email -> Email -> Bool
$c>= :: Email -> Email -> Bool
> :: Email -> Email -> Bool
$c> :: Email -> Email -> Bool
<= :: Email -> Email -> Bool
$c<= :: Email -> Email -> Bool
< :: Email -> Email -> Bool
$c< :: Email -> Email -> Bool
compare :: Email -> Email -> Ordering
$ccompare :: Email -> Email -> Ordering
$cp1Ord :: Eq Email
Ord)

data Scope
  = ScopeCalendarFull
  | ScopeCalendarRead
  | ScopeGmailFull
  | ScopeGmailSend
  | ScopeDriveFile
  | ScopeDriveMetadataRead
  deriving (Scope -> Scope -> Bool
(Scope -> Scope -> Bool) -> (Scope -> Scope -> Bool) -> Eq Scope
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Scope -> Scope -> Bool
$c/= :: Scope -> Scope -> Bool
== :: Scope -> Scope -> Bool
$c== :: Scope -> Scope -> Bool
Eq, Int -> Scope -> ShowS
[Scope] -> ShowS
Scope -> String
(Int -> Scope -> ShowS)
-> (Scope -> String) -> ([Scope] -> ShowS) -> Show Scope
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Scope] -> ShowS
$cshowList :: [Scope] -> ShowS
show :: Scope -> String
$cshow :: Scope -> String
showsPrec :: Int -> Scope -> ShowS
$cshowsPrec :: Int -> Scope -> ShowS
Show, ReadPrec [Scope]
ReadPrec Scope
Int -> ReadS Scope
ReadS [Scope]
(Int -> ReadS Scope)
-> ReadS [Scope]
-> ReadPrec Scope
-> ReadPrec [Scope]
-> Read Scope
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Scope]
$creadListPrec :: ReadPrec [Scope]
readPrec :: ReadPrec Scope
$creadPrec :: ReadPrec Scope
readList :: ReadS [Scope]
$creadList :: ReadS [Scope]
readsPrec :: Int -> ReadS Scope
$creadsPrec :: Int -> ReadS Scope
Read, Eq Scope
Eq Scope
-> (Scope -> Scope -> Ordering)
-> (Scope -> Scope -> Bool)
-> (Scope -> Scope -> Bool)
-> (Scope -> Scope -> Bool)
-> (Scope -> Scope -> Bool)
-> (Scope -> Scope -> Scope)
-> (Scope -> Scope -> Scope)
-> Ord Scope
Scope -> Scope -> Bool
Scope -> Scope -> Ordering
Scope -> Scope -> Scope
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Scope -> Scope -> Scope
$cmin :: Scope -> Scope -> Scope
max :: Scope -> Scope -> Scope
$cmax :: Scope -> Scope -> Scope
>= :: Scope -> Scope -> Bool
$c>= :: Scope -> Scope -> Bool
> :: Scope -> Scope -> Bool
$c> :: Scope -> Scope -> Bool
<= :: Scope -> Scope -> Bool
$c<= :: Scope -> Scope -> Bool
< :: Scope -> Scope -> Bool
$c< :: Scope -> Scope -> Bool
compare :: Scope -> Scope -> Ordering
$ccompare :: Scope -> Scope -> Ordering
$cp1Ord :: Eq Scope
Ord)

{-| Make sure if you added new scope, update configuration in page bellow.
  https://admin.google.com/uzuz.jp/AdminHome?chromeless=1#OGX:ManageOauthClients
-}
scopeUrl :: Scope -> Text
scopeUrl :: Scope -> Text
scopeUrl Scope
ScopeCalendarFull = Text
"https://www.googleapis.com/auth/calendar"
scopeUrl Scope
ScopeCalendarRead = Text
"https://www.googleapis.com/auth/calendar.readonly"
scopeUrl Scope
ScopeGmailSend = Text
"https://www.googleapis.com/auth/gmail.send"
scopeUrl Scope
ScopeGmailFull = Text
"https://www.googleapis.com/auth/gmail"
scopeUrl Scope
ScopeDriveFile = Text
"https://www.googleapis.com/auth/drive.file"
scopeUrl Scope
ScopeDriveMetadataRead = Text
"https://www.googleapis.com/auth/drive.metadata.readonly"

-- | Get the private key obtained from the
-- Google API Console from a PEM 'String'.
--
-- >fromPEMString "-----BEGIN PRIVATE KEY-----\nB9e [...] bMdF\n-----END PRIVATE KEY-----\n"
-- >
fromPEMString :: String -> IO PrivateKey
fromPEMString :: String -> IO PrivateKey
fromPEMString String
s =
  Maybe RSAKeyPair -> RSAKeyPair
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe RSAKeyPair -> RSAKeyPair)
-> (SomeKeyPair -> Maybe RSAKeyPair) -> SomeKeyPair -> RSAKeyPair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeKeyPair -> Maybe RSAKeyPair
forall a. KeyPair a => SomeKeyPair -> Maybe a
toKeyPair (SomeKeyPair -> RSAKeyPair) -> IO SomeKeyPair -> IO RSAKeyPair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> PemPasswordSupply -> IO SomeKeyPair
readPrivateKey String
s PemPasswordSupply
PwNone IO RSAKeyPair -> (RSAKeyPair -> IO PrivateKey) -> IO PrivateKey
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \RSAKeyPair
k ->
    PrivateKey -> IO PrivateKey
forall (m :: * -> *) a. Monad m => a -> m a
return
      PrivateKey :: PublicKey
-> Integer
-> Integer
-> Integer
-> Integer
-> Integer
-> Integer
-> PrivateKey
PrivateKey
        { private_pub :: PublicKey
private_pub =
            PublicKey :: Int -> Integer -> Integer -> PublicKey
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
0
        , private_dQ :: Integer
private_dQ = Integer
0
        , private_qinv :: Integer
private_qinv = Integer
0
        }

-- | Create the signed JWT ready for transmission
-- in the access token request as assertion value.
--
-- >grant_type=urn%3Aietf%3Aparams%3Aoauth%3Agrant-type%3Ajwt-bearer&assertion=
--
getSignedJWT ::
     JWT
  -> Maybe Email
  -- ^ The email address of the user for which the
  -- application is requesting delegated access.
  -> [Scope]
  -- ^ The list of the permissions that the application requests.
  -> Maybe Int
  -- ^ Expiration time (maximum and default value is an hour, 3600).
  -> IO (Either String SignedJWT) -- ^ Either an error message or a signed JWT.
getSignedJWT :: JWT
-> Maybe Email
-> [Scope]
-> Maybe Int
-> IO (Either String SignedJWT)
getSignedJWT JWT {PrivateKey
Email
privateKey :: PrivateKey
clientEmail :: Email
$sel:privateKey:JWT :: JWT -> PrivateKey
$sel:clientEmail:JWT :: JWT -> Email
..} Maybe Email
msub [Scope]
scs Maybe Int
mxt = do
  let xt :: Int64
xt = Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
3600 Maybe Int
mxt)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int64
xt Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
1 Bool -> Bool -> Bool
&& Int64
xt Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
3600) (String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Bad expiration time")
  UnixTime
t <- IO UnixTime
getUnixTime
  let i :: ByteString
i =
        [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
          [ ByteString
header
          , ByteString
"."
          , Text -> ByteString
toB64 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$
            [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
              [ Text
"{\"iss\":\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Email -> Text
unEmail Email
clientEmail Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\","
              , Text -> (Email -> Text) -> Maybe Email -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
forall a. Monoid a => a
mempty (\(Email Text
sub) -> Text
"\"sub\":\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sub Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\",") Maybe Email
msub
              , Text
"\"scope\":\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
" " ((Scope -> Text) -> [Scope] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Scope -> Text
scopeUrl [Scope]
scs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\","
              , Text
"\"aud\":\"https://www.googleapis.com/oauth2/v4/token\","
              , Text
"\"exp\":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CTime -> Text
toT (UnixTime -> CTime
utSeconds UnixTime
t CTime -> CTime -> CTime
forall a. Num a => a -> a -> a
+ Int64 -> CTime
CTime Int64
xt) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
","
              , Text
"\"iat\":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CTime -> Text
toT (UnixTime -> CTime
utSeconds UnixTime
t) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"
              ]
          ]
  Either String SignedJWT -> IO (Either String SignedJWT)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String SignedJWT -> IO (Either String SignedJWT))
-> Either String SignedJWT -> IO (Either String SignedJWT)
forall a b. (a -> b) -> a -> b
$
    (RSAError -> Either String SignedJWT)
-> (ByteString -> Either String SignedJWT)
-> Either RSAError ByteString
-> Either String SignedJWT
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
      (\RSAError
err -> String -> Either String SignedJWT
forall a b. a -> Either a b
Left (String -> Either String SignedJWT)
-> String -> Either String SignedJWT
forall a b. (a -> b) -> a -> b
$ String
"RSAError: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> RSAError -> String
forall a. Show a => a -> String
show RSAError
err)
      (\ByteString
s -> SignedJWT -> Either String SignedJWT
forall (m :: * -> *) a. Monad m => a -> m a
return (SignedJWT -> Either String SignedJWT)
-> SignedJWT -> Either String SignedJWT
forall a b. (a -> b) -> a -> b
$ ByteString -> SignedJWT
SignedJWT (ByteString -> SignedJWT) -> ByteString -> SignedJWT
forall a b. (a -> b) -> a -> b
$ ByteString
i ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"." ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
encode (ByteString -> ByteString
toStrict ByteString
s))
      (HashInfo -> PrivateKey -> ByteString -> Either RSAError ByteString
rsassa_pkcs1_v1_5_sign HashInfo
hashSHA256 PrivateKey
privateKey (ByteString -> Either RSAError ByteString)
-> ByteString -> Either RSAError ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
fromStrict ByteString
i)
  where
    toT :: CTime -> Text
toT = String -> Text
T.pack (String -> Text) -> (CTime -> String) -> CTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CTime -> String
forall a. Show a => a -> String
show
    header :: ByteString
header = Text -> ByteString
toB64 Text
"{\"alg\":\"RS256\",\"typ\":\"JWT\"}"

toB64 :: Text -> ByteString
toB64 :: Text -> ByteString
toB64 = ByteString -> ByteString
encode (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8