diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 3899d6b9c..fbc2ae3d6 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -81,8 +81,6 @@ module Simplex.Messaging.Protocol CommandError (..), ProxyError (..), NameQuery (..), - NameQueryLabel (..), - nameQuery, queryName, NameRegistration (..), NamePricing (..), @@ -254,7 +252,7 @@ import Data.Constraint (Dict (..)) import Data.Functor (($>)) import Data.Int (Int64) import Data.Kind -import Data.List (foldl') +import Data.List (find, foldl') import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) @@ -282,7 +280,7 @@ import Simplex.Messaging.Protocol.Types import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.ServiceScheme import Simplex.Messaging.SystemTime (SystemSeconds) -import Simplex.Messaging.SimplexName (LabelHash, SimplexDomain (..), SimplexTLD (..), fullDomainName, labelHash, labelHashText) +import Simplex.Messaging.SimplexName (LabelHash, SimplexDomain (..), SimplexTLD (..), boundedNonSpace, fullDomainName, labelHash, labelHashOfText, labelHashText, tldSuffix) import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..)) import Simplex.Messaging.Util (bshow, eitherToMaybe, safeDecodeUtf8, (<$?>)) @@ -1601,81 +1599,43 @@ data ErrorType DUPLICATE_ -- not part of SMP protocol, used internally deriving (Eq, Show) --- | What RSLV asks about. Unlike SimplexDomain, which is always text, this may --- name a label by its hash. -data NameQuery = NameQuery - { queryTLD :: SimplexTLD, - -- | only the second-level label may be hashed: subname labels are needed as - -- text to reach the record - queryLabel :: NameQueryLabel, - -- | parent to child, as in SimplexDomain - querySub :: [Text] - } +-- | What RSLV asks about: a name, or the hash of a second-level label. +data NameQuery = NQDomain SimplexDomain | NQHash SimplexTLD LabelHash deriving (Eq, Show) -data NameQueryLabel - = NQName Text - | NQHash LabelHash - deriving (Eq, Show) +instance Encoding NameQuery where + smpEncode = encodeUtf8 . queryName + smpP = nameQueryOf . safeDecodeUtf8 <$?> boundedNonSpace -instance Encoding NameQueryLabel where - smpEncode = \case - NQName t -> smpEncode ('N', t) - NQHash h -> smpEncode ('H', h) - smpP = - A.anyChar >>= \case - 'N' -> NQName <$> smpP - 'H' -> NQHash <$> smpP - _ -> fail "bad NameQueryLabel" +-- | 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) + +-- | 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) + _ -> q -- | How the backing resolver is addressed for this query. queryName :: NameQuery -> Text -queryName = fullDomainName . queryDomain +queryName = \case + NQDomain d -> fullDomainName d + NQHash tld h -> labelHashText h <> tldSuffix tld --- | The query as a name: what RSLV carries below v22, and what the resolver's --- HTTP API takes. The only place a hashed label is written as text; SMP tags --- the choice instead. -queryDomain :: NameQuery -> SimplexDomain -queryDomain NameQuery {queryTLD, queryLabel, querySub} = - SimplexDomain {nameTLD = queryTLD, domain = label, subDomain = querySub} - where - label = case queryLabel of - NQName t -> t - NQHash h -> labelHashText h - --- | The name a client asked about, hashed from v22. The hash only hides an --- unregistered name: a registered one comes back with its name in the record, --- and a short label is guessable by hashing candidates. A web TLD has no --- registry, so it is never hashed. -nameQuery :: VersionSMP -> SimplexDomain -> NameQuery -nameQuery v SimplexDomain {nameTLD, domain, subDomain} = - NameQuery {queryTLD = nameTLD, queryLabel = label, querySub = subDomain} - where - label - | v >= nameAvailSMPVersion && nameTLD /= TLDWeb = NQHash (labelHash domain) - | otherwise = NQName domain - -instance Encoding NameQuery where - smpEncode NameQuery {queryTLD, queryLabel, querySub} = - smpEncode (queryTLD, queryLabel, EncList querySub) - smpP = do - (queryTLD, queryLabel, EncList querySub) <- smpP - pure NameQuery {queryTLD, queryLabel, querySub} - --- | US cents, rounded up where the registry's unit does not divide evenly, so --- a quote is never below what is charged. The exact price is settled on chain. +-- | US cents, rounded up so a quote is never below what is charged. newtype USDCents = USDCents Int64 deriving (Eq, Ord, Show) deriving newtype (Encoding) --- | What the registry holds for a name. A name that cannot be dated or priced --- is not a case here: the router answers ERR NAME RESOLVER instead. +-- | What the registry holds for a name. data NameRegistration - = -- | Held by someone. Always carries a record: where the owner set none, - -- every field is unset and the resolver address is zero. + = -- | Held by someone. Always carries a record, empty where none was set. NRRegistered - { -- | unix seconds the registration runs out. Absent only from a v20/v21 - -- router, whose answer carried the record alone. + { -- | absent only from a v20/v21 router, which sent the record alone expires :: Maybe SystemSeconds, -- | unix seconds, > expires: until here only the owner may renew graceUntil :: Maybe SystemSeconds, @@ -1684,15 +1644,8 @@ data NameRegistration nameRecord :: NameRecord } | -- | Held by nobody, and registrable now. - NRAvailable - { pricing :: NamePricing, - -- | while set, the name also costs a surcharge above `pricing` that - -- decays to nothing at this time. The surcharge itself is not carried: - -- it changes continuously, so it cannot be quoted as a price. - auctionUntil :: Maybe SystemSeconds - } - | -- | Held back by the registry and not registered. No price: it is not for - -- sale at the registry's price. + NRAvailable {pricing :: NamePricing} + | -- | Held back by the registry, and not for sale at its price. NRReserved {reservedReason :: NameReservedReason} deriving (Eq, Show) @@ -1700,7 +1653,7 @@ instance Encoding NameRegistration where smpEncode = \case NRRegistered {expires, graceUntil, reservedReason_, nameRecord} -> smpEncode ('N', expires, graceUntil, reservedReason_, ' ', Tail $ LB.toStrict $ J.encode nameRecord) - NRAvailable {pricing, auctionUntil} -> smpEncode ('A', auctionUntil, pricing) + NRAvailable {pricing} -> smpEncode ('A', pricing) NRReserved {reservedReason} -> smpEncode ('R', reservedReason) smpP = A.anyChar >>= \case @@ -1708,19 +1661,14 @@ instance Encoding NameRegistration where (expires, graceUntil, reservedReason_) <- smpP nameRecord <- J.eitherDecodeStrict . unTail <$?> _smpP pure NRRegistered {expires, graceUntil, reservedReason_, nameRecord} - 'A' -> do - auctionUntil <- smpP - pricing <- smpP - pure NRAvailable {pricing, auctionUntil} + 'A' -> NRAvailable <$> smpP 'R' -> NRReserved <$> smpP _ -> fail "bad NameRegistration" --- | Enough to price the name locally. The client knows the label, so it knows --- which tier applies and whether the label is long enough; the router, behind a --- hash, knows neither. The formula is in protocol/simplex-messaging.md. +-- | Enough to price the name locally, which the router cannot do behind a hash. data NamePricing = NamePricing { -- | US cents per year, for the lengths the registry prices specially - rentPrices :: Map Int USDCents, + registrationPrices :: Map Int USDCents, -- | US cents per year for every other length basePrice :: USDCents, -- | characters; the registry refuses shorter labels @@ -1729,14 +1677,14 @@ data NamePricing = NamePricing deriving (Eq, Show) instance Encoding NamePricing where - smpEncode NamePricing {rentPrices, basePrice, minLabelLength} = - smpEncode (EncList $ map tier $ M.toList rentPrices, basePrice, w16 minLabelLength) + smpEncode NamePricing {registrationPrices, basePrice, minLabelLength} = + smpEncode (EncList $ map tier $ M.toList registrationPrices, basePrice, w16 minLabelLength) where tier (len, price) = (w16 len, price) w16 = fromIntegral :: Int -> Word16 smpP = do (EncList tiers, basePrice, minLen) <- smpP - pure NamePricing {rentPrices = tierMap tiers, basePrice, minLabelLength = fromIntegral (minLen :: Word16)} + pure NamePricing {registrationPrices = tierMap tiers, basePrice, minLabelLength = fromIntegral (minLen :: Word16)} where tierMap :: [(Word16, USDCents)] -> Map Int USDCents tierMap = M.fromList . map (\(len, price) -> (fromIntegral len, price)) @@ -1747,31 +1695,31 @@ data NameReservedReason NRRInternal | NRRTrademark | NRRCommunity - | -- | a reason added to the registry after this version: still reserved, and - -- carries its own word so a later version can name it + | -- | added to the registry after this version, and still reserved NRRUnknown Text deriving (Eq, Show) --- | One vocabulary, shared by the wire, the backing resolver and the JSON API. -instance StrEncoding NameReservedReason where - strEncode = \case +instance TextEncoding NameReservedReason where + textEncode = \case NRRInternal -> "internal" NRRTrademark -> "trademark" NRRCommunity -> "community" - NRRUnknown t -> encodeUtf8 t - strP = reservedReasonOf . safeDecodeUtf8 <$> A.takeTill (== ' ') - where - reservedReasonOf = \case - "internal" -> NRRInternal - "trademark" -> NRRTrademark - "community" -> NRRCommunity - t -> NRRUnknown t + NRRUnknown t -> t + textDecode = Just . reservedReasonOf + +-- | A reason this version has no word for keeps its own. +reservedReasonOf :: Text -> NameReservedReason +reservedReasonOf = \case + "internal" -> NRRInternal + "trademark" -> NRRTrademark + "community" -> NRRCommunity + t -> NRRUnknown t instance Encoding NameReservedReason where - smpEncode = strEncode - smpP = strP + smpEncode = encodeUtf8 . textEncode + smpP = reservedReasonOf . safeDecodeUtf8 <$> A.takeTill (== ' ') --- | A v20/v21 router's answer: the name resolves, and nothing else was said. +-- | What a v20/v21 router's answer amounts to. oldRegistration :: NameRecord -> NameRegistration oldRegistration nameRecord = NRRegistered {expires = Nothing, graceUntil = Nothing, reservedReason_ = Nothing, nameRecord} @@ -2011,8 +1959,8 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where PFWD fwdV pubKey (EncTransmission s) -> e (PFWD_, ' ', fwdV, pubKey, Tail s) RFWD (EncFwdTransmission s) -> e (RFWD_, ' ', Tail s) RSLV q - | v >= nameAvailSMPVersion -> e (RSLV_, ' ', q) - | otherwise -> e (RSLV_, ' ', queryDomain q) + | v >= nameAvailSMPVersion -> e (RSLV_, ' ', hashedQuery q) + | otherwise -> e (RSLV_, ' ') <> encodeUtf8 (queryName q) where e :: Encoding a => a -> ByteString e = smpEncode @@ -2121,7 +2069,7 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where | otherwise -> pure $ Cmd SNotifierService $ NSUBS (-1) mempty CT SResolver RSLV_ | v >= nameAvailSMPVersion -> Cmd SResolver . RSLV <$> _smpP <* A.takeByteString - | otherwise -> Cmd SResolver . RSLV . nameQuery v <$> _smpP <* A.takeByteString + | otherwise -> Cmd SResolver . RSLV . NQDomain <$> _smpP <* A.takeByteString fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg {-# INLINE fromProtocolError #-} @@ -2612,8 +2560,8 @@ $(J.deriveJSON defaultJSON ''BlockingInfo) $(concat <$> mapM @[] (J.deriveJSON (sumTypeJSON id)) [''ProxyError, ''NameErrorType, ''ErrorType]) instance ToJSON NameReservedReason where - toJSON = strToJSON - toEncoding = strToJEncoding + toJSON = textToJSON + toEncoding = textToEncoding instance FromJSON NameReservedReason where - parseJSON = strParseJSON "NameReservedReason" + parseJSON = textParseJSON "NameReservedReason" diff --git a/src/Simplex/Messaging/SimplexName.hs b/src/Simplex/Messaging/SimplexName.hs index c81dbd4cb..7fb65d714 100644 --- a/src/Simplex/Messaging/SimplexName.hs +++ b/src/Simplex/Messaging/SimplexName.hs @@ -10,9 +10,12 @@ module Simplex.Messaging.SimplexName SimplexTLD (..), SimplexNameType (..), fullDomainName, + tldSuffix, LabelHash (..), labelHash, labelHashText, + labelHashOfText, + boundedNonSpace, shortNameInfoStr, ) where @@ -77,8 +80,7 @@ nameLabelP = do -- (Cyrillic а vs ASCII a hash to different on-chain records). isNameLetter c = c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z' --- | The registry's key for a label, and what --- BaseRegistrarImplementation.labelOf takes. Always 32 bytes. +-- | The registry's key for a label: 32 bytes, as labelOf takes it. newtype LabelHash = LabelHash ByteString deriving (Eq, Show) @@ -90,11 +92,17 @@ instance Encoding LabelHash where labelHash :: Text -> LabelHash labelHash label = LabelHash $ BA.convert (hash (encodeUtf8 (T.toLower label)) :: Digest Keccak_256) --- | ENS's encoding for a label whose text is unknown, which is what the --- backing resolver's HTTP API takes. +-- | 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 + -- | Cap the name at 253 bytes (DNS full-domain limit) boundedNonSpace :: A.Parser ByteString boundedNonSpace = do @@ -145,12 +153,15 @@ instance Encoding SimplexTLD where _ -> fail "bad SimplexTLD" 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]) <> tldSuffix nameTLD + +-- | A web name carries its own TLD, so it gets no suffix. +tldSuffix :: SimplexTLD -> Text +tldSuffix = \case + TLDSimplex -> ".simplex" + TLDTesting -> ".testing" + TLDWeb -> "" shortNameInfoStr :: SimplexNameInfo -> Text shortNameInfoStr = \case