webpush: small fixes (#1699)

* Fix compilation for client lib

* Print VAPID fp

* Fix VAPID signature

* refactor

---------

Co-authored-by: sim <git@sgougeon.fr>

simplexmq.cabal

@@ -312,6 +312,7 @@ library
     , directory ==1.3.*
     , filepath ==1.4.*
     , hourglass ==0.2.*
+    , http-client ==0.7.*
     , http-types ==0.12.*
     , http2 >=4.2.2 && <4.3
     , iproute ==1.7.*
@@ -343,7 +344,6 @@ library
         case-insensitive ==1.2.*
       , hashable ==1.4.*
       , ini ==0.4.1
-      , http-client ==0.7.*
       , http-client-tls ==0.3.6.*
       , optparse-applicative >=0.15 && <0.17
       , process ==1.6.*

src/Simplex/Messaging/Crypto.hs

@@ -95,6 +95,7 @@ module Simplex.Messaging.Crypto
     encodePrivKey,
     decodePrivKey,
     pubKeyBytes,
+    encodeBigInt,
     uncompressEncodePoint,
     uncompressDecodePoint,
     uncompressDecodePrivateNumber,

src/Simplex/Messaging/Notifications/Server/Main.hs

@@ -11,7 +11,7 @@
 module Simplex.Messaging.Notifications.Server.Main where
 
 import Control.Logger.Simple (setLogLevel)
-import Control.Monad ( (<$!>), unless, void )
+import Control.Monad (unless, void, (<$!>))
 import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
 import Data.Ini (lookupValue, readIniFile)
@@ -31,9 +31,10 @@ import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClie
 import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol (NtfTokenId)
-import Simplex.Messaging.Notifications.Server (runNtfServer, restoreServerLastNtfs)
+import Simplex.Messaging.Notifications.Server (restoreServerLastNtfs, runNtfServer)
 import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..), defaultInactiveClientExpiration)
 import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig)
+import Simplex.Messaging.Notifications.Server.Push.WebPush (VapidKey (..), WebPushConfig (..), mkVapid)
 import Simplex.Messaging.Notifications.Server.Store (newNtfSTMStore)
 import Simplex.Messaging.Notifications.Server.Store.Postgres (exportNtfDbStore, importNtfSTMStore, newNtfDbStore)
 import Simplex.Messaging.Notifications.Server.StoreLog (readWriteNtfSTMStore)
@@ -55,9 +56,8 @@ import System.Directory (createDirectoryIfMissing, doesFileExist, renameFile)
 import System.Exit (exitFailure)
 import System.FilePath (combine)
 import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
-import Text.Read (readMaybe)
 import System.Process (readCreateProcess, shell)
-import Simplex.Messaging.Notifications.Server.Push.WebPush (WebPushConfig(..), VapidKey, mkVapid)
+import Text.Read (readMaybe)
 
 ntfServerCLI :: FilePath -> FilePath -> IO ()
 ntfServerCLI cfgPath logPath =
@@ -215,12 +215,13 @@ ntfServerCLI cfgPath logPath =
       hSetBuffering stdout LineBuffering
       hSetBuffering stderr LineBuffering
       fp <- checkSavedFingerprint cfgPath defaultX509Config
-      vapidKey <- getVapidKey vapidKeyPath
+      vapidKey@VapidKey {fp = vapidFp} <- getVapidKey vapidKeyPath
       let host = either (const "<hostnames>") T.unpack $ lookupValue "TRANSPORT" "host" ini
           port = T.unpack $ strictIni "TRANSPORT" "port" ini
           cfg@NtfServerConfig {transports} = serverConfig vapidKey
           srv = ProtoServerWithAuth (NtfServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp)) Nothing
       printServiceInfo serverVersion srv
+      B.putStrLn $ "VAPID: " <> vapidFp
       printNtfServerConfig transports dbStoreConfig
       runNtfServer cfg
       where
@@ -360,18 +361,21 @@ cliCommandP cfgPath logPath iniFile =
     skipTokensP =
       option
         strParse
-          ( long "skip-tokens"
-              <> help "Skip tokens during import"
-              <> value S.empty
-          )
+        ( long "skip-tokens"
+            <> help "Skip tokens during import"
+            <> value S.empty
+        )
     initP :: Parser InitOptions
     initP = do
       enableStoreLog <-
-        flag' False
+        flag'
+          False
           ( long "disable-store-log"
               <> help "Disable store log for persistence (enabled by default)"
           )
-          <|> flag True True
+          <|> flag
+            True
+            True
             ( long "store-log"
                 <> short 'l'
                 <> help "Enable store log for persistence (DEPRECATED, enabled by default)"

src/Simplex/Messaging/Notifications/Server/Push.hs

@@ -10,6 +10,8 @@
 
 module Simplex.Messaging.Notifications.Server.Push where
 
+import Control.Exception (Exception)
+import Control.Monad.Except (ExceptT)
 import Crypto.Hash.Algorithms (SHA256 (..))
 import qualified Crypto.PubKey.ECC.ECDSA as EC
 import qualified Crypto.PubKey.ECC.Types as ECT
@@ -28,15 +30,13 @@ import Data.List.NonEmpty (NonEmpty (..))
 import Data.Text (Text)
 import Data.Time.Clock.System
 import qualified Data.X509 as X
+import GHC.Exception (SomeException)
+import Network.HTTP.Types (Status)
+import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Notifications.Server.Store.Types (NtfTknRec)
 import Simplex.Messaging.Parsers (defaultJSON)
 import Simplex.Messaging.Transport.HTTP2.Client (HTTP2ClientError)
-import qualified Simplex.Messaging.Crypto as C
-import Network.HTTP.Types (Status)
-import Control.Exception (Exception)
-import Simplex.Messaging.Notifications.Server.Store.Types (NtfTknRec)
-import Control.Monad.Except (ExceptT)
-import GHC.Exception (SomeException)
 
 data JWTHeader = JWTHeader
   { typ :: Text, -- "JWT"
@@ -46,7 +46,7 @@ data JWTHeader = JWTHeader
   deriving (Show)
 
 mkJWTHeader :: Text -> Maybe Text -> JWTHeader
-mkJWTHeader alg kid = JWTHeader { typ = "JWT", alg, kid }
+mkJWTHeader alg kid = JWTHeader {typ = "JWT", alg, kid}
 
 data JWTClaims = JWTClaims
   { iss :: Maybe Text, -- issuer, team ID for APNS
@@ -65,13 +65,14 @@ mkJWTToken hdr iss = do
   iat <- systemSeconds <$> getSystemTime
   pure $ JWTToken hdr $ jwtClaims iat
   where
-    jwtClaims iat = JWTClaims
-      { iss = Just iss,
-        iat = Just iat,
-        exp = Nothing,
-        aud = Nothing,
-        sub = Nothing
-      }
+    jwtClaims iat =
+      JWTClaims
+        { iss = Just iss,
+          iat = Just iat,
+          exp = Nothing,
+          aud = Nothing,
+          sub = Nothing
+        }
 
 type SignedJWTToken = ByteString
 
@@ -79,15 +80,23 @@ $(JQ.deriveToJSON defaultJSON ''JWTHeader)
 
 $(JQ.deriveToJSON defaultJSON ''JWTClaims)
 
-signedJWTToken :: EC.PrivateKey -> JWTToken -> IO SignedJWTToken
-signedJWTToken pk (JWTToken hdr claims) = do
+signedJWTToken_ :: (EC.Signature -> ByteString) -> EC.PrivateKey -> JWTToken -> IO SignedJWTToken
+signedJWTToken_ serialize pk (JWTToken hdr claims) = do
   let hc = jwtEncode hdr <> "." <> jwtEncode claims
   sig <- EC.sign pk SHA256 hc
-  pure $ hc <> "." <> serialize sig
+  pure $ hc <> "." <> U.encodeUnpadded (serialize sig)
   where
     jwtEncode :: ToJSON a => a -> ByteString
     jwtEncode = U.encodeUnpadded . LB.toStrict . J.encode
-    serialize sig = U.encodeUnpadded $ encodeASN1' DER [Start Sequence, IntVal (EC.sign_r sig), IntVal (EC.sign_s sig), End Sequence]
+
+signedJWTToken :: EC.PrivateKey -> JWTToken -> IO SignedJWTToken
+signedJWTToken = signedJWTToken_ $ \sig ->
+  encodeASN1' DER [Start Sequence, IntVal (EC.sign_r sig), IntVal (EC.sign_s sig), End Sequence]
+
+-- | Does it work with APNS ?
+signedJWTTokenRaw :: EC.PrivateKey -> JWTToken -> IO SignedJWTToken
+signedJWTTokenRaw = signedJWTToken_ $ \sig ->
+  C.encodeBigInt (EC.sign_r sig) <> C.encodeBigInt (EC.sign_s sig)
 
 readECPrivateKey :: FilePath -> IO EC.PrivateKey
 readECPrivateKey f = do

src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs

@@ -125,11 +125,11 @@ mkVapidHeader VapidKey {key, fp} uriAuthority expire = do
           { iss = Nothing,
             iat = Nothing,
             exp = Just expire,
-            aud = Just $ T.decodeUtf8 uriAuthority,
+            aud = Just $ T.decodeUtf8 $ "https://" <> uriAuthority,
             sub = Just "https://github.com/simplex-chat/simplexmq/"
           }
       jwt = JWTToken jwtHeader jwtClaims
-  signedToken <- signedJWTToken key jwt
+  signedToken <- signedJWTTokenRaw key jwt
   pure $ "vapid t=" <> signedToken <> ",k=" <> fp
 
 wpPushProviderClient :: WebPushClient -> PushProviderClient