From c2bd7293dbaeb077c99a5a5479810249beffff20 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Fri, 11 Sep 2026 10:06:33 +0100 Subject: [PATCH] simplify encoding --- src/Simplex/Messaging/Names/Record.hs | 6 ----- src/Simplex/Messaging/Protocol.hs | 37 ++++++++------------------ src/Simplex/Messaging/Server/Names.hs | 6 +++-- src/Simplex/Messaging/SimplexName.hs | 38 +++++++++------------------ tests/SMPNamesTests.hs | 2 +- 5 files changed, 29 insertions(+), 60 deletions(-) diff --git a/src/Simplex/Messaging/Names/Record.hs b/src/Simplex/Messaging/Names/Record.hs index 05800eb25..55efce4fe 100644 --- a/src/Simplex/Messaging/Names/Record.hs +++ b/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 diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 72ddd4aee..afce76d8c 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/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 diff --git a/src/Simplex/Messaging/Server/Names.hs b/src/Simplex/Messaging/Server/Names.hs index 2525a9f1c..3ec1d7b5c 100644 --- a/src/Simplex/Messaging/Server/Names.hs +++ b/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 diff --git a/src/Simplex/Messaging/SimplexName.hs b/src/Simplex/Messaging/SimplexName.hs index dcde97463..535682f0c 100644 --- a/src/Simplex/Messaging/SimplexName.hs +++ b/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 diff --git a/tests/SMPNamesTests.hs b/tests/SMPNamesTests.hs index 23799cd91..7ddd21b98 100644 --- a/tests/SMPNamesTests.hs +++ b/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