web-push-0.1.2.0: src/Web/WebPush/Internal.hs
{-# LANGUAGE RecordWildCards, OverloadedStrings #-}
module Web.WebPush.Internal where
import GHC.Int (Int64)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LB
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.HashMap.Strict as HM
import qualified Crypto.PubKey.ECC.Types as ECC
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import Crypto.Hash.Algorithms (SHA256(..))
import qualified Crypto.PubKey.ECC.DH as ECDH
import qualified Crypto.MAC.HMAC as HMAC
import Crypto.Cipher.AES (AES128)
import qualified Crypto.Cipher.Types as Cipher
import Crypto.Error (CryptoFailable(CryptoPassed,CryptoFailed), CryptoError)
import Crypto.JWT (createJWSJWT, ClaimsSet(..))
import qualified Crypto.JWT as JWT
import qualified Crypto.JOSE.JWK as JWK
import Crypto.JOSE.JWS (JWSHeader(..), Alg(ES256))
import qualified Crypto.JOSE.Header as JOSE.Header
import qualified Crypto.JOSE.Types as JOSE
import qualified Crypto.JOSE.Compact as JOSE.Compact
import qualified Crypto.JOSE.Error as JOSE.Error
import Data.Aeson (ToJSON, toJSON, (.=))
import qualified Data.Aeson as A
import qualified Data.ByteString.Base64.URL as B64.URL
import Data.Word (Word8, Word16, Word64)
import qualified Data.Binary as Binary
import qualified Data.Bits as Bits
import qualified Data.ByteArray as ByteArray
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Except (runExceptT)
type VAPIDKeys = ECDSA.KeyPair
data VAPIDClaims = VAPIDClaims { vapidAud :: JWT.Audience
, vapidSub :: JWT.StringOrURI
, vapidExp :: JWT.NumericDate
}
-- JSON Web Token for VAPID
webPushJWT :: MonadIO m => VAPIDKeys -> VAPIDClaims -> m (Either (JOSE.Error.Error) LB.ByteString)
webPushJWT vapidKeys vapidClaims = do
let ECC.Point publicKeyX publicKeyY = ECDSA.public_q $ ECDSA.toPublicKey vapidKeys
privateKeyNumber = ECDSA.private_d $ ECDSA.toPrivateKey vapidKeys
liftIO $ runExceptT $ do
jwtData <- createJWSJWT ( JWK.fromKeyMaterial $ JWK.ECKeyMaterial $
JWK.ECKeyParameters { JWK.ecKty = JWK.EC
, JWK.ecCrv = JWK.P_256
, JWK.ecX = JOSE.SizedBase64Integer 32 $ publicKeyX
, JWK.ecY = JOSE.SizedBase64Integer 32 $ publicKeyY
, JWK.ecD = Just $ JOSE.SizedBase64Integer 32 $ privateKeyNumber
}
)
( JWSHeader { _jwsHeaderAlg = JOSE.Header.HeaderParam JOSE.Header.Protected ES256
, _jwsHeaderJku = Nothing
, _jwsHeaderJwk = Nothing
, _jwsHeaderKid = Nothing
, _jwsHeaderX5u = Nothing
, _jwsHeaderX5c = Nothing
, _jwsHeaderX5t = Nothing
, _jwsHeaderX5tS256 = Nothing
, _jwsHeaderTyp = Just (JOSE.Header.HeaderParam JOSE.Header.Protected "JWT")
, _jwsHeaderCty = Nothing
, _jwsHeaderCrit = Nothing
}
)
( ClaimsSet { _claimIss = Nothing
, _claimSub = Just $ vapidSub $ vapidClaims
, _claimAud = Just $ vapidAud $ vapidClaims
, _claimExp = Just $ vapidExp $ vapidClaims
, _claimNbf = Nothing
, _claimIat = Nothing
, _claimJti = Nothing
, _unregisteredClaims = HM.empty
}
)
JOSE.Compact.encodeCompact $ jwtData
----------------------------
{-
-- Manual implementation without using the JWT libraries.
-- This works as well.
-- Kept here mainly as process explanation.
-- JWT base 64 encoding is without padding
let messageForJWTSignature = let encodedJWTPayload = b64UrlNoPadding $ LB.toStrict $ A.encode $ A.object $
[ "aud" .= (TE.decodeUtf8With TE.lenientDecode $
(if secure initReq then "https://" else "http://") ++ (host initReq)
)
-- jwt expiration time
, "exp" .= (formatTime defaultTimeLocale "%s" $ addUTCTime 3000 time)
, "sub" .= ("mailto: " ++ (senderEmail pushNotification))
]
encodedJWTHeader = b64UrlNoPadding $ LB.toStrict $ A.encode $ A.object $
[ "typ" .= ("JWT" :: Text), "alg" .= ("ES256" :: Text) ]
in encodedJWTHeader <> "." <> encodedJWTPayload
-- JWT only accepts SHA256 hash with ECDSA for ES256 signed token
encodedJWTSignature <- do
-- ECDSA signing vulnerable to timing attacks
ECDSA.Signature signR signS <- liftIO $ ECDSA.sign (ECDSA.toPrivateKey vapidKeys)
SHA256
messageForJWTSignature
-- 32 bytes of R followed by 32 bytes of S
return $ b64UrlNoPadding $ LB.toStrict $
(Binary.encode $ int32Bytes signR) <>
(Binary.encode $ int32Bytes signS)
return $ Right $ messageForJWTSignature <> "." <> encodedJWTSignature
-}
----------------------------
data PushNotificationMessage = PushNotificationMessage { title :: Text
, body :: Text
, icon :: Text
, url :: Text
, tag :: Text
}
instance ToJSON PushNotificationMessage where
toJSON PushNotificationMessage {..} = A.object
[ "title" .= title
, "body" .= body
, "icon" .= icon
, "url" .= url
, "tag" .= tag
]
-- All inputs are in raw bytes with no encoding
-- except for the plaintext for which raw bytes are the Base 64 encoded bytes
data WebPushEncryptionInput = EncryptionInput { applicationServerPrivateKey :: ECDH.PrivateNumber
, userAgentPublicKeyBytes :: ByteString
, authenticationSecret :: ByteString
, salt :: ByteString
, plainText :: LB.ByteString
, paddingLength :: Int64
}
-- Intermediate encryption output used in tests
-- All in raw bytes
data WebPushEncryptionOutput = EncryptionOutput { sharedECDHSecretBytes :: ByteString
, inputKeyingMaterialBytes :: ByteString
, contentEncryptionKeyContext :: ByteString
, contentEncryptionKey :: ByteString
, nonceContext :: ByteString
, nonce :: ByteString
, paddedPlainText :: ByteString
, encryptedMessage :: ByteString
}
-- payload encryption
-- https://tools.ietf.org/html/draft-ietf-webpush-encryption-04
webPushEncrypt :: WebPushEncryptionInput -> Either CryptoError WebPushEncryptionOutput
webPushEncrypt EncryptionInput {..} =
let applicationServerPublicKeyBytes = LB.toStrict $ ecPublicKeyToBytes $
ECDH.calculatePublic (ECC.getCurveByName ECC.SEC_p256r1) $
applicationServerPrivateKey
userAgentPublicKey = ecBytesToPublicKey userAgentPublicKeyBytes
sharedECDHSecret = ECDH.getShared (ECC.getCurveByName ECC.SEC_p256r1) applicationServerPrivateKey userAgentPublicKey
-- HMAC key derivation (HKDF, here expanded into HMAC steps as specified in web push encryption spec)
pseudoRandomKeyCombine = HMAC.hmac authenticationSecret sharedECDHSecret :: HMAC.HMAC SHA256
authInfo = "Content-Encoding: auth" <> "\x00" :: ByteString
inputKeyingMaterial = HMAC.hmac pseudoRandomKeyCombine (authInfo <> "\x01") :: HMAC.HMAC SHA256
context = "P-256" <> "\x00" <>
"\x00" <> "\x41" <> userAgentPublicKeyBytes <>
"\x00" <> "\x41" <> applicationServerPublicKeyBytes
pseudoRandomKeyEncryption = HMAC.hmac salt inputKeyingMaterial :: HMAC.HMAC SHA256
contentEncryptionKeyContext = "Content-Encoding: aesgcm" <> "\x00" <> context
contentEncryptionKey = BS.pack $ take 16 $ ByteArray.unpack (HMAC.hmac pseudoRandomKeyEncryption (contentEncryptionKeyContext <> "\x01") :: HMAC.HMAC SHA256)
nonceContext = "Content-Encoding: nonce" <> "\x00" <> context
nonce = BS.pack $ take 12 $ ByteArray.unpack (HMAC.hmac pseudoRandomKeyEncryption (nonceContext <> "\x01") :: HMAC.HMAC SHA256)
-- HMAC a doesn't have Show instance needed for test suite
-- so we extract the bytes and store that in WebPushEncryptionOutput
inputKeyingMaterialBytes = ByteArray.convert inputKeyingMaterial
sharedECDHSecretBytes = ByteArray.convert sharedECDHSecret
-- padding length encoded in 2 bytes, followed by
-- padding length times '0' byte, followed by
-- message
paddedPlainText = LB.toStrict $
(Binary.encode (fromIntegral paddingLength :: Word16)) <>
(LB.replicate paddingLength (0 :: Word8)) <>
plainText
-- aes_gcm is aead (authenticated encryption with associated data)
-- use cek as the encryption key and nonce as the initialization vector
eitherAesCipher = Cipher.cipherInit contentEncryptionKey :: CryptoFailable AES128
in case eitherAesCipher of
CryptoFailed err -> Left err
CryptoPassed aesCipher ->
let eitherAeadGcmCipher = Cipher.aeadInit Cipher.AEAD_GCM aesCipher nonce
in case eitherAeadGcmCipher of
CryptoFailed err -> Left err
CryptoPassed aeadGcmCipher ->
-- tag length 16 bytes (maximum), anything less than 16 bytes may not be secure enough
-- spec says final encrypted size is 16 bits longer than the padded text
-- NOTE: the final encrypted message must be sent as raw binary data
let encryptedMessage = let (authTagBytes, cipherText) = Cipher.aeadSimpleEncrypt aeadGcmCipher
BS.empty
paddedPlainText
16
authTag = ByteArray.convert $ Cipher.unAuthTag authTagBytes
in cipherText <> authTag
in Right $ EncryptionOutput {..}
-- Conversions among integers and bytes
-- The bytes are in network/big endian order.
{-
-- DON'T use DER encoding to extract integer bytes
-- if a 32 byte number can be written in less bytes with leading zeros,
-- DER encdoing will be shorter than 32 bytes
-- and decoding to 4 word64 will fail because of short input
-}
ecPublicKeyToBytes :: ECC.Point -> LB.ByteString
-- Point0 is the point at infinity, not sure what's the encoding for that
-- CHECK THIS
ecPublicKeyToBytes ECC.PointO = "\x04" <>
(Binary.encode $ int32Bytes 0) <>
(Binary.encode $ int32Bytes 0)
ecPublicKeyToBytes (ECC.Point x y) = "\x04" <>
(Binary.encode $ int32Bytes x) <>
(Binary.encode $ int32Bytes y)
ecBytesToPublicKey :: ByteString -> ECC.Point
-- the first byte is guarenteed to be \x04 which tells that the key is in uncompressed form
ecBytesToPublicKey bytes = let bothCoordBytes = BS.drop 1 bytes
(xBytes, yBytes) = Binary.decode $ LB.fromStrict bothCoordBytes :: (Bytes32, Bytes32)
xInteger = bytes32Int xBytes
yInteger = bytes32Int yBytes
in ECC.Point xInteger yInteger
-- Coordinates on Elliptic Curves are 32 bit integers
type Bytes32 = (Word64, Word64, Word64, Word64)
-- points on elliptic curve for 256 bit algorithms are 32 bytes (256 bits) unsigned integers each
-- fixed width big endian format
-- integer to 4 Word64 (8 bytes each)
int32Bytes :: Integer -> Bytes32
int32Bytes number = let shift1 = Bits.shiftR number 64
shift2 = Bits.shiftR shift1 64
shift3 = Bits.shiftR shift2 64
in ( fromIntegral shift3
, fromIntegral shift2
, fromIntegral shift1
, fromIntegral number
)
bytes32Int :: Bytes32 -> Integer
bytes32Int (d,c,b,a) = (Bits.shiftL (fromIntegral d) (64*3)) +
(Bits.shiftL (fromIntegral c) (64*2)) +
(Bits.shiftL (fromIntegral b) (64 )) +
(fromIntegral a)
-- at most places we do not need the padding in base64 url encoding
b64UrlNoPadding :: ByteString -> ByteString
b64UrlNoPadding = fst . BS.breakSubstring "=" . B64.URL.encode