diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,23 @@ # web-push Helper functions to send messages using Web Push protocol. + +## Usage + +The `sendPushNotification` function encodes the message into Base64 URL form before encrypting and sending. Decode the message in Service Worker notification handler in browser before trying to read the JSON message. + +Guides to using Web Push API in browsers can be found on [Mozilla's](https://developer.mozilla.org/en/docs/Web/API/Push_API) and [Google's](https://developers.google.com/web/fundamentals/engage-and-retain/push-notifications/) docs, or you can check out [this](https://gist.github.com/sarthakbagaria/c08c0d7b84e1165760bb429a4064cfff) _untested_ Yesod app demonstrating the use of this library. + +## To Do + +- Add recognition of more error/status codes from send notification HTTP response. +- Clearly differentiate between ByteString encodings (Raw, Base64URL etc). +- Extend tests to verify that push messages are sent properly. + +## References + +Current implementation is based on the following versions of the drafts: +- [https://tools.ietf.org/html/draft-ietf-webpush-encryption-04](https://tools.ietf.org/html/draft-ietf-webpush-encryption-04) +- [https://tools.ietf.org/html/draft-ietf-httpbis-encryption-encoding-02](https://tools.ietf.org/html/draft-ietf-httpbis-encryption-encoding-02) +- [https://tools.ietf.org/html/draft-ietf-webpush-protocol-10](https://tools.ietf.org/html/draft-ietf-webpush-protocol-10) +- [https://tools.ietf.org/html/draft-ietf-webpush-vapid-01](https://tools.ietf.org/html/draft-ietf-webpush-vapid-01) diff --git a/src/Web/WebPush.hs b/src/Web/WebPush.hs --- a/src/Web/WebPush.hs +++ b/src/Web/WebPush.hs @@ -8,71 +8,58 @@ , vapidPublicKeyBytes , sendPushNotification -- * Types - , VAPIDKeys + , VAPIDKeys , VAPIDKeysMinDetails(..) , PushNotificationDetails(..) , PushNotificationMessage(..) , PushNotificationError(..) ) where - -import Data.ByteString (ByteString) -import GHC.Int (Int64) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy as LB -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Encoding.Error as TE -import qualified Data.List as L -import qualified Data.HashMap.Strict as HM -import Data.Time.Clock (getCurrentTime) -import Network.HTTP.Client (Manager, httpLbs, parseRequest, HttpException(StatusCodeException), RequestBody(..), requestBody, requestHeaders, method, host, secure) -import Network.HTTP.Types (hContentType, hAuthorization, hContentEncoding) -import Network.HTTP.Types.Status (Status(statusCode)) -import Data.Time (addUTCTime) +import Web.WebPush.Internal +import Crypto.Random (MonadRandom(getRandomBytes)) import qualified Crypto.PubKey.ECC.Types as ECC import qualified Crypto.PubKey.ECC.Generate 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.Random (MonadRandom(getRandomBytes)) -import Crypto.Cipher.AES (AES128) -import qualified Crypto.Cipher.Types as Cipher -import Crypto.Error (CryptoFailable(CryptoPassed,CryptoFailed), CryptoError) -import Crypto.JWT (createJWSJWT, ClaimsSet(..), NumericDate(..)) +import Crypto.JWT (NumericDate(..)) import qualified Crypto.JWT as JWT -import qualified Crypto.JOSE.JWK as JWK -import Crypto.JOSE.JWS (JWSHeader(..), Alg(ES256)) -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.Bits as Bits +import Data.Word (Word8) + +import GHC.Int (Int64) +import qualified Data.List as L +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Encoding.Error as TE +import Data.Monoid ((<>)) +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C8 import qualified Data.Aeson as A import qualified Data.ByteString.Base64.URL as B64.URL import qualified Data.ByteString.Base64.URL.Lazy as B64.URL.Lazy -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 System.Random (randomRIO) +import Data.Time.Clock (getCurrentTime) +import Data.Time (addUTCTime) +import Network.HTTP.Client (Manager, httpLbs, parseRequest, HttpException(HttpExceptionRequest), HttpExceptionContent(StatusCodeException), RequestBody(..), requestBody, requestHeaders, method, host, secure, responseStatus) +import Network.HTTP.Types (hContentType, hAuthorization, hContentEncoding) +import Network.HTTP.Types.Status (Status(statusCode)) + +import qualified Crypto.JOSE.Error as JOSE.Error +import Crypto.Error (CryptoError) + import Control.Exception.Base (SomeException(..), fromException) import Control.Monad.Catch.Pure (runCatchT) import Control.Monad.IO.Class (MonadIO, liftIO) - - -type VAPIDKeys = ECDSA.KeyPair +import System.Random (randomRIO) -- |Generate the 3 integers minimally representing a unique pair of public and private keys. @@ -80,6 +67,7 @@ -- Store them in configuration and use them across multiple push notification requests. generateVAPIDKeys :: MonadRandom m => m VAPIDKeysMinDetails generateVAPIDKeys = do + -- SEC_p256r1 is the NIST P-256 (pubKey, privKey) <- ECC.generate $ ECC.getCurveByName ECC.SEC_p256r1 let ECC.Point pubX pubY = ECDSA.public_q pubKey return $ VAPIDKeysMinDetails { privateNumber = ECDSA.private_d privKey @@ -87,7 +75,7 @@ , publicCoordY = pubY } - + -- |Read VAPID key pair from the 3 integers minimally representing a unique key pair. readVAPIDKeys :: VAPIDKeysMinDetails -> VAPIDKeys readVAPIDKeys VAPIDKeysMinDetails {..} = @@ -95,16 +83,15 @@ in ECDSA.KeyPair (ECC.getCurveByName ECC.SEC_p256r1) vapidPublicKeyPoint privateNumber --- |Pass the VAPID public key bytes to front end when subscribing to push notifications. --- +-- |Pass the VAPID public key bytes to browser when subscribing to push notifications. -- Generate application server key using --- applicationServerKey = new Uint8Array(vapidPublicKeyBytes) in Javascript +-- applicationServerKey = new Uint8Array(vapidPublicKeyBytes) in Javascript. vapidPublicKeyBytes :: VAPIDKeys -> [Word8] vapidPublicKeyBytes keys = let ECC.Point vapidPublicKeyX vapidPublicKeyY = ECDSA.public_q $ ECDSA.toPublicKey keys -- First byte 04 tells that the EC key is uncompressed in 4 : ( (extract32Bytes vapidPublicKeyX) ++ (extract32Bytes vapidPublicKeyY) ) - + where -- an array of bytes -- 32 steps (32 bytes) @@ -115,10 +102,16 @@ ([1..32] :: [Int]) +-- References: +-- NOTE: these references are drafts; the current implementation is based on the versions given below. +-- https://tools.ietf.org/html/draft-ietf-webpush-encryption-04 +-- https://tools.ietf.org/html/draft-ietf-httpbis-encryption-encoding-02 +-- https://tools.ietf.org/html/draft-ietf-webpush-protocol-10 +-- https://tools.ietf.org/html/draft-ietf-webpush-vapid-01 + -- |Send a Push Message. --- --- The message sent is base64 URL encoded. --- Decode the message in notification handler in front end. +-- The message sent is Base64 URL encoded. +-- Decode the message in Service Worker notification handler in browser before trying to read the JSON. sendPushNotification :: MonadIO m => VAPIDKeys -> Manager @@ -127,278 +120,94 @@ sendPushNotification vapidKeys httpManager pushNotification = do eitherInitReq <- runCatchT $ parseRequest $ T.unpack $ endpoint pushNotification case eitherInitReq of - -- delete endpoint if it cannot be parsed Left exc@(SomeException _) -> return $ Left $ EndpointParseFailed exc Right initReq -> do time <- liftIO $ getCurrentTime - - -- JWT encryption for VAPID - eitherJwt <- do - let ECC.Point publicKeyX publicKeyY = ECDSA.public_q $ ECDSA.toPublicKey vapidKeys - privateKeyNumber = ECDSA.private_d $ ECDSA.toPrivateKey vapidKeys - - eitherJwtData <- liftIO $ 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 { headerAlg = Just ES256 - , headerJku = Nothing - , headerJwk = Nothing - , headerKid = Nothing - , headerX5u = Nothing - , headerX5c = Nothing - , headerX5t = Nothing - , headerX5tS256 = Nothing - , headerTyp = Just "JWT" - , headerCty = Nothing - , headerCrit = Nothing - } - ) - - ( ClaimsSet { _claimIss = Nothing - , _claimSub = Just $ JWT.fromString $ T.append "mailto:" $ senderEmail pushNotification - , _claimAud = Just $ JWT.Special $ JWT.fromString $ TE.decodeUtf8With TE.lenientDecode $ - BS.append (if secure initReq then "https://" else "http://") (host initReq) - - , _claimExp = Just $ NumericDate $ addUTCTime 3000 time - , _claimNbf = Nothing - , _claimIat = Nothing - , _claimJti = Nothing - , _unregisteredClaims = HM.empty - } - ) - - case eitherJwtData of - Left err -> return $ Left err - Right jwtData -> return $ LB.toStrict <$> (JOSE.Compact.encodeCompact $ jwtData) - - ---------------------------- - {- - -- Manual implementation without using the JWT libraries - -- This works as well, - -- kept here mainly to understanding the process - - -- 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 - -} - ---------------------------- - - + eitherJwt <- webPushJWT vapidKeys $ VAPIDClaims { vapidAud = JWT.Audience [ JWT.fromString $ TE.decodeUtf8With TE.lenientDecode $ + BS.append (if secure initReq then "https://" else "http://") (host initReq) + ] + , vapidSub = JWT.fromString $ T.append "mailto:" $ senderEmail pushNotification + , vapidExp = NumericDate $ addUTCTime 3000 time + } case eitherJwt of Left err -> return $ Left $ JWTGenerationFailed err Right jwt -> do - -- payload encryption - -- https://tools.ietf.org/html/draft-ietf-webpush-encryption-04 - -- cek = content encryption key - (cek, nonce, salt, ecdhServerPublicKeyBytes) <- do - - -- first create a new pair of ECDH keys on P-256 curve (SEC_p256r1) and get the sharedSecret - ecdhServerPrivateKey <- liftIO $ ECDH.generatePrivate $ ECC.getCurveByName ECC.SEC_p256r1 - salt <- liftIO $ getRandomBytes 16 - - let ecdhServerPublicKeyBytes = LB.toStrict $ ecPublicKeyToBytes $ - ECDH.calculatePublic (ECC.getCurveByName ECC.SEC_p256r1) ecdhServerPrivateKey - - ecdhSecretBytes = ECDH.getShared (ECC.getCurveByName ECC.SEC_p256r1) ecdhServerPrivateKey subscriptionPublicKey - authSecretBytes = B64.URL.decodeLenient $ TE.encodeUtf8 $ auth pushNotification - - -- then use HMAC key derivation (HKDF, here expanded into HMAC steps as specified in web push encryption spec) - authInfo = "Content-Encoding: auth" <> "\x00" :: ByteString - - prkCombine = HMAC.hmac authSecretBytes ecdhSecretBytes :: HMAC.HMAC SHA256 - ikm = HMAC.hmac prkCombine (authInfo <> "\x01") :: HMAC.HMAC SHA256 - - - context = "P-256" <> "\x00" <> - "\x00" <> "\x41" <> subscriptionPublicKeyBytes <> - "\x00" <> "\x41" <> ecdhServerPublicKeyBytes - - cekInfo = "Content-Encoding: aesgcm" <> "\x00" <> context - - prk = HMAC.hmac salt ikm :: HMAC.HMAC SHA256 - cek = BS.pack $ take 16 $ ByteArray.unpack $ (HMAC.hmac prk (cekInfo <> "\x01") :: HMAC.HMAC SHA256) - - nonceInfo = "Content-Encoding: nonce" <> "\x00" <> context - nonce = BS.pack $ take 12 $ ByteArray.unpack $ (HMAC.hmac prk (nonceInfo <> "\x01") :: HMAC.HMAC SHA256) - - return (cek, nonce, salt, ecdhServerPublicKeyBytes) - - -- padding is required can't skip, add a random length padding (0 - 20 bytes) - -- NOTE: 0 length padding is allowed, it just takes 2 bytes to encode the padding length - - paddedMessage <- do - randLen <- liftIO $ randomRIO (0, 20) - - let plainMessage64Encoded = B64.URL.Lazy.encode $ A.encode $ toJSON $ message pushNotification - paddedMessage = LB.toStrict $ pad randLen plainMessage64Encoded - - return $ paddedMessage - - -- aes_gcm is aead (authenticated encryption with associated data) - -- use cek as the encryption key and nonce as the initialization vector - let eitherAesCipher = Cipher.cipherInit cek :: CryptoFailable AES128 - case eitherAesCipher of - CryptoFailed err -> return $ Left $ MessageEncryptionFailed err - CryptoPassed aesCipher -> do - let eitherAeadGcmCipher = Cipher.aeadInit Cipher.AEAD_GCM aesCipher nonce - case eitherAeadGcmCipher of - CryptoFailed err -> return $ Left $ MessageEncryptionFailed err - CryptoPassed aeadGcmCipher -> do - - -- 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 (authTag, cipherText) = Cipher.aeadSimpleEncrypt aeadGcmCipher - BS.empty - paddedMessage - 16 - in cipherText <> (BS.pack $ ByteArray.unpack $ Cipher.unAuthTag authTag) + ecdhServerPrivateKey <- liftIO $ ECDH.generatePrivate $ ECC.getCurveByName ECC.SEC_p256r1 + randSalt <- liftIO $ getRandomBytes 16 + padLen <- liftIO $ randomRIO (0, 20) - -- content-length is automtically added before making the http request - postHeaders = let authorizationHeader = "WebPush " <> jwt - cryptoKeyHeader = BS.concat [ "dh=", b64UrlNoPadding ecdhServerPublicKeyBytes - , ";" - -- this base64 should be without padding - -- according to the spec - , "p256ecdsa=", b64UrlNoPadding vapidPublicKeyBytestring - ] + let authSecretBytes = B64.URL.decodeLenient $ TE.encodeUtf8 $ auth pushNotification + -- extract the 65 bytes of ECDH uncompressed public key received from browser in subscription + subscriptionPublicKeyBytes = B64.URL.decodeLenient $ TE.encodeUtf8 $ p256dh pushNotification + -- encode the message to a safe representation like base64URL before sending it to encryption algorithms + -- decode the message through service workers on browsers before trying to read the JSON + plainMessage64Encoded = B64.URL.Lazy.encode $ A.encode $ A.toJSON $ message pushNotification - in [ ("TTL", C8.pack $ show (60*60*(expireInHours pushNotification))) - , (hContentType, "text/plain;charset=utf8") - , (hAuthorization, authorizationHeader) - , ("Crypto-Key", cryptoKeyHeader) - , (hContentEncoding, "aesgcm") - , ("Encryption", "salt=" <> (b64UrlNoPadding salt)) - ] + eitherEncryptionOutput = webPushEncrypt $ EncryptionInput { applicationServerPrivateKey = ecdhServerPrivateKey + , userAgentPublicKeyBytes = subscriptionPublicKeyBytes + , authenticationSecret = authSecretBytes + , salt = randSalt + , plainText = plainMessage64Encoded + , paddingLength = padLen + } + case eitherEncryptionOutput of + Left err -> return $ Left $ MessageEncryptionFailed err + Right encryptionOutput -> do - request = initReq { method = "POST" - , requestHeaders = postHeaders ++ - -- avoid duplicates - (filter (\(x, _) -> L.notElem x $ map fst postHeaders) - (requestHeaders initReq) - ) - -- the body is encrypted message in raw bytes - -- without URL encoding - , requestBody = RequestBodyBS encryptedMessage - } + let ecdhServerPublicKeyBytes = LB.toStrict $ ecPublicKeyToBytes $ + ECDH.calculatePublic (ECC.getCurveByName ECC.SEC_p256r1) $ + ecdhServerPrivateKey + -- content-length is automtically added before making the http request + let postHeaders = let authorizationHeader = LB.toStrict $ "WebPush " <> jwt + cryptoKeyHeader = BS.concat [ "dh=", b64UrlNoPadding ecdhServerPublicKeyBytes + , ";" + , "p256ecdsa=", b64UrlNoPadding vapidPublicKeyBytestring + ] + in [ ("TTL", C8.pack $ show (60*60*(expireInHours pushNotification))) + , (hContentType, "application/octet-stream") + , (hAuthorization, authorizationHeader) + , ("Crypto-Key", cryptoKeyHeader) + , (hContentEncoding, "aesgcm") + , ("Encryption", "salt=" <> (b64UrlNoPadding randSalt)) + ] + request = initReq { method = "POST" + , requestHeaders = postHeaders ++ + -- avoid duplicate headers + (filter (\(x, _) -> L.notElem x $ map fst postHeaders) + (requestHeaders initReq) + ) + -- the body is encrypted message in raw bytes + -- without URL encoding + , requestBody = RequestBodyBS $ encryptedMessage encryptionOutput + } - -- httpLbs from Network.HTTP.Client.Conduit takes manager from the Reader environment - eitherResp <- runCatchT $ liftIO $ httpLbs request httpManager - case eitherResp of - Left err@(SomeException _) -> case fromException err of - Just (StatusCodeException status _ _) - -- when the endpoint is invalid, we need to remove it from database - |(statusCode status == 404) -> return $ Left RecepientEndpointNotFound - _ -> return $ Left $ PushRequestFailed err - Right _ -> return $ Right () + eitherResp <- runCatchT $ liftIO $ httpLbs request httpManager + case eitherResp of + Left err@(SomeException _) -> case fromException err of + Just (HttpExceptionRequest _ (StatusCodeException resp _)) + -- when the endpoint is invalid, we need to remove it from database + |(statusCode (responseStatus resp) == 404) -> return $ Left RecepientEndpointNotFound + _ -> return $ Left $ PushRequestFailed err + Right _ -> return $ Right () where vapidPublicKeyBytestring = LB.toStrict $ ecPublicKeyToBytes $ ECDSA.public_q $ ECDSA.toPublicKey vapidKeys - -- 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) - -- extract the 65 bytes of ECDH uncompressed public key received from browser in subscription - subscriptionPublicKeyBytes = B64.URL.decodeLenient $ TE.encodeUtf8 $ p256dh pushNotification - -- the first byte is guarenteed to be \x04 which tells that the key is in uncompressed form - subscriptionPublicKey = let bothCoordBytes = BS.drop 1 $ subscriptionPublicKeyBytes - (xBytes, yBytes) = Binary.decode $ LB.fromStrict bothCoordBytes :: (Bytes32, Bytes32) - xInteger = bytes32Int xBytes - yInteger = bytes32Int yBytes - in ECC.Point xInteger yInteger - -- fixed width big endian format - -- First byte 04 tells that the EC key is uncompressed - - {- - -- 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) - - - -- padding: scheme - -- the first 2 bytes (16bits) represent length of padding - -- followed by that many null bytes - -- padding is added at the beginning of the message - pad :: Int64 -> LB.ByteString -> LB.ByteString - pad len message = (Binary.encode (fromIntegral len :: Word16)) <> (LB.replicate len (0 :: Word8)) <> message - - b64UrlNoPadding = fst . BS.breakSubstring "=" . B64.URL.encode - - - -- |Web push subscription and message details. -- -- Get subscription details from front end using -- subscription.endpoint, -- subscription.toJSON().keys.p256dh and -- subscription.toJSON().keys.auth. --- -- Save subscription details to send messages to the endpoint in future. data PushNotificationDetails = PushNotificationDetails { endpoint :: Text , p256dh :: Text @@ -407,37 +216,19 @@ , expireInHours :: Int64 , message :: PushNotificationMessage } - -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 - ] - -- |3 integers minimally representing a unique VAPID key pair. data VAPIDKeysMinDetails = VAPIDKeysMinDetails { privateNumber :: Integer , publicCoordX :: Integer , publicCoordY :: Integer } - +-- |'RecepientEndpointNotFound' comes up when the endpoint is no longer recognized by the push service. +-- This may happen if the user has cancelled the push subscription, and hence deleted the endpoint. +-- You may want to delete the endpoint from database in this case. data PushNotificationError = EndpointParseFailed SomeException | JWTGenerationFailed JOSE.Error.Error | MessageEncryptionFailed CryptoError | RecepientEndpointNotFound | PushRequestFailed SomeException - - -type Bytes32 = (Word64, Word64, Word64, Word64) diff --git a/src/Web/WebPush/Internal.hs b/src/Web/WebPush/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Web/WebPush/Internal.hs @@ -0,0 +1,286 @@ +{-# 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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/WebPushEncryptionSpec.hs b/test/WebPushEncryptionSpec.hs new file mode 100644 --- /dev/null +++ b/test/WebPushEncryptionSpec.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE OverloadedStrings #-} + +module WebPushEncryptionSpec where + +import Web.WebPush.Internal + +import Test.Hspec + +import qualified Data.Binary as Binary +import qualified Data.ByteString.Base64.URL as B64.URL +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LB + + +-- Test to match input and output from the specification. +-- https://tools.ietf.org/html/draft-ietf-webpush-encryption-04 +spec :: Spec +spec = describe "Web Push Encryption Test" $ do + + let encryptionInput = EncryptionInput + { applicationServerPrivateKey = bytes32Int $ bsTo32Bytes $ BS.concat [ "nCScek-QpEjmOOlT-rQ38nZ" + , "zvdPlqa00Zy0i6m2OJvY" + ] + , userAgentPublicKeyBytes = B64.URL.decodeLenient $ BS.concat [ "BCEkBjzL8Z3C-oi2Q7oE5t2Np-" + , "p7osjGLg93qUP0wvqR" + , "T21EEWyf0cQDQcakQMqz4hQKYOQ3il2nNZct4HgAUQU" + ] + , authenticationSecret = B64.URL.decodeLenient "R29vIGdvbyBnJyBqb29iIQ" + , salt = B64.URL.decodeLenient "lngarbyKfMoi9Z75xYXmkg" + , plainText = "I am the walrus" + , paddingLength = 0 + } + + encryptionOutput = webPushEncrypt encryptionInput + + expectedEncryptionOutput = EncryptionOutput + { sharedECDHSecretBytes = B64.URL.decodeLenient $ BS.concat [ "RNjC-" + -- NOTE: the specs example might have printed this wrong + -- there should be two consecutive hyphens and not one + -- near the end of the encoded string, just before "NOQ6Y" + , "NVW4BGJbxWPW7G2mowsLeDa53LYKYm4--NOQ6Y" + ] + , inputKeyingMaterialBytes = B64.URL.decodeLenient $ BS.concat [ "EhpZec37Ptm4IRD5-jtZ0q6r1iK5vYmY1tZwtN8" + , "fbZY" + ] + , contentEncryptionKeyContext = B64.URL.decodeLenient $ BS.concat [ "Q29udGVudC1FbmNvZGluZzogYWVzZ2NtAFAtMjU2AABB BCEkBjzL8Z3C-" + , "oi2Q7oE5t2Np-p7osjGLg93qUP0wvqR" + , "T21EEWyf0cQDQcakQMqz4hQKYOQ3il2nNZct4HgAUQUA" + , "QQTaEQ22_OCRpvIOWeQhcbq0qrF1iddSLX1xFmFSxPOW" + , "OwmJA417CBHOGqsWGkNRvAapFwiegz6Q61rXVo_5roB1" + ] + , contentEncryptionKey = B64.URL.decodeLenient "AN2-xhvFWeYh5z0fcDu0Ww" + , nonceContext = B64.URL.decodeLenient $ BS.concat [ "Q29udGVudC1FbmNvZGluZzogbm9uY2UAUC0yNT" + , "YAAEEE ISQGPMvxncL6iLZDugTm3Y2n6nuiyMYuD3epQ_TC-pFP" + , "bUQRbJ_RxANBxqRAyrPiFApg5DeKXac1ly3geABRBQBB" + , "BNoRDbb84JGm8g5Z5CFxurSqsXWJ11ItfXEWYVLE85Y7" + , "CYkDjXsIEc4aqxYaQ1G8BqkXCJ6DPpDrWtdWj_mugHU" + ] + , nonce = B64.URL.decodeLenient "JY1Okw5rw1Drkg9J" + , paddedPlainText = B64.URL.decodeLenient "AABJIGFtIHRoZSB3YWxydXM" + , encryptedMessage = B64.URL.decodeLenient $ BS.concat [ "6nqAQUME8hNqw5J3kl8cpVVJylXKYqZOeseZG8UueKpA" ] + } + + it "should match the shared secret" $ do + (sharedECDHSecretBytes <$> encryptionOutput) `shouldBe` Right (sharedECDHSecretBytes expectedEncryptionOutput) + + it "should match the input keying material" $ do + (inputKeyingMaterialBytes <$> encryptionOutput) `shouldBe` Right (inputKeyingMaterialBytes expectedEncryptionOutput) + + it "should match the context for content encryption key derivation" $ do + (contentEncryptionKeyContext <$> encryptionOutput) `shouldBe` Right (contentEncryptionKeyContext expectedEncryptionOutput) + + it "should match the content encryption key" $ do + (contentEncryptionKey <$> encryptionOutput) `shouldBe` Right (contentEncryptionKey expectedEncryptionOutput) + + it "should match the context for nonce derivation" $ do + (nonceContext <$> encryptionOutput) `shouldBe` Right (nonceContext expectedEncryptionOutput) + + it "should match the nonce" $ do + (nonce <$> encryptionOutput) `shouldBe` Right (nonce expectedEncryptionOutput) + + it "should match the paddded plain text" $ do + (paddedPlainText <$> encryptionOutput) `shouldBe` Right (paddedPlainText expectedEncryptionOutput) + + it "should match the encrypted message" $ do + (encryptedMessage <$> encryptionOutput) `shouldBe` Right (encryptedMessage expectedEncryptionOutput) + + + + where + bsTo32Bytes :: ByteString -> Bytes32 + bsTo32Bytes = Binary.decode . LB.fromStrict . B64.URL.decodeLenient diff --git a/web-push.cabal b/web-push.cabal --- a/web-push.cabal +++ b/web-push.cabal @@ -1,6 +1,6 @@ name: web-push -version: 0.1.0.0 -synopsis: Helper functions to send messages using Web Push protocol. +version: 0.1.2.0 +synopsis: Send messages using Web Push protocol. description: Please see README.md homepage: https://github.com/sarthakbagaria/web-push#readme license: MIT @@ -16,6 +16,7 @@ library hs-source-dirs: src exposed-modules: Web.WebPush + Web.WebPush.Internal ghc-options: -Wall -fwarn-tabs -O2 build-depends: base >= 4.7 && < 5 , aeson @@ -23,18 +24,33 @@ , bytestring >= 0.9 && < 0.11 , base64-bytestring >= 1.0.0.1 && < 1.1 , text >= 0.11 && < 2.0 - , cryptonite >= 0.6 && < 0.16 + , cryptonite >= 0.21 && < 0.22 , binary >= 0.7.5 && < 0.9 - , memory >= 0.13 && < 0.14 + , memory >= 0.14.5 && < 0.15 , random >= 1.1 && < 1.2 - , http-client >= 0.4.31 && < 0.5 + , http-client >= 0.5.7 && < 0.6 , http-types >= 0.8.6 && < 1.0 , exceptions >= 0.8.3 && < 0.9 - , transformers >= 0.4.2.0 && < 0.5 - - , jose >= 0.4.0.2 && < 0.5 + , transformers >= 0.5.2.0 && < 0.6 + , mtl >= 2.2.1 && < 2.3 + , jose >= 0.5.0.4 && < 0.6 , unordered-containers - + + default-language: Haskell2010 + +test-suite web-push-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: WebPushEncryptionSpec + hs-source-dirs: test + ghc-options: -Wall + build-depends: base + , web-push + , hspec >= 2.4.3 && < 2.5 + , bytestring >= 0.9 && < 0.11 + , base64-bytestring >= 1.0.0.1 && < 1.1 + , binary >= 0.7.5 && < 0.9 + default-language: Haskell2010 source-repository head