store: check name link kinds and hosts

apps/simplex-store-service/src/StoreService/Names/Links.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module StoreService.Names.Links
+  ( LinkKind (..),
+    linkMaxBytes,
+    linkKindOf,
+    linkHosts,
+  )
+where
+
+import Control.Applicative (optional, (<|>))
+import Data.Attoparsec.Text (Parser)
+import qualified Data.Attoparsec.Text as A
+import qualified Data.ByteString as B
+import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
+import qualified Data.List.NonEmpty as L
+import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
+import Simplex.Messaging.Agent.Protocol (ConnShortLink (..), ConnectionMode (..))
+import Simplex.Messaging.Encoding.String (StrEncoding (..))
+import Simplex.Messaging.Protocol (ProtocolServer (..))
+import Simplex.Messaging.Transport.Client (TransportHost)
+
+data LinkKind = LKContact | LKChannel
+  deriving (Eq, Show)
+
+linkMaxBytes :: Int
+linkMaxBytes = 4096
+
+-- the page's rule for one short link, so both refuse the same links
+linkKindOf :: Text -> Maybe LinkKind
+linkKindOf link
+  | B.length (encodeUtf8 link) > linkMaxBytes = Nothing
+  | otherwise = either (const Nothing) Just $ A.parseOnly (shortLinkP <* A.endOfInput) link
+
+shortLinkP :: Parser LinkKind
+shortLinkP = do
+  _ <- ("https://" *> A.takeWhile1 hostChar *> "/") <|> "simplex:/"
+  kind <- (LKContact <$ A.char 'a') <|> (LKChannel <$ A.char 'c')
+  _ <- A.char '#' *> A.takeWhile1 keyChar
+  _ <- optional $ A.char '?' *> A.takeWhile queryChar
+  pure kind
+  where
+    hostChar c = isAsciiLower c || isDigit c || c == '.' || c == '-'
+    keyChar c = isAsciiLower c || isAsciiUpper c || isDigit c || c == '_' || c == '-'
+    queryChar c = keyChar c || c == '=' || c == '&' || c == '.'
+
+-- the hosts as the chat core reads them, empty for a link it cannot read
+linkHosts :: Text -> [TransportHost]
+linkHosts = either (const []) hosts . strDecode . encodeUtf8
+  where
+    hosts :: ConnShortLink 'CMContact -> [TransportHost]
+    hosts (CSLContact _ _ ProtocolServer {host} _) = L.toList host

simplex-chat.cabal

@@ -446,6 +446,7 @@ executable simplex-store-service
       StoreService.Names.Chain
       StoreService.Names.Env
       StoreService.Names.Label
+      StoreService.Names.Links
       StoreService.Names.Phases
       StoreService.Names.Registration
       StoreService.Names.Signatures
@@ -749,6 +750,7 @@ test-suite simplex-chat-test
       Bots.StoreService.GroupTests
       Bots.StoreService.NameRegistrationTests
       Bots.StoreService.NamesLabelTests
+      Bots.StoreService.NamesLinksTests
       Bots.StoreService.NamesSignatureTests
       Bots.StoreService.NamesWiringTests
       Bots.StoreService.StripeTests
@@ -776,6 +778,7 @@ test-suite simplex-chat-test
       StoreService.Names.Chain
       StoreService.Names.Env
       StoreService.Names.Label
+      StoreService.Names.Links
       StoreService.Names.Phases
       StoreService.Names.Registration
       StoreService.Names.Signatures

tests/Bots/StoreService/NamesLinksTests.hs

@@ -0,0 +1,86 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Bots.StoreService.NamesLinksTests (namesLinksTests) where
+
+import Data.ByteString (ByteString)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Simplex.Messaging.Transport.Client (TransportHost (..))
+import StoreService.Names.Links
+import Test.Hspec
+
+namesLinksTests :: Spec
+namesLinksTests = describe "StoreService names: links" $ do
+  describe "kinds" $ do
+    it "accepts the page's short links of each kind" $ do
+      linkKindOf pageContact `shouldBe` Just LKContact
+      linkKindOf pageChannel `shouldBe` Just LKChannel
+      linkKindOf "https://smp9.simplex.im/c#Rk27xN4pDe9Tz1Wb3Yc5Vd7Xf9Hg2Jk4Lm" `shouldBe` Just LKChannel
+      linkKindOf "https://smp8.simplex.im/a#x" `shouldBe` Just LKContact
+      linkKindOf "simplex:/a#lrdvu2d8A1GumSmoKb2krQmtKhWXq-tyGpHuM7aMwsw?h=smp6.simplex.im" `shouldBe` Just LKContact
+      linkKindOf "https://localhost/a#4AkRDmhf64tdRlN406g8lJRg5OCmhD6ynIhi6glOcCM?p=7001&c=LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI" `shouldBe` Just LKContact
+      linkKindOf "https://1.2.3.4/c#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY" `shouldBe` Just LKChannel
+    it "refuses full links, two links joined, other link types and anything else" $ do
+      mapM_
+        refused
+        [ "https://simplex.chat/contact#/?v=2&smp=smp%3A%2F%2Fabc",
+          pageContact <> ";" <> pageContact,
+          "hello",
+          "",
+          "https://smp8.simplex.im/g#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY",
+          "https://smp8.simplex.im/i#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3/MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY",
+          "simplex:/g#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY?h=smp.simplex.im",
+          "http://smp8.simplex.im/a#Y8m3qT0vLw2Ab7cD9eF1gH3jK5mN7pQ9rS",
+          "https://SMP8.simplex.im/a#Y8m3qT0vLw2Ab7cD9eF1gH3jK5mN7pQ9rS",
+          "https://smp8.simplex.im/a/#Y8m3qT0vLw2Ab7cD9eF1gH3jK5mN7pQ9rS",
+          "https://smp8.simplex.im/a#",
+          "https:///a#Y8m3qT0vLw2Ab7cD9eF1gH3jK5mN7pQ9rS",
+          "simplex:/a#Y8m3qT0vLw2Ab7cD9eF1gH3jK5mN7pQ9rS=",
+          " " <> pageContact,
+          pageContact <> "\n",
+          pageContact <> " ",
+          pageContact <> "?x=é"
+        ]
+    it "refuses a link with several hosts, as the page does" $
+      linkKindOf multiHostContact `shouldBe` Nothing
+    it "accepts a link of exactly the bound and refuses one byte over it" $ do
+      let atBound = padded linkMaxBytes
+      T.length atBound `shouldBe` linkMaxBytes
+      linkKindOf atBound `shouldBe` Just LKContact
+      linkKindOf (padded $ linkMaxBytes + 1) `shouldBe` Nothing
+  describe "hosts" $ do
+    it "reads the authority of an https link" $
+      linkHosts presetContact `shouldBe` [THDomainName "smp6.simplex.im"]
+    it "reads an IP literal authority" $
+      linkHosts "https://1.2.3.4/c#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY" `shouldBe` [THIPv4 (1, 2, 3, 4)]
+    it "reads the authority and the extra hosts of an https link" $
+      linkHosts "https://smp.simplex.im/a#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY?h=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion&p=5223&c=1234-w"
+        `shouldBe` [THDomainName "smp.simplex.im", THOnionHost onionHost]
+    it "reads the one server host of a simplex link" $
+      linkHosts "simplex:/a#lrdvu2d8A1GumSmoKb2krQmtKhWXq-tyGpHuM7aMwsw?h=smp6.simplex.im" `shouldBe` [THDomainName "smp6.simplex.im"]
+    it "reads every server host of a simplex link" $
+      linkHosts multiHostContact `shouldBe` [THDomainName "smp.simplex.im", THOnionHost onionHost]
+    it "reads the hosts of a channel link" $
+      linkHosts "simplex:/c#AQIDBAUGBwgBAgMEBQYHCAECAwQFBgcIAQIDBAUGBwg?h=smp.simplex.im&p=5223&c=1234-w" `shouldBe` [THDomainName "smp.simplex.im"]
+    it "has no hosts for a link the chat core cannot read" $ do
+      linkHosts pageChannel `shouldBe` []
+      linkHosts "https://simplex.chat/contact#/?v=2&smp=smp%3A%2F%2Fabc" `shouldBe` []
+      linkHosts "hello" `shouldBe` []
+  where
+    refused l = (l, linkKindOf l) `shouldBe` (l, Nothing)
+    padded n = let base = presetContact <> "?x=" in base <> T.replicate (n - T.length base) "a"
+
+pageContact :: Text
+pageContact = "https://smp8.simplex.im/a#Y8m3qT0vLw2Ab7cD9eF1gH3jK5mN7pQ9rS"
+
+pageChannel :: Text
+pageChannel = "simplex:/c#Rk27xN4pDe9Tz1Wb3Yc5Vd7Xf9Hg2Jk4Lm?v=1"
+
+presetContact :: Text
+presetContact = "https://smp6.simplex.im/a#lrdvu2d8A1GumSmoKb2krQmtKhWXq-tyGpHuM7aMwsw"
+
+multiHostContact :: Text
+multiHostContact = "simplex:/a#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY?h=smp.simplex.im%2Cjjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion&p=5223&c=1234-w"
+
+onionHost :: ByteString
+onionHost = "jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion"

tests/Test.hs

@@ -11,6 +11,7 @@ import Bots.StoreService.GroupIntegrationTests
 import Bots.StoreService.GroupTests
 import Bots.StoreService.NameRegistrationTests
 import Bots.StoreService.NamesLabelTests
+import Bots.StoreService.NamesLinksTests
 import Bots.StoreService.NamesSignatureTests
 import Bots.StoreService.NamesWiringTests
 import Bots.StoreService.StripeTests
@@ -91,6 +92,7 @@ main = do
         badgeNameRegistrationTests
       namesConfigTests
       namesLabelTests
+      namesLinksTests
       namesSignatureTests
       namesWiringTests
       describe "SimpleX chat markdown" markdownTests