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)
import Data.Monoid ((<>))
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
| ScopeGmailSend
deriving (Eq, Show, Read, Ord)
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"
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
}
getSignedJWT ::
JWT
-> Maybe Email
-> [Scope]
-> Maybe Int
-> IO (Either String SignedJWT)
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
(fail "RSAError")
(\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