module Network.Google.OAuth2.JWT
(
Email
, Scope
, getSignedJWT
, fromPEMString
, fromPEMFile
) where
import Codec.Crypto.RSA.Pure
import qualified Data.ByteString as B
import Data.ByteString.Base64.URL (encode)
import Data.ByteString.Lazy (fromStrict, toStrict)
import Data.Maybe (fromMaybe, fromJust)
import Data.Monoid ((<>))
import qualified Data.Text as T
import Data.Text.Encoding
import Data.UnixTime (getUnixTime, utSeconds)
import Foreign.C.Types
import OpenSSL.EVP.PKey (toKeyPair)
import OpenSSL.PEM (PemPasswordSupply (PwNone),
readPrivateKey)
import OpenSSL.RSA
type Scope = T.Text
type Email = T.Text
fromPEMFile :: FilePath -> IO PrivateKey
fromPEMFile f = readFile f >>= fromPEMString
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 :: Email
-> Maybe Email
-> [Scope]
-> Maybe Int
-> PrivateKey
-> IO (Either String B.ByteString)
getSignedJWT iss msub scs mxt pk = do
let xt = fromIntegral (fromMaybe 3600 mxt)
if xt >= 1 && xt <= 3600
then do
cs <- do
let s = maybe T.empty (\e -> "\"sub\":\"" <> e <> "\",") msub
(t',xt') <- getUnixTime >>=
\t -> return (toText (utSeconds t),toText (utSeconds t + CTime xt))
return $
toJWT $
"{\"iss\":\"" <> iss <> "\"," <> s <> "\"scope\":\"" <>
T.intercalate " " scs <> "\",\"aud\":\"https://www.goo\
\gleapis.com/oauth2/v4/token\",\"exp\":" <> xt' <> ",\"\
\iat\":" <> t' <> "}"
let i = toJWT "{\"alg\":\"RS256\",\"typ\":\"JWT\"}" <> "." <> cs
return $
case rsassa_pkcs1_v1_5_sign hashSHA256 pk (fromStrict i) of
Right s -> Right (i <> "." <> encode (toStrict s))
Left _ -> Left "RSAError"
else fail "Bad expiration time"
where
toText = T.pack . show
toJWT = encode . encodeUtf8