{-# 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 = id
data JWT = JWT
{ clientEmail :: Email
, privateKey :: PrivateKey
} deriving (Eq, Show, Read)
readServiceKeyFile :: FilePath -> IO (Maybe JWT)
readServiceKeyFile fp = do
content <- LBS.readFile fp
runMaybeT $ do
result <- MaybeT . pure . decode $ content
(pkey, clientEmail) <-
MaybeT . pure . flip parseMaybe result $ \obj -> do
pkey <- obj .: "private_key"
clientEmail <- obj .: "client_email"
pure (pkey, clientEmail)
liftIO $ JWT <$> (pure $ Email clientEmail) <*> (fromPEMString pkey)
newtype SignedJWT = SignedJWT
{ unSignedJWT :: ByteString
} deriving (Eq, Show, Read, Ord)
newtype Email = Email
{ unEmail :: Text
} deriving (Eq, Show, Read, Ord)
data Scope
= ScopeCalendarFull
| ScopeCalendarRead
| ScopeGmailFull
| ScopeGmailSend
| ScopeDriveFile
| ScopeDriveMetadataRead
| ScopeSpreadsheets
deriving (Eq, Show, Read, 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 ScopeCalendarFull = "https://www.googleapis.com/auth/calendar"
scopeUrl ScopeCalendarRead = "https://www.googleapis.com/auth/calendar.readonly"
scopeUrl ScopeGmailSend = "https://www.googleapis.com/auth/gmail.send"
scopeUrl ScopeGmailFull = "https://www.googleapis.com/auth/gmail"
scopeUrl ScopeDriveFile = "https://www.googleapis.com/auth/drive.file"
scopeUrl ScopeDriveMetadataRead = "https://www.googleapis.com/auth/drive.metadata.readonly"
scopeUrl ScopeSpreadsheets = "https://www.googleapis.com/auth/spreadsheets"
-- | 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 s =
fromJust . toKeyPair <$> readPrivateKey s PwNone >>= \k ->
return
PrivateKey
{ private_pub =
PublicKey
{public_size = rsaSize k, public_n = rsaN k, public_e = rsaE k}
, private_d = rsaD k
, private_p = rsaP k
, private_q = rsaQ k
, private_dP = 0
, private_dQ = 0
, private_qinv = 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 {..} msub scs mxt = do
let xt = fromIntegral (fromMaybe 3600 mxt)
unless (xt >= 1 && xt <= 3600) (fail "Bad expiration time")
t <- getUnixTime
let i =
mconcat
[ header
, "."
, toB64 $
mconcat
[ "{\"iss\":\"" <> unEmail clientEmail <> "\","
, maybe mempty (\(Email sub) -> "\"sub\":\"" <> sub <> "\",") msub
, "\"scope\":\"" <> T.intercalate " " (map scopeUrl scs) <> "\","
, "\"aud\":\"https://www.googleapis.com/oauth2/v4/token\","
, "\"exp\":" <> toT (utSeconds t + CTime xt) <> ","
, "\"iat\":" <> toT (utSeconds t) <> "}"
]
]
return $
either
(\err -> Left $ "RSAError: " <> show err)
(\s -> return $ SignedJWT $ i <> "." <> encode (toStrict s))
(rsassa_pkcs1_v1_5_sign hashSHA256 privateKey $ fromStrict i)
where
toT = T.pack . show
header = toB64 "{\"alg\":\"RS256\",\"typ\":\"JWT\"}"
toB64 :: Text -> ByteString
toB64 = encode . encodeUtf8