web-push-0.1.0.0: src/Web/WebPush.hs
{-# LANGUAGE RecordWildCards, OverloadedStrings #-}
module Web.WebPush
(
-- * Functions
generateVAPIDKeys
, readVAPIDKeys
, vapidPublicKeyBytes
, sendPushNotification
-- * Types
, 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 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 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.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 Control.Exception.Base (SomeException(..), fromException)
import Control.Monad.Catch.Pure (runCatchT)
import Control.Monad.IO.Class (MonadIO, liftIO)
type VAPIDKeys = ECDSA.KeyPair
-- |Generate the 3 integers minimally representing a unique pair of public and private keys.
--
-- Store them in configuration and use them across multiple push notification requests.
generateVAPIDKeys :: MonadRandom m => m VAPIDKeysMinDetails
generateVAPIDKeys = do
(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
, publicCoordX = pubX
, publicCoordY = pubY
}
-- |Read VAPID key pair from the 3 integers minimally representing a unique key pair.
readVAPIDKeys :: VAPIDKeysMinDetails -> VAPIDKeys
readVAPIDKeys VAPIDKeysMinDetails {..} =
let vapidPublicKeyPoint = ECC.Point publicCoordX publicCoordY
in ECDSA.KeyPair (ECC.getCurveByName ECC.SEC_p256r1) vapidPublicKeyPoint privateNumber
-- |Pass the VAPID public key bytes to front end when subscribing to push notifications.
--
-- Generate application server key using
-- 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)
-- in each step extract last 8 bits using fromIntegral
extract32Bytes :: Integer -> [Word8]
extract32Bytes number = snd $ L.foldl' (\(integer, bytes) _ -> (Bits.shiftR integer 8, (fromIntegral integer) : bytes))
(number, ([] :: [Word8]))
([1..32] :: [Int])
-- |Send a Push Message.
--
-- The message sent is base64 URL encoded.
-- Decode the message in notification handler in front end.
sendPushNotification :: MonadIO m
=> VAPIDKeys
-> Manager
-> PushNotificationDetails
-> m (Either PushNotificationError ())
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
-}
----------------------------
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)
-- 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
]
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))
]
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
}
-- 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 ()
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
, auth :: Text
, senderEmail :: Text
, 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
}
data PushNotificationError = EndpointParseFailed SomeException
| JWTGenerationFailed JOSE.Error.Error
| MessageEncryptionFailed CryptoError
| RecepientEndpointNotFound
| PushRequestFailed SomeException
type Bytes32 = (Word64, Word64, Word64, Word64)