clean up WP encryption

src/Simplex/Messaging/Agent.hs

@@ -201,7 +201,7 @@ import qualified Simplex.Messaging.Crypto.ShortLink as SL
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId, PNMessageData (..), pnMessagesP)
+import Simplex.Messaging.Notifications.Protocol (ADeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId, PNMessageData (..), pnMessagesP)
 import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (defaultJSON, parse)
 import Simplex.Messaging.Protocol
@@ -619,24 +619,24 @@ reconnectAllServers c = do
   reconnectServerClients c ntfClients
 
 -- | Register device notifications token
-registerNtfToken :: AgentClient -> NetworkRequestMode -> DeviceToken -> NotificationsMode -> AE NtfTknStatus
+registerNtfToken :: AgentClient -> NetworkRequestMode -> ADeviceToken -> NotificationsMode -> AE NtfTknStatus
 registerNtfToken c = withAgentEnv c .:. registerNtfToken' c
 {-# INLINE registerNtfToken #-}
 
 -- | Verify device notifications token
-verifyNtfToken :: AgentClient -> NetworkRequestMode -> DeviceToken -> C.CbNonce -> ByteString -> AE ()
+verifyNtfToken :: AgentClient -> NetworkRequestMode -> ADeviceToken -> C.CbNonce -> ByteString -> AE ()
 verifyNtfToken c = withAgentEnv c .:: verifyNtfToken' c
 {-# INLINE verifyNtfToken #-}
 
-checkNtfToken :: AgentClient -> NetworkRequestMode -> DeviceToken -> AE NtfTknStatus
+checkNtfToken :: AgentClient -> NetworkRequestMode -> ADeviceToken -> AE NtfTknStatus
 checkNtfToken c = withAgentEnv c .: checkNtfToken' c
 {-# INLINE checkNtfToken #-}
 
-deleteNtfToken :: AgentClient -> DeviceToken -> AE ()
+deleteNtfToken :: AgentClient -> ADeviceToken -> AE ()
 deleteNtfToken c = withAgentEnv c . deleteNtfToken' c
 {-# INLINE deleteNtfToken #-}
 
-getNtfToken :: AgentClient -> AE (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
+getNtfToken :: AgentClient -> AE (ADeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
 getNtfToken c = withAgentEnv c $ getNtfToken' c
 {-# INLINE getNtfToken #-}
 
@@ -2453,7 +2453,7 @@ checkUserServers name srvs =
   unless (any (\ServerCfg {enabled} -> enabled) srvs) $
     logWarn (name <> ": all passed servers are disabled, using all servers.")
 
-registerNtfToken' :: AgentClient -> NetworkRequestMode -> DeviceToken -> NotificationsMode -> AM NtfTknStatus
+registerNtfToken' :: AgentClient -> NetworkRequestMode -> ADeviceToken -> NotificationsMode -> AM NtfTknStatus
 registerNtfToken' c nm suppliedDeviceToken suppliedNtfMode =
   withStore' c getSavedNtfToken >>= \case
     Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId, ntfTknStatus, ntfTknAction, ntfMode = savedNtfMode} -> do
@@ -2530,7 +2530,7 @@ registerNtfToken' c nm suppliedDeviceToken suppliedNtfMode =
       ns <- asks ntfSupervisor
       atomically $ nsUpdateToken ns tkn {deviceToken = suppliedDeviceToken, ntfTknStatus = NTRegistered, ntfMode = suppliedNtfMode}
 
-verifyNtfToken' :: AgentClient -> NetworkRequestMode -> DeviceToken -> C.CbNonce -> ByteString -> AM ()
+verifyNtfToken' :: AgentClient -> NetworkRequestMode -> ADeviceToken -> C.CbNonce -> ByteString -> AM ()
 verifyNtfToken' c nm deviceToken nonce code =
   withStore' c getSavedNtfToken >>= \case
     Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId = Just tknId, ntfDhSecret = Just dhSecret, ntfMode} -> do
@@ -2549,7 +2549,7 @@ setCronInterval c nm tknId tkn = do
   cron <- asks $ ntfCron . config
   void $ forkIO $ void $ runExceptT $ agentNtfSetCronInterval c nm tknId tkn cron
 
-checkNtfToken' :: AgentClient -> NetworkRequestMode -> DeviceToken -> AM NtfTknStatus
+checkNtfToken' :: AgentClient -> NetworkRequestMode -> ADeviceToken -> AM NtfTknStatus
 checkNtfToken' c nm deviceToken =
   withStore' c getSavedNtfToken >>= \case
     Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId = Just tknId, ntfTknAction} -> do
@@ -2563,7 +2563,7 @@ checkNtfToken' c nm deviceToken =
       pure status
     _ -> throwE $ CMD PROHIBITED "checkNtfToken: no token"
 
-deleteNtfToken' :: AgentClient -> DeviceToken -> AM ()
+deleteNtfToken' :: AgentClient -> ADeviceToken -> AM ()
 deleteNtfToken' c deviceToken =
   withStore' c getSavedNtfToken >>= \case
     Just tkn@NtfToken {deviceToken = savedDeviceToken} -> do
@@ -2572,7 +2572,7 @@ deleteNtfToken' c deviceToken =
       deleteNtfSubs c NSCSmpDelete
     _ -> throwE $ CMD PROHIBITED "deleteNtfToken: no token"
 
-getNtfToken' :: AgentClient -> AM (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
+getNtfToken' :: AgentClient -> AM (ADeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
 getNtfToken' c =
   withStore' c getSavedNtfToken >>= \case
     Just NtfToken {deviceToken, ntfTknStatus, ntfMode, ntfServer} -> pure (deviceToken, ntfTknStatus, ntfMode, ntfServer)

src/Simplex/Messaging/Agent/Client.hs

@@ -1322,7 +1322,7 @@ runNTFServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth sr
         (nKey, npKey) <- atomically $ C.generateAuthKeyPair a g
         (dhKey, _) <- atomically $ C.generateKeyPair g
         r <- runExceptT $ do
-          let deviceToken = APNSDeviceToken PPApnsNull "test_ntf_token"
+          let deviceToken = ADT SAPNS $ APNSDeviceToken PPApnsNull "test_ntf_token"
           (tknId, _) <- liftError (testErr TSCreateNtfToken) $ ntfRegisterToken ntf nm npKey (NewNtfTkn deviceToken nKey dhKey)
           liftError (testErr TSDeleteNtfToken) $ ntfDeleteToken ntf nm npKey tknId
         ok <- netTimeoutInt (tcpTimeout $ networkConfig cfg) nm `timeout` closeProtocolClient ntf
@@ -1972,7 +1972,7 @@ agentNtfCheckToken :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToke
 agentNtfCheckToken c nm tknId NtfToken {ntfServer, ntfPrivKey} =
   withNtfClient c nm ntfServer tknId "TCHK" $ \ntf -> ntfCheckToken ntf nm ntfPrivKey tknId
 
-agentNtfReplaceToken :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> DeviceToken -> AM ()
+agentNtfReplaceToken :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> ADeviceToken -> AM ()
 agentNtfReplaceToken c nm tknId NtfToken {ntfServer, ntfPrivKey} token =
   withNtfClient c nm ntfServer tknId "TRPL" $ \ntf -> ntfReplaceToken ntf nm ntfPrivKey tknId token
 

src/Simplex/Messaging/Agent/Store/AgentStore.hs

@@ -294,7 +294,7 @@ import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), Ratc
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..), deviceTokenFields, deviceToken')
+import Simplex.Messaging.Notifications.Protocol (ADeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..), deviceToken', deviceTokenFields)
 import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol
@@ -1464,7 +1464,7 @@ updateNtfTokenRegistration db NtfToken {deviceToken, ntfServer = ProtocolServer
     |]
     (tknId, ntfDhSecret, NTRegistered, Nothing :: Maybe NtfTknAction, updatedAt, provider, token, host, port)
 
-updateDeviceToken :: DB.Connection -> NtfToken -> DeviceToken -> IO ()
+updateDeviceToken :: DB.Connection -> NtfToken -> ADeviceToken -> IO ()
 updateDeviceToken db NtfToken {deviceToken, ntfServer = ProtocolServer {host, port}} toDt = do
   let (provider, token) = deviceTokenFields deviceToken
   updatedAt <- getCurrentTime

src/Simplex/Messaging/Notifications/Client.hs

@@ -43,7 +43,7 @@ ntfCheckToken c nm pKey tknId =
     NRTkn stat -> pure stat
     r -> throwE $ unexpectedResponse r
 
-ntfReplaceToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO ()
+ntfReplaceToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> ADeviceToken -> ExceptT NtfClientError IO ()
 ntfReplaceToken c nm pKey tknId token = okNtfCommand (TRPL token) c nm pKey tknId
 
 ntfDeleteToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO ()

src/Simplex/Messaging/Notifications/Protocol.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -27,7 +28,7 @@ import Data.Maybe (isNothing)
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time.Clock.System
 import Data.Type.Equality
-import Data.Word (Word16)
+import Data.Word (Word16, Word64)
 import Simplex.Messaging.Agent.Protocol (updateSMPServerHosts)
 import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_)
 import qualified Simplex.Messaging.Crypto as C
@@ -38,7 +39,6 @@ import Simplex.Messaging.Protocol hiding (Command (..), CommandTag (..))
 import Simplex.Messaging.Util (eitherToMaybe, (<$?>))
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.Binary as Bin
-import qualified Crypto.Error as CE
 import qualified Data.Bits as Bits
 import Network.HTTP.Client (Request, parseUrlThrow)
 
@@ -133,7 +133,7 @@ instance ToJSON NtfRegCode where
   toEncoding = strToJEncoding
 
 data NewNtfEntity (e :: NtfEntity) where
-  NewNtfTkn :: DeviceToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> NewNtfEntity 'Token
+  NewNtfTkn :: ADeviceToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> NewNtfEntity 'Token
   NewNtfSub :: NtfTokenId -> SMPQueueNtf -> NtfPrivateAuthKey -> NewNtfEntity 'Subscription
 
 deriving instance Show (NewNtfEntity e)
@@ -178,7 +178,7 @@ data NtfCommand (e :: NtfEntity) where
   -- | check token status
   TCHK :: NtfCommand 'Token
   -- | replace device token (while keeping all existing subscriptions)
-  TRPL :: DeviceToken -> NtfCommand 'Token
+  TRPL :: ADeviceToken -> NtfCommand 'Token
   -- | delete token - all subscriptions will be removed and no more notifications will be sent
   TDEL :: NtfCommand 'Token
   -- | enable periodic background notification to fetch the new messages - interval is in minutes, minimum is 20, 0 to disable
@@ -378,8 +378,58 @@ instance StrEncoding SMPQueueNtf where
     notifierId <- A.char '/' *> strP
     pure SMPQueueNtf {smpServer, notifierId}
 
-data PushProvider = PPAPNS APNSProvider | PPWP WPProvider
-  deriving (Eq, Ord, Show)
+data PushType = APNS | WebPush deriving (Eq, Ord, Show)
+
+data SPushType (p :: PushType) where
+  SAPNS :: SPushType 'APNS
+  SWebPush :: SPushType 'WebPush
+
+toPushType :: SPushType p -> PushType
+toPushType = \case
+  SAPNS -> APNS
+  SWebPush -> WebPush
+
+deriving instance Show (SPushType p)
+
+class PushTypeI (p :: PushType) where sPushType :: SPushType p
+
+instance PushTypeI 'APNS where sPushType = SAPNS
+
+instance PushTypeI 'WebPush where sPushType = SWebPush
+
+instance TestEquality SPushType where
+  testEquality SAPNS SAPNS = Just Refl
+  testEquality SWebPush SWebPush = Just Refl
+  testEquality _ _ = Nothing
+
+checkPushType :: forall t p p'. (PushTypeI p, PushTypeI p') => t p' -> Either String (t p)
+checkPushType c = case testEquality (sPushType @p) (sPushType @p') of
+  Just Refl -> Right c
+  Nothing -> Left "bad push type"
+
+data PushProvider (p :: PushType) where
+  PPAPNS :: APNSProvider -> PushProvider 'APNS
+  PPWP :: WPProvider -> PushProvider 'WebPush
+
+deriving instance Eq (PushProvider p)
+
+deriving instance Ord (PushProvider p)
+
+deriving instance Show (PushProvider p)
+
+data APushProvider = forall p. PushTypeI p => APP (SPushType p) (PushProvider p)
+
+instance Eq APushProvider where
+  APP pt p == APP pt' p' = case testEquality pt pt' of
+    Just Refl -> p == p'
+    Nothing -> False
+
+instance Ord APushProvider where
+  APP pt t `compare` APP pt' t' = case testEquality pt pt' of
+    Just Refl -> t `compare` t'
+    Nothing -> toPushType pt `compare` toPushType pt'
+
+deriving instance Show APushProvider
 
 data APNSProvider
   = PPApnsDev -- provider for Apple development environment
@@ -394,14 +444,18 @@ newtype WPSrvLoc = WPSrvLoc SrvLoc
 newtype WPProvider = WPP WPSrvLoc
   deriving (Eq, Ord, Show)
 
-instance Encoding PushProvider where
+instance PushTypeI p => Encoding (PushProvider p) where
   smpEncode = \case
     PPAPNS p -> smpEncode p
     PPWP p -> smpEncode p
+  smpP = (\(APP _ p) -> checkPushType p) <$?> smpP
+
+instance Encoding APushProvider where
+  smpEncode (APP _ p) = smpEncode p
   smpP =
     A.peekChar' >>= \case
-      'A' -> PPAPNS <$> smpP
-      _ -> PPWP <$> smpP
+      'A' -> APP SAPNS . PPAPNS <$> smpP
+      _ -> APP SWebPush . PPWP <$> smpP
 
 instance Encoding APNSProvider where
   smpEncode = \case
@@ -417,14 +471,18 @@ instance Encoding APNSProvider where
       "AN" -> pure PPApnsNull
       _ -> fail "bad APNSProvider"
 
-instance StrEncoding PushProvider where
+instance PushTypeI p => StrEncoding (PushProvider p) where
   strEncode = \case
     PPAPNS p -> strEncode p
     PPWP p -> strEncode p
+  strP = (\(APP _ p) -> checkPushType p) <$?> strP
+
+instance StrEncoding APushProvider where
+  strEncode (APP _ p) = strEncode p
   strP =
     A.peekChar' >>= \case
-      'a' -> PPAPNS <$> strP
-      _ -> PPWP <$> strP
+      'a' -> APP SAPNS . PPAPNS <$> strP
+      _ -> APP SWebPush . PPWP <$> strP
 
 instance StrEncoding APNSProvider where
   strEncode = \case
@@ -456,9 +514,9 @@ instance StrEncoding WPProvider where
   strEncode (WPP srv) = "webpush " <> strEncode srv
   strP = WPP <$> ("webpush " *> strP)
 
-instance FromField PushProvider where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
+instance FromField APushProvider where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
 
-instance ToField PushProvider where toField = toField . decodeLatin1 . strEncode
+instance ToField APushProvider where toField = toField . decodeLatin1 . strEncode
 
 newtype WPAuth = WPAuth {unWPAuth :: ByteString} deriving (Eq, Ord, Show)
 
@@ -487,52 +545,50 @@ data WPKey = WPKey
 -- | Elliptic-Curve-Point-to-Octet-String Conversion without compression
 -- | as required by RFC8291
 -- | https://www.secg.org/sec1-v2.pdf#subsubsection.2.3.3
-uncompressEncodePoint :: ECC.Point -> BL.ByteString
+uncompressEncodePoint :: ECC.Point -> ByteString
 uncompressEncodePoint (ECC.Point x y) = "\x04" <> encodeBigInt x <> encodeBigInt y
 uncompressEncodePoint ECC.PointO = "\0"
 
-uncompressDecodePoint :: BL.ByteString -> Either CE.CryptoError ECC.Point
+uncompressDecodePoint :: ByteString -> Either String ECC.Point
 uncompressDecodePoint "\0" = pure ECC.PointO
 uncompressDecodePoint s
-  | BL.take 1 s /= prefix = Left CE.CryptoError_PointFormatUnsupported
-  | BL.length s /= 65 = Left CE.CryptoError_KeySizeInvalid
+  | B.null s = Left "KeySizeInvalid"
+  | B.head s /= '\x04' = Left "PointFormatUnsupported"
+  | B.length s /= 65 = Left "KeySizeInvalid"
   | otherwise = do
-    let s' = BL.drop 1 s
-    x <- decodeBigInt $ BL.take 32 s'
-    y <- decodeBigInt $ BL.drop 32 s'
-    pure $ ECC.Point x y
-  where
-    prefix = "\x04" :: BL.ByteString
+      let s' = B.drop 1 s
+      x <- decodeBigInt $ B.take 32 s'
+      y <- decodeBigInt $ B.drop 32 s'
+      pure $ ECC.Point x y
 
 -- Used to test encryption against the RFC8291 Example - which gives the AS private key
-uncompressDecodePrivateNumber :: BL.ByteString -> Either CE.CryptoError ECC.PrivateNumber
+uncompressDecodePrivateNumber :: ByteString -> Either String ECC.PrivateNumber
 uncompressDecodePrivateNumber s
-  | BL.length s /= 32 = Left CE.CryptoError_KeySizeInvalid
-  | otherwise = do
-    decodeBigInt s
+  | B.length s /= 32 = Left "KeySizeInvalid"
+  | otherwise = decodeBigInt s
 
-uncompressEncode :: WPP256dh -> BL.ByteString
+uncompressEncode :: WPP256dh -> ByteString
 uncompressEncode (WPP256dh p) = uncompressEncodePoint p
 
-uncompressDecode :: BL.ByteString -> Either CE.CryptoError WPP256dh
+uncompressDecode :: ByteString -> Either String WPP256dh
 uncompressDecode bs = WPP256dh <$> uncompressDecodePoint bs
 
-encodeBigInt :: Integer -> BL.ByteString
-encodeBigInt i = do
+encodeBigInt :: Integer -> ByteString
+encodeBigInt i =
   let s1 = Bits.shiftR i 64
       s2 = Bits.shiftR s1 64
       s3 = Bits.shiftR s2 64
-  Bin.encode (w64 s3, w64 s2, w64 s1, w64 i)
+   in BL.toStrict $ Bin.encode (w64 s3, w64 s2, w64 s1, w64 i)
   where
-    w64 :: Integer -> Bin.Word64
+    w64 :: Integer -> Word64
     w64 = fromIntegral
 
-decodeBigInt :: BL.ByteString -> Either CE.CryptoError Integer
+decodeBigInt :: ByteString -> Either String Integer
 decodeBigInt s
-  | BL.length s /= 32 = Left CE.CryptoError_PointSizeInvalid
+  | B.length s /= 32 = Left "PointSizeInvalid"
   | otherwise = do
-      let (w3, w2, w1, w0) = Bin.decode s :: (Bin.Word64, Bin.Word64, Bin.Word64, Bin.Word64 )
-      pure $ shift 3 w3 + shift 2 w2 + shift 1 w1 + shift 0 w0
+      let (w3, w2, w1, w0) = Bin.decode (BL.fromStrict s) :: (Word64, Word64, Word64, Word64)
+       in Right $ shift 3 w3 + shift 2 w2 + shift 1 w1 + fromIntegral w0
   where
     shift i w = Bits.shiftL (fromIntegral w) (64 * i)
 
@@ -551,18 +607,12 @@ instance StrEncoding WPAuth where
   strP = toWPAuth <$?> strP
 
 instance Encoding WPP256dh where
-  smpEncode p = smpEncode . BL.toStrict $ uncompressEncode p
-  smpP = smpP >>= \bs ->
-    case uncompressDecode (BL.fromStrict bs) of
-      Left _ -> fail "Invalid p256dh key"
-      Right res -> pure res
+  smpEncode p = smpEncode $ uncompressEncode p
+  smpP = uncompressDecode <$?> smpP
 
 instance StrEncoding WPP256dh where
-  strEncode p = strEncode . BL.toStrict $ uncompressEncode p
-  strP = strP >>= \bs ->
-    case uncompressDecode (BL.fromStrict bs) of
-      Left _ -> fail "Invalid p256dh key"
-      Right res -> pure res
+  strEncode p = strEncode $ uncompressEncode p
+  strP = uncompressDecode <$?> strP
 
 instance Encoding WPKey where
   smpEncode WPKey {wpAuth, wpP256dh} = smpEncode (wpAuth, wpP256dh)
@@ -592,81 +642,102 @@ instance StrEncoding WPTokenParams where
     wpKey <- strP
     pure WPTokenParams {wpPath, wpKey}
 
-data DeviceToken
-  = APNSDeviceToken APNSProvider ByteString
-  | WPDeviceToken WPProvider WPTokenParams
-  deriving (Eq, Ord, Show)
+data DeviceToken (p :: PushType) where
+  APNSDeviceToken :: APNSProvider -> ByteString -> DeviceToken 'APNS
+  WPDeviceToken :: WPProvider -> WPTokenParams -> DeviceToken 'WebPush
 
-tokenPushProvider :: DeviceToken -> PushProvider
+deriving instance Eq (DeviceToken p)
+
+deriving instance Ord (DeviceToken p)
+
+deriving instance Show (DeviceToken p)
+
+data ADeviceToken = forall p. PushTypeI p => ADT (SPushType p) (DeviceToken p)
+
+instance Eq ADeviceToken where
+  ADT p t == ADT p' t' = case testEquality p p' of
+    Just Refl -> t == t'
+    Nothing -> False
+
+instance Ord ADeviceToken where
+  ADT p t `compare` ADT p' t' = case testEquality p p' of
+    Just Refl -> t `compare` t'
+    Nothing -> toPushType p `compare` toPushType p'
+
+deriving instance Show ADeviceToken
+
+tokenPushProvider :: DeviceToken p -> PushProvider p
 tokenPushProvider = \case
-  APNSDeviceToken pp _ -> PPAPNS pp
-  WPDeviceToken pp _ -> PPWP pp
+  APNSDeviceToken p _ -> PPAPNS p
+  WPDeviceToken p _ -> PPWP p
 
-instance Encoding DeviceToken where
-  smpEncode token = case token of
+instance PushTypeI p => Encoding (DeviceToken p) where
+  smpEncode = \case
     APNSDeviceToken p t -> smpEncode (p, t)
     WPDeviceToken p t -> smpEncode (p, t)
+  smpP = (\(ADT _ t) -> checkPushType t) <$?> smpP
+
+instance Encoding ADeviceToken where
+  smpEncode (ADT _ t) = smpEncode t
   smpP =
     smpP >>= \case
-      PPAPNS p -> APNSDeviceToken p <$> smpP
-      PPWP p -> WPDeviceToken p <$> smpP
+      APP _ (PPAPNS p) -> ADT SAPNS . APNSDeviceToken p <$> smpP
+      APP _ (PPWP p) -> ADT SWebPush . WPDeviceToken p <$> smpP
 
-instance StrEncoding DeviceToken where
+instance PushTypeI p => StrEncoding (DeviceToken p) where
   strEncode token = case token of
     APNSDeviceToken p t -> strEncode p <> " " <> t
     -- We don't do strEncode (p, t), because we don't want any space between
     -- p (e.g. webpush https://localhost) and t.wpPath (e.g /random)
     WPDeviceToken p t -> strEncode p <> strEncode t
+  strP = (\(ADT _ t) -> checkPushType t) <$?> strP
+
+instance StrEncoding ADeviceToken where
+  strEncode (ADT _ t) = strEncode t
   strP = nullToken <|> deviceToken
     where
-      nullToken = "apns_null test_ntf_token" $> APNSDeviceToken PPApnsNull "test_ntf_token"
+      nullToken = "apns_null test_ntf_token" $> ADT SAPNS (APNSDeviceToken PPApnsNull "test_ntf_token")
+      deviceToken :: A.Parser ADeviceToken
       deviceToken =
         strP >>= \case
-          PPAPNS p -> APNSDeviceToken p <$> hexStringP
-          PPWP p -> do
+          APP _ (PPAPNS p) -> ADT SAPNS . APNSDeviceToken p <$> hexStringP
+          APP _ (PPWP p) -> do
             t <- WPDeviceToken p <$> strP
             _ <- wpRequest t
-            pure t
+            pure $ ADT SWebPush t
       hexStringP = do
         _ <- A.space
         A.takeWhile (`B.elem` "0123456789abcdef") >>= \s ->
           if even (B.length s) then pure s else fail "odd number of hex characters"
 
-instance ToJSON DeviceToken where
-  toEncoding token = case token of
+instance ToJSON (DeviceToken 'APNS) where
+  toEncoding = \case
     APNSDeviceToken p t -> J.pairs $ "pushProvider" .= decodeLatin1 (strEncode p) <> "token" .= decodeLatin1 t
-    -- ToJSON/FromJSON isn't used for WPDeviceToken, we just include the pushProvider so it can fail properly if used to decrypt
-    WPDeviceToken p _ -> J.pairs $ "pushProvider" .= decodeLatin1 (strEncode p)
-    -- WPDeviceToken p t -> J.pairs $ "pushProvider" .= decodeLatin1 (strEncode p) <> "token" .= toJSON t
-  toJSON token = case token of
+  toJSON = \case
     APNSDeviceToken p t -> J.object ["pushProvider" .= decodeLatin1 (strEncode p), "token" .= decodeLatin1 t]
-    -- ToJSON/FromJSON isn't used for WPDeviceToken, we just include the pushProvider so it can fail properly if used to decrypt
-    WPDeviceToken p _ -> J.object ["pushProvider" .= decodeLatin1 (strEncode p)]
-    -- WPDeviceToken p t -> J.object ["pushProvider" .= decodeLatin1 (strEncode p), "token" .= toJSON t]
 
-instance FromJSON DeviceToken where
+instance FromJSON (DeviceToken 'APNS) where
   parseJSON = J.withObject "DeviceToken" $ \o ->
-    (strDecode . encodeUtf8 <$?> o .: "pushProvider") >>= \case
+    (strDecode @(PushProvider 'APNS) . encodeUtf8 <$?> o .: "pushProvider") >>= \case
       PPAPNS p -> APNSDeviceToken p . encodeUtf8 <$> (o .: "token")
-      PPWP _ -> fail "FromJSON not implemented for WPDeviceToken"
 
 -- | Returns fields for the device token (pushProvider, token)
 -- TODO [webpush] save token as separate fields
-deviceTokenFields :: DeviceToken -> (PushProvider, ByteString)
-deviceTokenFields dt = case dt of
-  APNSDeviceToken p t -> (PPAPNS p, t)
-  WPDeviceToken p t -> (PPWP p, strEncode t)
+deviceTokenFields :: ADeviceToken -> (APushProvider, ByteString)
+deviceTokenFields = \case
+  ADT _ (APNSDeviceToken p t) -> (APP SAPNS (PPAPNS p), t)
+  ADT _ (WPDeviceToken p t) -> (APP SWebPush (PPWP p), strEncode t)
 
 -- | Returns the device token from the fields (pushProvider, token)
-deviceToken' :: PushProvider -> ByteString -> DeviceToken
+-- TODO [webpush] read token as separate fields, don't use `error`
+deviceToken' :: APushProvider -> ByteString -> ADeviceToken
 deviceToken' pp t = case pp of
-  PPAPNS p -> APNSDeviceToken p t
-  PPWP p -> WPDeviceToken p <$> either error id $ strDecode t
+  APP _ (PPAPNS p) -> ADT SAPNS $ APNSDeviceToken p t
+  APP _ (PPWP p) -> ADT SWebPush . WPDeviceToken p <$> either error id $ strDecode t
 
-wpRequest :: MonadFail m => DeviceToken -> m Request
-wpRequest (APNSDeviceToken _ _) = fail "Invalid device token"
-wpRequest (WPDeviceToken (WPP s) param) = do
-  let endpoint = strEncode s <> wpPath param
+wpRequest :: MonadFail m => DeviceToken 'WebPush -> m Request
+wpRequest (WPDeviceToken (WPP s) params) = do
+  let endpoint = strEncode s <> wpPath params
   case parseUrlThrow $ B.unpack endpoint of
     Left _ -> fail "Invalid URL"
     Right r -> pure r

src/Simplex/Messaging/Notifications/Server.hs

@@ -629,18 +629,18 @@ showServer' = decodeLatin1 . strEncode . host
 
 ntfPush :: NtfPushServer -> M ()
 ntfPush s@NtfPushServer {pushQ} = forever $ do
-  (srvHost_, tkn@NtfTknRec {ntfTknId, token = t, tknStatus}, ntf) <- atomically (readTBQueue pushQ)
-  logDebug $ "sending push notification to " <> tshow (tokenPushProvider t)
+  (srvHost_, tkn@NtfTknRec {ntfTknId, token = t@(ADT _ token), tknStatus}, ntf) <- atomically (readTBQueue pushQ)
+  logDebug $ "sending push notification to " <> tshow (tokenPushProvider token)
   st <- asks store
   case ntf of
     PNVerification _ ->
-      liftIO (deliverNotification st tkn ntf) >>= \case
+      liftIO (deliverNotification st tkn token ntf) >>= \case
         Right _ -> do
           void $ liftIO $ setTknStatusConfirmed st tkn
           incNtfStatT t ntfVrfDelivered
         Left _ -> incNtfStatT t ntfVrfFailed
     PNCheckMessages -> do
-      liftIO (deliverNotification st tkn ntf) >>= \case
+      liftIO (deliverNotification st tkn token ntf) >>= \case
         Right _ -> do
           void $ liftIO $ updateTokenCronSentAt st ntfTknId . systemSeconds =<< getSystemTime
           incNtfStatT t ntfCronDelivered
@@ -648,7 +648,7 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
     PNMessage {} -> checkActiveTkn tknStatus $ do
       stats <- asks serverStats
       liftIO $ updatePeriodStats (activeTokens stats) ntfTknId
-      liftIO (deliverNotification st tkn ntf) >>= \case
+      liftIO (deliverNotification st tkn token ntf) >>= \case
         Left _ -> do
           incNtfStatT t ntfFailed
           liftIO $ mapM_ (`incServerStat` ntfFailedOwn stats) srvHost_
@@ -661,10 +661,10 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
     checkActiveTkn status action
       | status == NTActive = action
       | otherwise = liftIO $ logError "bad notification token status"
-    deliverNotification :: NtfPostgresStore -> NtfTknRec -> PushNotification -> IO (Either PushProviderError ())
-    deliverNotification st tkn@NtfTknRec {ntfTknId, token} ntf = do
+    deliverNotification :: NtfPostgresStore -> NtfTknRec -> DeviceToken p -> PushNotification -> IO (Either PushProviderError ())
+    deliverNotification st tkn@NtfTknRec {ntfTknId} token ntf = do
       deliver <- getPushClient s pp
-      runExceptT (deliver tkn ntf) >>= \case
+      runExceptT (deliver tkn token ntf) >>= \case
         Right _ -> pure $ Right ()
         Left e -> case e of
           PPConnection _ -> retryDeliver
@@ -675,14 +675,13 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
             void $ updateTknStatus st tkn $ NTInvalid $ Just r
             err e
           PPPermanentError -> err e
-          PPInvalidPusher -> err e
           _ -> err e
       where
         pp = tokenPushProvider token
         retryDeliver :: IO (Either PushProviderError ())
         retryDeliver = do
           deliver <- newPushClient s pp
-          runExceptT (deliver tkn ntf) >>= \case
+          runExceptT (deliver tkn token ntf) >>= \case
             Right _ -> pure $ Right ()
             Left e -> case e of
               PPTokenInvalid r -> do
@@ -907,8 +906,9 @@ withNtfStore stAction continue = do
     Left e -> pure $ NRErr e
     Right a -> continue a
 
-incNtfStatT :: DeviceToken -> (NtfServerStats -> IORef Int) -> M ()
-incNtfStatT (APNSDeviceToken PPApnsNull _) _ = pure ()
+-- TODO [webpush] track webpush statistics separately
+incNtfStatT :: ADeviceToken -> (NtfServerStats -> IORef Int) -> M ()
+incNtfStatT (ADT _ (APNSDeviceToken PPApnsNull _)) _ = pure ()
 incNtfStatT _ statSel = incNtfStat statSel
 {-# INLINE incNtfStatT #-}
 

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

@@ -152,35 +152,38 @@ data SMPSubscriber = SMPSubscriber
 
 data NtfPushServer = NtfPushServer
   { pushQ :: TBQueue (Maybe T.Text, NtfTknRec, PushNotification), -- Maybe Text is a hostname of "own" server
-    pushClients :: TMap PushProvider PushProviderClient,
+    apnsPushClients :: TMap APNSProvider (PushProviderClient 'APNS),
+    webPushClients :: TMap WPProvider (PushProviderClient 'WebPush),
     apnsConfig :: APNSPushClientConfig
   }
 
 newNtfPushServer :: Natural -> APNSPushClientConfig -> IO NtfPushServer
 newNtfPushServer qSize apnsConfig = do
   pushQ <- newTBQueueIO qSize
-  pushClients <- TM.emptyIO
-  pure NtfPushServer {pushQ, pushClients, apnsConfig}
+  apnsPushClients <- TM.emptyIO
+  webPushClients <- TM.emptyIO
+  pure NtfPushServer {pushQ, apnsPushClients, webPushClients, apnsConfig}
 
-newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
-newPushClient s pp = do
-  c <- case pp of
-    PPWP p -> newWPPushClient s p
-    PPAPNS p -> newAPNSPushClient s p
-  atomically $ TM.insert pp c $ pushClients s
-  pure c
+newPushClient :: NtfPushServer -> PushProvider p -> IO (PushProviderClient p)
+newPushClient s = \case
+  PPWP p -> newWPPushClient s p
+  PPAPNS p -> newAPNSPushClient s p
 
-newAPNSPushClient :: NtfPushServer -> APNSProvider -> IO PushProviderClient
-newAPNSPushClient NtfPushServer {apnsConfig, pushClients} pp = do
-  case apnsProviderHost pp of
-    Nothing -> pure $ \_ _ -> pure ()
-    Just host -> apnsPushProviderClient <$> createAPNSPushClient host apnsConfig
+newAPNSPushClient :: NtfPushServer -> APNSProvider -> IO (PushProviderClient 'APNS)
+newAPNSPushClient NtfPushServer {apnsConfig, apnsPushClients} pp = case apnsProviderHost pp of
+  Nothing -> pure $ \_ _ _ -> pure ()
+  Just host -> do
+    c <- apnsPushProviderClient <$> createAPNSPushClient host apnsConfig
+    atomically $ TM.insert pp c apnsPushClients
+    pure c
 
-newWPPushClient :: NtfPushServer -> WPProvider -> IO PushProviderClient
-newWPPushClient NtfPushServer {pushClients} pp = do
+newWPPushClient :: NtfPushServer -> WPProvider -> IO (PushProviderClient 'WebPush)
+newWPPushClient NtfPushServer {webPushClients} pp = do
   logDebug "New WP Client requested"
   -- We use one http manager per push server (which may be used by different clients)
-  wpPushProviderClient <$> wpHTTPManager
+  c <- wpPushProviderClient <$> wpHTTPManager
+  atomically $ TM.insert pp c webPushClients
+  pure c
 
 wpHTTPManager :: IO Manager
 wpHTTPManager = newManager tlsManagerSettings {
@@ -191,9 +194,10 @@ wpHTTPManager = newManager tlsManagerSettings {
     managerModifyRequest = \r -> pure r {redirectCount = 0}
   }
 
-getPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
-getPushClient s@NtfPushServer {pushClients} pp =
-  TM.lookupIO pp pushClients >>= maybe (newPushClient s pp) pure
+getPushClient :: NtfPushServer -> PushProvider p -> IO (PushProviderClient p)
+getPushClient s = \case
+  PPAPNS p -> TM.lookupIO p (apnsPushClients s) >>= maybe (newAPNSPushClient s p) pure
+  PPWP p -> TM.lookupIO p (webPushClients s) >>= maybe (newWPPushClient s p) pure
 
 data NtfRequest
   = NtfReqNew CorrId ANewNtfEntity

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

@@ -36,7 +36,6 @@ 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
   { alg :: Text, -- key algorithm, ES256 for APNS
@@ -94,11 +93,10 @@ data PushProviderError
   | PPTokenInvalid NTInvalidReason
   | PPRetryLater
   | PPPermanentError
-  | PPInvalidPusher
   | PPWPInvalidUrl
   | PPWPRemovedEndpoint
   | PPWPRequestTooLong
-  | PPWPOtherError SomeException
+  | PPWPOtherError Text
   deriving (Show, Exception)
 
-type PushProviderClient = NtfTknRec -> PushNotification -> ExceptT PushProviderError IO ()
+type PushProviderClient p = NtfTknRec -> DeviceToken p -> PushNotification -> ExceptT PushProviderError IO ()

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

@@ -1,5 +1,7 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -255,10 +257,8 @@ data APNSErrorResponse = APNSErrorResponse {reason :: Text}
 
 $(JQ.deriveFromJSON defaultJSON ''APNSErrorResponse)
 
--- TODO [webpush] change type accept token components so it only allows APNS token
-apnsPushProviderClient :: APNSPushClient -> PushProviderClient
-apnsPushProviderClient _ NtfTknRec {token = WPDeviceToken _ _} _ = throwE PPInvalidPusher
-apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknRec {token = APNSDeviceToken _ tknStr} pn = do
+apnsPushProviderClient :: APNSPushClient -> PushProviderClient 'APNS
+apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn (APNSDeviceToken _ tknStr) pn = do
   http2 <- liftHTTPS2 $ getApnsHTTP2Client c
   nonce <- atomically $ C.randomCbNonce nonceDrg
   apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn

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

@@ -1,4 +1,6 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -8,39 +10,37 @@
 
 module Simplex.Messaging.Notifications.Server.Push.WebPush where
 
-import Network.HTTP.Client
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), WPAuth (..), WPKey (..), WPTokenParams (..), WPP256dh (..), uncompressEncodePoint, wpRequest)
-import Simplex.Messaging.Notifications.Server.Store.Types
-import Simplex.Messaging.Notifications.Server.Push
-import Control.Monad.Except
+import Control.Exception (SomeException, fromException, try)
 import Control.Logger.Simple (logDebug)
-import Simplex.Messaging.Util (tshow)
-import qualified Data.ByteString.Char8 as B
+import Control.Monad
+import Control.Monad.Except
 import Control.Monad.IO.Class (liftIO)
-import Control.Exception ( fromException, SomeException, try )
-import qualified Network.HTTP.Types as N
-import qualified Data.Aeson as J
-import Data.Aeson ((.=))
-import qualified Data.Binary as Bin
-import qualified Data.ByteArray as BA
-import qualified Data.ByteString.Lazy as BL
-import Control.Monad.Trans.Except (throwE)
 import Crypto.Hash.Algorithms (SHA256)
-import Crypto.Random (MonadRandom(getRandomBytes))
-import qualified Crypto.Cipher.Types as CT
 import qualified Crypto.MAC.HMAC as HMAC
 import qualified Crypto.PubKey.ECC.DH as ECDH
 import qualified Crypto.PubKey.ECC.Types as ECC
+import Crypto.Random (MonadRandom(getRandomBytes))
+import Data.Aeson ((.=))
+import qualified Data.Aeson as J
+import qualified Data.Binary as Bin
+import qualified Data.ByteArray as BA
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy as BL
+import Network.HTTP.Client
+import qualified Network.HTTP.Types as N
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), PushType (..), WPAuth (..), WPKey (..), WPTokenParams (..), WPP256dh (..), uncompressEncodePoint, wpRequest)
+import Simplex.Messaging.Notifications.Server.Push
+import Simplex.Messaging.Util (liftError', tshow)
 
-wpPushProviderClient :: Manager -> PushProviderClient
-wpPushProviderClient _ NtfTknRec {token = APNSDeviceToken _ _} _ = throwE PPInvalidPusher
-wpPushProviderClient mg NtfTknRec {token = token@(WPDeviceToken _ param)} pn = do
+wpPushProviderClient :: Manager -> PushProviderClient 'WebPush
+wpPushProviderClient mg _ t@(WPDeviceToken _ params) pn = do
   -- TODO [webpush] this function should accept type that is restricted to WP token (so, possibly WPProvider and WPTokenParams)
   -- parsing will happen in DeviceToken parser, so it won't fail here
-  r <- wpRequest token
-  logDebug $ "Request to " <> tshow (host r)
-  encBody <- body
+  r <- wpRequest t
+  logDebug $ "Web Push request to " <> tshow (host r)
+  encBody <- withExceptT PPCryptoError $ wpEncrypt (wpKey params) (BL.toStrict $ encodeWPN pn)
   let requestHeaders =
         [ ("TTL", "2592000"), -- 30 days
           ("Urgency", "high"),
@@ -54,55 +54,47 @@ wpPushProviderClient mg NtfTknRec {token = token@(WPDeviceToken _ param)} pn = d
             requestBody = RequestBodyBS encBody,
             redirectCount = 0
           }
-  _ <- liftPPWPError $ httpNoBody req mg
-  pure ()
-  where
-    body :: ExceptT PushProviderError IO B.ByteString
-    body = withExceptT PPCryptoError $ wpEncrypt (wpKey param) (BL.toStrict $ encodeWPN pn)
+  void $ liftError' toPPWPError $ try $ httpNoBody req mg
 
 -- | encrypt :: UA key -> clear -> cipher
 -- | https://www.rfc-editor.org/rfc/rfc8291#section-3.4
-wpEncrypt :: WPKey -> B.ByteString -> ExceptT C.CryptoError IO B.ByteString
+wpEncrypt :: WPKey -> ByteString -> ExceptT C.CryptoError IO ByteString
 wpEncrypt wpKey clearT = do
-  salt :: B.ByteString <- liftIO $ getRandomBytes 16
+  salt :: ByteString <- liftIO $ getRandomBytes 16
   asPrivK <- liftIO $ ECDH.generatePrivate $ ECC.getCurveByName ECC.SEC_p256r1
   wpEncrypt' wpKey asPrivK salt clearT
 
 -- | encrypt :: UA key -> AS key -> salt -> clear -> cipher
 -- | https://www.rfc-editor.org/rfc/rfc8291#section-3.4
-wpEncrypt' :: WPKey -> ECC.PrivateNumber -> B.ByteString -> B.ByteString -> ExceptT C.CryptoError IO B.ByteString
+wpEncrypt' :: WPKey -> ECC.PrivateNumber -> ByteString -> ByteString -> ExceptT C.CryptoError IO ByteString
 wpEncrypt' WPKey {wpAuth, wpP256dh = WPP256dh uaPubK} asPrivK salt clearT = do
-  let uaPubKS = BL.toStrict . uncompressEncodePoint $ uaPubK
-  let asPubKS = BL.toStrict . uncompressEncodePoint . ECDH.calculatePublic (ECC.getCurveByName ECC.SEC_p256r1) $ asPrivK
+  let uaPubKS = uncompressEncodePoint $ uaPubK
+  let asPubKS = uncompressEncodePoint . ECDH.calculatePublic (ECC.getCurveByName ECC.SEC_p256r1) $ asPrivK
       ecdhSecret = ECDH.getShared (ECC.getCurveByName ECC.SEC_p256r1) asPrivK uaPubK
       prkKey = hmac (unWPAuth wpAuth) ecdhSecret
       keyInfo = "WebPush: info\0" <> uaPubKS <> asPubKS
       ikm = hmac prkKey (keyInfo <> "\x01")
       prk = hmac salt ikm
-      cekInfo = "Content-Encoding: aes128gcm\0" :: B.ByteString
-      cek = takeHM 16 $ hmac prk (cekInfo <> "\x01")
-      nonceInfo = "Content-Encoding: nonce\0" :: B.ByteString
-      nonce = takeHM 12 $ hmac prk (nonceInfo <> "\x01")
+      cekInfo = "Content-Encoding: aes128gcm\0" :: ByteString
+      cek = B.take 16 $ BA.convert $ hmac prk (cekInfo <> "\x01")
+      nonceInfo = "Content-Encoding: nonce\0" :: ByteString
+      nonce = B.take 12 $ BA.convert $ hmac prk (nonceInfo <> "\x01")
       rs = BL.toStrict $ Bin.encode (4096 :: Bin.Word32) -- with RFC8291, it's ok to always use 4096 because there is only one single record and the final record can be smaller than rs (RFC8188)
       idlen = BL.toStrict $ Bin.encode (65 :: Bin.Word8) -- with RFC8291, keyid is the pubkey, so always 65 bytes
       header = salt <> rs <> idlen <> asPubKS
   iv <- ivFrom nonce
   -- The last record uses a padding delimiter octet set to the value 0x02
-  (C.AuthTag (CT.AuthTag tag), cipherT) <- C.encryptAES128NoPad (C.Key cek) iv $ clearT <> "\x02"
+  (C.AuthTag tag, cipherT) <- C.encryptAES128NoPad (C.Key cek) iv $ clearT <> "\x02"
   -- Uncomment to see intermediate values, to compare with RFC8291 example
-  -- liftIO . print $ strEncode (BA.convert ecdhSecret :: B.ByteString)
+  -- liftIO . print $ strEncode (BA.convert ecdhSecret :: ByteString)
   -- liftIO . print . strEncode $ takeHM 32 prkKey
   -- liftIO . print $ strEncode cek
   -- liftIO . print $ strEncode cipherT
   pure $ header <> cipherT <> BA.convert tag
   where
     hmac k v = HMAC.hmac k v :: HMAC.HMAC SHA256
-    takeHM :: Int -> HMAC.HMAC SHA256 -> B.ByteString
-    takeHM n v = BL.toStrict $ BL.pack $ take n $ BA.unpack v
-    ivFrom :: B.ByteString -> ExceptT C.CryptoError IO C.GCMIV
-    ivFrom s = case C.gcmIV s of
-      Left e -> throwE e
-      Right iv -> pure iv
+    ivFrom :: ByteString -> ExceptT C.CryptoError IO C.GCMIV
+    ivFrom s = liftEither $ C.gcmIV s
 
 encodeWPN :: PushNotification -> BL.ByteString
 encodeWPN pn = J.encode $ case pn of
@@ -113,17 +105,11 @@ encodeWPN pn = J.encode $ case pn of
   PNMessage _ -> J.object ["checkMessages" .= True]
   PNCheckMessages -> J.object ["checkMessages" .= True]
 
-liftPPWPError :: IO a -> ExceptT PushProviderError IO a
-liftPPWPError = liftPPWPError' toPPWPError
-
-liftPPWPError' :: (SomeException -> PushProviderError) -> IO a -> ExceptT PushProviderError IO a
-liftPPWPError' err a = liftIO (try @SomeException a) >>= either (throwError . err) return
-
 toPPWPError :: SomeException -> PushProviderError
 toPPWPError e = case fromException e of
     Just (InvalidUrlException _ _) -> PPWPInvalidUrl
     Just (HttpExceptionRequest _ (StatusCodeException resp _)) -> fromStatusCode (responseStatus resp) ("" :: String)
-    _ -> PPWPOtherError e
+    _ -> PPWPOtherError $ tshow e
   where
     fromStatusCode status reason
       | status == N.status200 = PPWPRemovedEndpoint

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

@@ -33,7 +33,7 @@ import Simplex.Messaging.Util (whenM, ($>>=))
 data NtfSTMStore = NtfSTMStore
   { tokens :: TMap NtfTokenId NtfTknData,
     -- multiple registrations exist to protect from malicious registrations if token is compromised
-    tokenRegistrations :: TMap DeviceToken (TMap ByteString NtfTokenId),
+    tokenRegistrations :: TMap ADeviceToken (TMap ByteString NtfTokenId),
     subscriptions :: TMap NtfSubscriptionId NtfSubData,
     tokenSubscriptions :: TMap NtfTokenId (TVar (Set NtfSubscriptionId)),
     subscriptionLookup :: TMap SMPQueueNtf NtfSubscriptionId,
@@ -54,7 +54,7 @@ newNtfSTMStore = do
 
 data NtfTknData = NtfTknData
   { ntfTknId :: NtfTokenId,
-    token :: DeviceToken,
+    token :: ADeviceToken,
     tknStatus :: TVar NtfTknStatus,
     tknVerifyKey :: NtfPublicAuthKey,
     tknDhKeys :: C.KeyPairX25519,

src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs

@@ -172,7 +172,7 @@ updateTokenDate st db NtfTknRec {ntfTknId, tknUpdatedAt} = do
     void $ DB.execute db "UPDATE tokens SET updated_at = ? WHERE token_id = ?" (ts, ntfTknId)
     withLog "updateTokenDate" st $ \sl -> logUpdateTokenTime sl ntfTknId ts
 
-type NtfTknRow = (NtfTokenId, PushProvider, Binary ByteString, NtfTknStatus, NtfPublicAuthKey, C.PrivateKeyX25519, C.DhSecretX25519, Binary ByteString, Word16, Maybe SystemDate)
+type NtfTknRow = (NtfTokenId, APushProvider, Binary ByteString, NtfTknStatus, NtfPublicAuthKey, C.PrivateKeyX25519, C.DhSecretX25519, Binary ByteString, Word16, Maybe SystemDate)
 
 ntfTknQuery :: Query
 ntfTknQuery =

src/Simplex/Messaging/Notifications/Server/Store/Types.hs

@@ -13,14 +13,14 @@ import Data.Maybe (fromMaybe)
 import Data.Word (Word16)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode, NtfSubStatus, NtfSubscriptionId, NtfTokenId, NtfTknStatus, SMPQueueNtf)
+import Simplex.Messaging.Notifications.Protocol (ADeviceToken, NtfRegCode, NtfSubStatus, NtfSubscriptionId, NtfTokenId, NtfTknStatus, SMPQueueNtf)
 import Simplex.Messaging.Notifications.Server.Store (NtfSubData (..), NtfTknData (..))
 import Simplex.Messaging.Protocol (NotifierId, NtfPrivateAuthKey, NtfPublicAuthKey)
 import Simplex.Messaging.SystemTime
 
 data NtfTknRec = NtfTknRec
   { ntfTknId :: NtfTokenId,
-    token :: DeviceToken,
+    token :: ADeviceToken,
     tknStatus :: NtfTknStatus,
     tknVerifyKey :: NtfPublicAuthKey,
     tknDhPrivKey :: C.PrivateKeyX25519,

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

@@ -46,7 +46,7 @@ import System.IO
 data NtfStoreLogRecord
   = CreateToken NtfTknRec
   | TokenStatus NtfTokenId NtfTknStatus
-  | UpdateToken NtfTokenId DeviceToken NtfRegCode
+  | UpdateToken NtfTokenId ADeviceToken NtfRegCode
   | TokenCron NtfTokenId Word16
   | DeleteToken NtfTokenId
   | UpdateTokenTime NtfTokenId SystemDate
@@ -94,7 +94,7 @@ logCreateToken s = logNtfStoreRecord s . CreateToken
 logTokenStatus :: StoreLog 'WriteMode -> NtfTokenId -> NtfTknStatus -> IO ()
 logTokenStatus s tknId tknStatus = logNtfStoreRecord s $ TokenStatus tknId tknStatus
 
-logUpdateToken :: StoreLog 'WriteMode -> NtfTokenId -> DeviceToken -> NtfRegCode -> IO ()
+logUpdateToken :: StoreLog 'WriteMode -> NtfTokenId -> ADeviceToken -> NtfRegCode -> IO ()
 logUpdateToken s tknId token regCode = logNtfStoreRecord s $ UpdateToken tknId token regCode
 
 logTokenCron :: StoreLog 'WriteMode -> NtfTokenId -> Word16 -> IO ()

src/Simplex/Messaging/Notifications/Types.hs

@@ -42,7 +42,7 @@ instance FromField NtfTknAction where fromField = blobFieldDecoder smpDecode
 instance ToField NtfTknAction where toField = toField . Binary . smpEncode
 
 data NtfToken = NtfToken
-  { deviceToken :: DeviceToken,
+  { deviceToken :: ADeviceToken,
     ntfServer :: NtfServer,
     ntfTokenId :: Maybe NtfTokenId,
     -- TODO combine keys to key pair as the types should match
@@ -63,7 +63,7 @@ data NtfToken = NtfToken
   }
   deriving (Show)
 
-newNtfToken :: DeviceToken -> NtfServer -> C.AAuthKeyPair -> C.KeyPairX25519 -> NotificationsMode -> NtfToken
+newNtfToken :: ADeviceToken -> NtfServer -> C.AAuthKeyPair -> C.KeyPairX25519 -> NotificationsMode -> NtfToken
 newNtfToken deviceToken ntfServer (ntfPubKey, ntfPrivKey) ntfDhKeys ntfMode =
   NtfToken
     { deviceToken,

tests/AgentTests/NotificationTests.hs

@@ -196,13 +196,13 @@ testNtfMatrix ps@(_, msType) runTest = do
     cfg' = cfgMS msType
     cfgVPrev' = cfgVPrev msType
 
-registerNtfToken :: AgentClient -> DeviceToken -> NotificationsMode -> AE NtfTknStatus
+registerNtfToken :: AgentClient -> ADeviceToken -> NotificationsMode -> AE NtfTknStatus
 registerNtfToken c = A.registerNtfToken c NRMInteractive
 
-checkNtfToken :: AgentClient -> DeviceToken -> AE NtfTknStatus
+checkNtfToken :: AgentClient -> ADeviceToken -> AE NtfTknStatus
 checkNtfToken c = A.checkNtfToken c NRMInteractive
 
-verifyNtfToken :: AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> AE ()
+verifyNtfToken :: AgentClient -> ADeviceToken -> C.CbNonce -> ByteString -> AE ()
 verifyNtfToken c = A.verifyNtfToken c NRMInteractive
 
 runNtfTestCfg :: HasCallStack => (ASrvTransport, AStoreType) -> AgentMsgId -> AServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO ()
@@ -218,7 +218,7 @@ runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do
 testNotificationToken :: APNSMockServer -> IO ()
 testNotificationToken apns = do
   withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do
-    let tkn = APNSDeviceToken PPApnsTest "abcd"
+    let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
     NTRegistered <- registerNtfToken a tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
       getMockNotification apns tkn
@@ -242,7 +242,7 @@ v .-> key = do
 testNtfTokenRepeatRegistration :: APNSMockServer -> IO ()
 testNtfTokenRepeatRegistration apns = do
   withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do
-    let tkn = APNSDeviceToken PPApnsTest "abcd"
+    let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
     NTRegistered <- registerNtfToken a tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
       getMockNotification apns tkn
@@ -261,7 +261,7 @@ testNtfTokenRepeatRegistration apns = do
 testNtfTokenSecondRegistration :: APNSMockServer -> IO ()
 testNtfTokenSecondRegistration apns =
   withAgentClients2 $ \a a' -> runRight_ $ do
-    let tkn = APNSDeviceToken PPApnsTest "abcd"
+    let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
     NTRegistered <- registerNtfToken a tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
       getMockNotification apns tkn
@@ -290,7 +290,7 @@ testNtfTokenSecondRegistration apns =
 
 testNtfTokenServerRestart :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestart t apns = do
-  let tkn = APNSDeviceToken PPApnsTest "abcd"
+  let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
   ntfData <- withAgent 1 agentCfg initAgentServers testDB $ \a ->
     withNtfServer t $ runRight $ do
       NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -311,7 +311,7 @@ testNtfTokenServerRestart t apns = do
 
 testNtfTokenServerRestartReverify :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestartReverify t apns = do
-  let tkn = APNSDeviceToken PPApnsTest "abcd"
+  let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
   withAgent 1 agentCfg initAgentServers testDB $ \a -> do
     ntfData <- withNtfServer t $ runRight $ do
       NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -334,7 +334,7 @@ testNtfTokenServerRestartReverify t apns = do
 
 testNtfTokenServerRestartReverifyTimeout :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestartReverifyTimeout t apns = do
-  let tkn = APNSDeviceToken PPApnsTest "abcd"
+  let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
   withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do
     (nonce, verification) <- withNtfServer t $ runRight $ do
       NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -355,7 +355,7 @@ testNtfTokenServerRestartReverifyTimeout t apns = do
           SET tkn_status = ?, tkn_action = ?
           WHERE provider = ? AND device_token = ?
         |]
-        (NTConfirmed, Just (NTAVerify code), PPAPNS PPApnsTest, "abcd" :: ByteString)
+        (NTConfirmed, Just (NTAVerify code), APP SAPNS (PPAPNS PPApnsTest), "abcd" :: ByteString)
     Just NtfToken {ntfTknStatus = NTConfirmed, ntfTknAction = Just (NTAVerify _)} <- withTransaction store getSavedNtfToken
     pure ()
   threadDelay 1500000
@@ -369,7 +369,7 @@ testNtfTokenServerRestartReverifyTimeout t apns = do
 
 testNtfTokenServerRestartReregister :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestartReregister t apns = do
-  let tkn = APNSDeviceToken PPApnsTest "abcd"
+  let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
   withAgent 1 agentCfg initAgentServers testDB $ \a ->
     withNtfServer t $ runRight $ do
       NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -393,7 +393,7 @@ testNtfTokenServerRestartReregister t apns = do
 
 testNtfTokenServerRestartReregisterTimeout :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestartReregisterTimeout t apns = do
-  let tkn = APNSDeviceToken PPApnsTest "abcd"
+  let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
   withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do
     withNtfServer t $ runRight $ do
       NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -409,7 +409,7 @@ testNtfTokenServerRestartReregisterTimeout t apns = do
           SET tkn_id = NULL, tkn_dh_secret = NULL, tkn_status = ?, tkn_action = ?
           WHERE provider = ? AND device_token = ?
         |]
-        (NTNew, Just NTARegister, PPAPNS PPApnsTest, "abcd" :: ByteString)
+        (NTNew, Just NTARegister, APP SAPNS (PPAPNS PPApnsTest), "abcd" :: ByteString)
     Just NtfToken {ntfTokenId = Nothing, ntfTknStatus = NTNew, ntfTknAction = Just NTARegister} <- withTransaction store getSavedNtfToken
     pure ()
   threadDelay 1000000
@@ -434,7 +434,7 @@ getTestNtfTokenPort a =
 
 testNtfTokenMultipleServers :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenMultipleServers t apns = do
-  let tkn = APNSDeviceToken PPApnsTest "abcd"
+  let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
   withAgent 1 agentCfg initAgentServers2 testDB $ \a ->
     withNtfServerThreadOn t ntfTestPort ntfTestDBCfg $ \ntf ->
       withNtfServerThreadOn t ntfTestPort2 ntfTestDBCfg2 $ \ntf2 -> runRight_ $ do
@@ -554,7 +554,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag
     get alice ##> ("", bobId, CON)
     get bob ##> ("", aliceId, CON)
     -- register notification token
-    let tkn = APNSDeviceToken PPApnsTest "abcd"
+    let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
     NTRegistered <- registerNtfToken alice tkn NMInstant
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
       getMockNotification apns tkn
@@ -607,9 +607,9 @@ testNotificationSubscriptionNewConnection :: HasCallStack => APNSMockServer -> A
 testNotificationSubscriptionNewConnection apns baseId alice bob =
   runRight_ $ do
     -- alice registers notification token
-    APNSDeviceToken {} <- registerTestToken alice "abcd" NMInstant apns
+    ADT _ APNSDeviceToken {} <- registerTestToken alice "abcd" NMInstant apns
     -- bob registers notification token
-    APNSDeviceToken {} <- registerTestToken bob "bcde" NMInstant apns
+    ADT _ APNSDeviceToken {} <- registerTestToken bob "bcde" NMInstant apns
     -- establish connection
     liftIO $ threadDelay 50000
     (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
@@ -643,9 +643,9 @@ testNotificationSubscriptionNewConnection apns baseId alice bob =
   where
     msgId = subtract baseId
 
-registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> APNSMockServer -> ExceptT AgentErrorType IO DeviceToken
+registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> APNSMockServer -> ExceptT AgentErrorType IO ADeviceToken
 registerTestToken a token mode apns = do
-  let tkn = APNSDeviceToken PPApnsTest token
+  let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest token
   NTRegistered <- registerNtfToken a tkn mode
   Just APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <-
     timeout 1000000 $ getMockNotification apns tkn
@@ -1023,7 +1023,7 @@ testMessage_ apns a aId b bId msg = do
   get a =##> \case ("", c, Msg msg') -> c == bId && msg == msg'; _ -> False
   ackMessage a bId msgId Nothing
 
-messageNotification :: HasCallStack => APNSMockServer -> DeviceToken -> ExceptT AgentErrorType IO (C.CbNonce, ByteString)
+messageNotification :: HasCallStack => APNSMockServer -> ADeviceToken -> ExceptT AgentErrorType IO (C.CbNonce, ByteString)
 messageNotification apns tkn = do
   500000 `timeout` getMockNotification apns tkn >>= \case
     Nothing -> error "no notification"

tests/NtfClient.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
@@ -41,7 +42,7 @@ import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost,
 import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
-import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfResponse)
+import Simplex.Messaging.Notifications.Protocol (ADeviceToken (..), DeviceToken (..), NtfResponse)
 import Simplex.Messaging.Notifications.Server (runNtfServerBlocking)
 import Simplex.Messaging.Notifications.Server.Env
 import Simplex.Messaging.Notifications.Server.Push.APNS
@@ -293,9 +294,9 @@ getAPNSMockServer config@HTTP2ServerConfig {qSize} = do
           putStrLn $ "runAPNSMockServer J.decodeStrict' error, reqBody: " <> show bodyHead
           sendApnsResponse $ APNSRespError N.badRequest400 "bad_request_body"
 
-getMockNotification :: MonadIO m => APNSMockServer -> DeviceToken -> m APNSMockRequest
-getMockNotification _ (WPDeviceToken _ _) = liftIO . throwIO $ userError "Invalid pusher"
-getMockNotification APNSMockServer {notifications} (APNSDeviceToken _ token) = do
+getMockNotification :: MonadIO m => APNSMockServer -> ADeviceToken -> m APNSMockRequest
+getMockNotification _ (ADT _ WPDeviceToken {}) = liftIO . throwIO $ userError "Invalid pusher"
+getMockNotification APNSMockServer {notifications} (ADT _ (APNSDeviceToken _ token)) = do
   atomically $ TM.lookup token notifications >>= maybe retry readTBQueue
 
 getAnyMockNotification :: MonadIO m => APNSMockServer -> m APNSMockRequest

tests/NtfServerTests.hs

@@ -107,7 +107,7 @@ testNotificationSubscription (ATransport t, msType) createQueue =
     (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
     (tknPub, tknKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
     (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
-    let tkn = APNSDeviceToken PPApnsTest "abcd"
+    let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
     withAPNSMockServer $ \apns ->
       smpTest2 t msType $ \rh sh ->
         ntfTest t $ \nh -> do
@@ -160,7 +160,7 @@ testNotificationSubscription (ATransport t, msType) createQueue =
           (msgBody, "hello") #== "delivered from queue"
           Resp "6" _ OK <- signSendRecv rh rKey ("6", rId, ACK mId1)
           -- replace token
-          let tkn' = APNSDeviceToken PPApnsTest "efgh"
+          let tkn' = ADT SAPNS $ APNSDeviceToken PPApnsTest "efgh"
           RespNtf "7" tId' NROk <- signSendRecvNtf nh tknKey ("7", tId, TRPL tkn')
           tId `shouldBe` tId'
           APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData2}} <-
@@ -237,7 +237,7 @@ registerToken nh apns token = do
   g <- C.newRandom
   (tknPub, tknKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
   (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
-  let tkn = APNSDeviceToken PPApnsTest token
+  let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest token
   RespNtf "1" NoEntity (NRTknId tId ntfDh) <- signSendRecvNtf nh tknKey ("1", NoEntity, TNEW $ NewNtfTkn tkn tknPub dhPub)
   APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
     getMockNotification apns tkn

tests/NtfWPTests.hs

@@ -34,7 +34,7 @@ testWPDeviceTokenStrEncoding = do
 
   let auth = either error id $ strDecode "AQ3VfRX3_F38J3ltcmMVRg"
   let pk = either error id $ strDecode "BKuw4WxupnnrZHqk6vCwoms4tOpitZMvFdR9eAn54yOPY4q9jpXOpl-Ui_FwbIy8ZbFCnuaS7RnO02ahuL4XxIM"
-  let params ::WPTokenParams = either error id $ strDecode "/secret AQ3VfRX3_F38J3ltcmMVRg BKuw4WxupnnrZHqk6vCwoms4tOpitZMvFdR9eAn54yOPY4q9jpXOpl-Ui_FwbIy8ZbFCnuaS7RnO02ahuL4XxIM"
+  let params :: WPTokenParams = either error id $ strDecode "/secret AQ3VfRX3_F38J3ltcmMVRg BKuw4WxupnnrZHqk6vCwoms4tOpitZMvFdR9eAn54yOPY4q9jpXOpl-Ui_FwbIy8ZbFCnuaS7RnO02ahuL4XxIM"
   wpPath params `shouldBe` "/secret"
   let key = wpKey params
   wpAuth key `shouldBe` auth
@@ -55,7 +55,7 @@ testInvalidWPDeviceTokenStrEncoding = do
   -- e.g "https://#1" is a valid URL. But that is the same parser
   -- we use to send the requests, so that's fine.
   let ts = "webpush https://localhost:/ AQ3VfRX3_F38J3ltcmMVRg BKuw4WxupnnrZHqk6vCwoms4tOpitZMvFdR9eAn54yOPY4q9jpXOpl-Ui_FwbIy8ZbFCnuaS7RnO02ahuL4XxIM"
-  let t = strDecode ts :: Either String DeviceToken
+  let t = strDecode ts :: Either String ADeviceToken
   t `shouldSatisfy` isLeft
 
 -- | Example from RFC8291
@@ -64,7 +64,7 @@ testWPEncryption = do
   let clearT :: B.ByteString = "When I grow up, I want to be a watermelon"
   let pParams :: WPTokenParams = either error id $ strDecode "/push/JzLQ3raZJfFBR0aqvOMsLrt54w4rJUsV BTBZMqHH6r4Tts7J_aSIgg BCVxsr7N_eNgVRqvHtD0zTZsEc6-VV-JvLexhqUzORcxaOzi6-AYWXvTBHm4bjyPjs7Vd8pZGH6SRpkNtoIAiw4"
   let salt :: B.ByteString = either error id $ strDecode "DGv6ra1nlYgDCS1FRnbzlw"
-  let privBS :: BL.ByteString = either error BL.fromStrict $ strDecode "yfWPiYE-n46HLnH0KqZOF1fJJU3MYrct3AELtAQ-oRw"
+  let privBS :: B.ByteString = either error id $ strDecode "yfWPiYE-n46HLnH0KqZOF1fJJU3MYrct3AELtAQ-oRw"
   asPriv :: ECC.PrivateNumber <- case uncompressDecodePrivateNumber privBS of
     Left e -> fail $ "Cannot decode PrivateNumber from b64 " <> show e
     Right p -> pure p