store: add the name label rule

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

@@ -0,0 +1,33 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module StoreService.Names.Label
+  ( LabelError (..),
+    validLabel,
+  )
+where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeLatin1, encodeUtf8)
+import Simplex.Messaging.Encoding.String (StrEncoding (..))
+import Simplex.Messaging.SimplexName (SimplexDomain (..), SimplexTLD)
+
+data LabelError = LELength | LEChars
+  deriving (Eq, Show)
+
+minLabelLength :: Int
+minLabelLength = 6
+
+maxLabelLength :: Int
+maxLabelLength = 63
+
+validLabel :: SimplexTLD -> Text -> Either LabelError Text
+validLabel tld label
+  | len < minLabelLength || len > maxLabelLength = Left LELength
+  | T.toLower label /= label = Left LEChars
+  | otherwise = case strDecode (encodeUtf8 $ label <> decodeLatin1 (strEncode tld)) of
+      Right SimplexDomain {domain, subDomain = []} | domain == label -> Right label
+      _ -> Left LEChars
+  where
+    len = T.length label

simplex-chat.cabal

@@ -738,6 +738,7 @@ test-suite simplex-chat-test
       Bots.StoreService.GroupIntegrationTests
       Bots.StoreService.GroupTests
       Bots.StoreService.NameRegistrationTests
+      Bots.StoreService.NamesLabelTests
       Bots.StoreService.StripeTests
       Bots.StoreService.WaitersTests
       Bots.StoreService.WebTests
@@ -760,6 +761,7 @@ test-suite simplex-chat-test
       StoreService.Group.Command
       StoreService.Log
       StoreService.Names.Chain
+      StoreService.Names.Label
       StoreService.Names.Registration
       StoreService.Options
       StoreService.Orders

tests/Bots/StoreService/NamesLabelTests.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Bots.StoreService.NamesLabelTests (storeNamesLabelTests) where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Simplex.Messaging.SimplexName (SimplexTLD (..))
+import StoreService.Names.Label
+import Test.Hspec
+
+storeNamesLabelTests :: Spec
+storeNamesLabelTests = describe "StoreService names: label" $ do
+  describe "accepts" $ do
+    mapM_ accepted ["bakery", "bak-ery-2", "a-b-c-d-e-f", "123456", T.replicate 63 "a"]
+  describe "refuses as characters" $ do
+    mapM_ (refused LEChars) ["bak--ery", "--bakery", "bakery--", "-bakery", "bakery-", "Bakery", "bak.ery", "bäkery", "bak ery", "bak_ery", "bakery.simplex", "бакеry1"]
+  describe "refuses as length" $ do
+    mapM_ (refused LELength) ["", "abcde", "a.b", T.replicate 64 "a", T.replicate 100 "-"]
+  it "applies the same rule under the testing TLD" $ do
+    validLabel TLDTesting "bakery" `shouldBe` Right "bakery"
+    validLabel TLDTesting "bak--ery" `shouldBe` Left LEChars
+  it "has no bare web names" $
+    validLabel TLDWeb "bakery" `shouldBe` Left LEChars
+  where
+    accepted l = it ("accepts " <> show l) $ validLabel TLDSimplex l `shouldBe` Right l
+    refused :: LabelError -> Text -> Spec
+    refused e l = it ("refuses " <> show l) $ validLabel TLDSimplex l `shouldBe` Left e

tests/Test.hs

@@ -10,6 +10,7 @@ import Bots.StoreService.ConfigTests
 import Bots.StoreService.GroupIntegrationTests
 import Bots.StoreService.GroupTests
 import Bots.StoreService.NameRegistrationTests
+import Bots.StoreService.NamesLabelTests
 import Bots.StoreService.StripeTests
 import Bots.StoreService.WaitersTests
 import Bots.StoreService.WebTests
@@ -86,6 +87,7 @@ main = do
         badgeBTCPayTests
         badgeStripeTests
         badgeNameRegistrationTests
+        storeNamesLabelTests
       describe "SimpleX chat markdown" markdownTests
       describe "JSON Tests" jsonTests
       describe "Member relations" memberRelationsTests