simplify encoding

src/Simplex/Messaging/Names/Record.hs

@@ -12,7 +12,6 @@ module Simplex.Messaging.Names.Record
     NamePricing (..),
     USDCents (..),
     NameReservedReason (..),
-    oldRegistration,
   )
 where
 
@@ -127,11 +126,6 @@ instance ToJSON NameReservedReason where
 instance FromJSON NameReservedReason where
   parseJSON = textParseJSON "NameReservedReason"
 
--- | A v20/v21 router's record as a registration.
-oldRegistration :: NameRecord -> NameRegistration
-oldRegistration nameRecord =
-  NRRegistered {expires = Nothing, graceUntil = Nothing, reservedReason_ = Nothing, nameRecord}
-
 $(JQ.deriveJSON defaultJSON ''NamePricing)
 
 -- taggedObjectJSON, not sumTypeJSON: this JSON is the RNAME payload and the

src/Simplex/Messaging/Protocol.hs

@@ -81,12 +81,10 @@ module Simplex.Messaging.Protocol
     CommandError (..),
     ProxyError (..),
     NameQuery (..),
-    queryName,
     NameRegistration (..),
     NamePricing (..),
     USDCents (..),
     NameReservedReason (..),
-    oldRegistration,
     NameErrorType (..),
     BrokerErrorType (..),
     NetworkError (..),
@@ -252,7 +250,7 @@ import Data.Constraint (Dict (..))
 import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.Kind
-import Data.List (find, foldl')
+import Data.List (foldl')
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import Data.Maybe (isJust, isNothing)
@@ -277,7 +275,7 @@ import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol.Types
 import Simplex.Messaging.Server.QueueStore.QueueInfo
 import Simplex.Messaging.ServiceScheme
-import Simplex.Messaging.SimplexName (LabelHash, SimplexDomain (..), SimplexTLD (..), boundedNonSpace, fullDomainName, labelHash, labelHashOfText, labelHashText, tldSuffix)
+import Simplex.Messaging.SimplexName (LabelHash, SimplexDomain (..), SimplexTLD (..), fullDomainName, labelHash)
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..))
 import Simplex.Messaging.Util (bshow, eitherToMaybe, safeDecodeUtf8, (<$?>))
@@ -1597,32 +1595,22 @@ data ErrorType
   deriving (Eq, Show)
 
 -- | What RSLV asks about: a name, or the hash of a second-level label.
-data NameQuery = NQDomain SimplexDomain | NQHash SimplexTLD LabelHash
+data NameQuery = NQDomain SimplexDomain | NQHash LabelHash SimplexTLD
   deriving (Eq, Show)
 
 instance Encoding NameQuery where
-  smpEncode = encodeUtf8 . queryName
-  smpP = nameQueryOf . safeDecodeUtf8 <$?> boundedNonSpace
-
--- | A hashed label is bracketed, which no name can be, so no tag is needed.
-nameQueryOf :: Text -> Either String NameQuery
-nameQueryOf t = case find ((`T.isSuffixOf` t) . tldSuffix) ([TLDSimplex, TLDTesting] :: [SimplexTLD]) of
-  Just tld | Just h <- labelHashOfText (T.dropEnd (T.length (tldSuffix tld)) t) -> Right (NQHash tld h)
-  _ -> NQDomain <$> strDecode (encodeUtf8 t)
+  smpEncode = \case
+    NQDomain d -> encodeUtf8 $ fullDomainName d
+    NQHash h tld -> strEncode h <> strEncode tld
+  smpP = NQHash <$> strP <*> strP <|> NQDomain <$> strP
 
 -- | Hashed from v22, except a name with subnames or a web TLD.
 hashedQuery :: NameQuery -> NameQuery
 hashedQuery q = case q of
   NQDomain SimplexDomain {nameTLD, domain, subDomain}
-    | null subDomain && nameTLD /= TLDWeb -> NQHash nameTLD (labelHash domain)
+    | null subDomain && nameTLD /= TLDWeb -> NQHash (labelHash domain) nameTLD
   _ -> q
 
--- | How the backing resolver is addressed for this query.
-queryName :: NameQuery -> Text
-queryName = \case
-  NQDomain d -> fullDomainName d
-  NQHash tld h -> labelHashText h <> tldSuffix tld
-
 -- | Name resolution error
 data NameErrorType
   = -- | the names role / resolver is not configured on this server
@@ -1856,9 +1844,7 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
     PRXY host auth_ -> e (PRXY_, ' ', host, auth_)
     PFWD fwdV pubKey (EncTransmission s) -> e (PFWD_, ' ', fwdV, pubKey, Tail s)
     RFWD (EncFwdTransmission s) -> e (RFWD_, ' ', Tail s)
-    RSLV q
-      | v >= nameAvailSMPVersion -> e (RSLV_, ' ', hashedQuery q)
-      | otherwise -> e (RSLV_, ' ') <> encodeUtf8 (queryName q)
+    RSLV q -> e (RSLV_, ' ', if v >= nameAvailSMPVersion then hashedQuery q else q)
     where
       e :: Encoding a => a -> ByteString
       e = smpEncode
@@ -1965,9 +1951,7 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
     CT SNotifierService NSUBS_
       | v >= rcvServiceSMPVersion -> Cmd SNotifierService <$> (NSUBS <$> _smpP <*> smpP)
       | otherwise -> pure $ Cmd SNotifierService $ NSUBS (-1) mempty
-    CT SResolver RSLV_
-      | v >= nameAvailSMPVersion -> Cmd SResolver . RSLV <$> _smpP <* A.takeByteString
-      | otherwise -> Cmd SResolver . RSLV . NQDomain <$> _smpP <* A.takeByteString
+    CT SResolver RSLV_ -> Cmd SResolver . RSLV <$> _smpP
 
   fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg
   {-# INLINE fromProtocolError #-}
@@ -2065,6 +2049,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
       | v >= nameAvailSMPVersion -> fmap RNAME . J.eitherDecodeStrict . unTail <$?> _smpP
       | otherwise -> fmap (RNAME . oldRegistration) . J.eitherDecodeStrict . unTail <$?> _smpP
     where
+      oldRegistration nameRecord = NRRegistered {expires = Nothing, graceUntil = Nothing, reservedReason_ = Nothing, nameRecord}
       serviceRespP resp
         | v >= rcvServiceSMPVersion = resp <$> _smpP <*> smpP
         | otherwise = resp <$> _smpP <*> pure mempty

src/Simplex/Messaging/Server/Names.hs

@@ -20,7 +20,9 @@ import Control.Logger.Simple (logError)
 import Data.Bifunctor (first)
 import Data.Maybe (fromMaybe)
 import qualified Data.Text as T
-import Simplex.Messaging.Protocol (NameErrorType (..), NameQuery, NameRegistration, queryName)
+import Data.Text.Encoding (decodeLatin1)
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Protocol (NameErrorType (..), NameQuery, NameRegistration)
 import Simplex.Messaging.Server.Names.HttpResolver
   ( ResolverEnv,
     ResolverError (..),
@@ -70,7 +72,7 @@ resolveName env q = do
 
 fetch :: NamesEnv -> NameQuery -> IO (Either NameErrorType NameRegistration)
 fetch NamesEnv {resolverEnv} q =
-  first mapResolverError <$> resolveHttp resolverEnv (queryName q)
+  first mapResolverError <$> resolveHttp resolverEnv (decodeLatin1 $ smpEncode q)
 
 mapResolverError :: ResolverError -> NameErrorType
 mapResolverError = \case

src/Simplex/Messaging/SimplexName.hs

@@ -10,11 +10,8 @@ module Simplex.Messaging.SimplexName
     SimplexTLD (..),
     SimplexNameType (..),
     fullDomainName,
-    tldSuffix,
     LabelHash (..),
     labelHash,
-    labelHashText,
-    labelHashOfText,
     boundedNonSpace,
     shortNameInfoStr,
   )
@@ -88,16 +85,11 @@ newtype LabelHash = LabelHash ByteString
 labelHash :: Text -> LabelHash
 labelHash label = LabelHash $ BA.convert (hash (encodeUtf8 (T.toLower label)) :: Digest Keccak_256)
 
--- | ENS's encoding for an unknown label, as the resolver's HTTP API takes it.
-labelHashText :: LabelHash -> Text
-labelHashText (LabelHash h) = "[" <> decodeLatin1 (BAE.convertToBase BAE.Base16 h) <> "]"
-
--- | The inverse: `[` cannot occur in a label, so the form is unambiguous.
-labelHashOfText :: Text -> Maybe LabelHash
-labelHashOfText t = do
-  hex <- T.stripSuffix "]" =<< T.stripPrefix "[" t
-  h <- eitherToMaybe (BAE.convertFromBase BAE.Base16 (encodeUtf8 hex) :: Either String ByteString)
-  if B.length h == 32 then Just (LabelHash h) else Nothing
+instance StrEncoding LabelHash where
+  strEncode (LabelHash h) = '[' `B.cons` (BAE.convertToBase BAE.Base16 h `B.snoc` ']')
+  strP = do
+    h <- BAE.convertFromBase BAE.Base16 <$?> (A.char '[' *> A.takeWhile (/= ']') <* A.char ']')
+    if B.length h == 32 then pure $ LabelHash h else fail "bad LabelHash"
 
 -- | Cap the name at 253 bytes (DNS full-domain limit)
 boundedNonSpace :: A.Parser ByteString
@@ -137,19 +129,15 @@ instance Encoding SimplexDomain where
   smpP = strP
 
 fullDomainName :: SimplexDomain -> Text
-fullDomainName SimplexDomain {nameTLD, domain, subDomain} = T.intercalate "." (reverse subDomain ++ [domain] ++ tld')
-  where
-    tld' = case nameTLD of
-      TLDSimplex -> ["simplex"]
-      TLDTesting -> ["testing"]
-      TLDWeb -> []
+fullDomainName SimplexDomain {nameTLD, domain, subDomain} = T.intercalate "." (reverse subDomain ++ [domain]) <> decodeLatin1 (strEncode nameTLD)
 
--- | A web name carries its own TLD, so it gets no suffix.
-tldSuffix :: SimplexTLD -> Text
-tldSuffix = \case
-  TLDSimplex -> ".simplex"
-  TLDTesting -> ".testing"
-  TLDWeb -> ""
+instance StrEncoding SimplexTLD where
+  strEncode = \case
+    TLDSimplex -> ".simplex"
+    TLDTesting -> ".testing"
+    TLDWeb -> ""
+  strP =
+    ".simplex" $> TLDSimplex <|> ".testing" $> TLDTesting <|> pure TLDWeb
 
 shortNameInfoStr :: SimplexNameInfo -> Text
 shortNameInfoStr = \case

tests/SMPNamesTests.hs

@@ -202,7 +202,7 @@ parseNameSpec = do
     mapM_
       (\q -> smpDecode (smpEncode q) `shouldBe` Right q)
       [ NQDomain d,
-        NQHash TLDSimplex (labelHash "alice")
+        NQHash (labelHash "alice") TLDSimplex
       ]
   it "accepts a valid simplex-TLD name" $
     case parseN "privacy.simplex" of