dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-09-14 15:16:41 +00:00
Code Issues Packages Projects Releases Wiki Activity
Files
99adfe9af079dd80b25d63d15fa2ed95155c9cdd
simplexmq/tests/SMPNamesTests.hs
T
Alain Brenzikofer 99adfe9af0 adapt house style
2026-09-06 19:00:44 +02:00

376 lines
18 KiB
Haskell
Raw Blame History

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module SMPNamesTests (smpNamesTests, testNameRecord) where
import qualified Data.Aeson as J
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import Data.Either (isLeft, isRight)
import Data.IORef (readIORef)
import Data.List (sort)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Network.HTTP.Types (status200, status400, status404, status410, status500, status502)
import NamesResolverServer (resolveResp, testNamesConfig, withResolverServer, withResolverServerDelayed)
import Simplex.Messaging.Encoding (smpDecode, smpEncode)
import Simplex.Messaging.Encoding.String (strDecode, strEncode)
import Simplex.Messaging.Protocol (NameAvailability (..), ErrorType (..), NameErrorType (..), NameRecord (..), NameReservedReason (..))
import Simplex.Messaging.Server.Main (validateUrl)
import Simplex.Messaging.Server.Names
( NamesConfig (..),
RpcAuth (..),
getNameAvailability,
newNamesEnv,
pingEndpoint,
resolveName,
)
import Simplex.Messaging.Server.Names.HttpResolver (ResolverError (..))
import Simplex.Messaging.SimplexName (SimplexDomain (..), SimplexTLD (..), fullDomainName, hashedDomain)
import Test.Hspec
testNameRecord :: NameRecord
testNameRecord =
NameRecord
{ nrName = "alice.simplex",
nrNickname = "Alice",
nrWebsite = "https://alice.example",
nrLocation = "Earth",
nrSimplexContact = ["simplex:/contact/abc#xyz"],
nrSimplexChannel = [],
nrEth = Just "0x0000000000000000000000000000000000000001",
nrBtc = Nothing,
nrXmr = Nothing,
nrDot = Nothing,
nrOwner = "0x0101010101010101010101010101010101010101",
nrResolver = "0x0202020202020202020202020202020202020202"
}
smpNamesTests :: Spec
smpNamesTests = do
describe "NameRecord JSON (Protocol)" nameRecordEncodingSpec
describe "ErrorType NAME wire encoding" errorWireSpec
describe "Name parsing (SimplexDomain)" parseNameSpec
describe "HTTP resolver" resolverSpec
describe "name availability" availabilitySpec
describe "Resolver health probe" healthSpec
describe "resolver_endpoint validation" validateUrlSpec
nameRecordEncodingSpec :: Spec
nameRecordEncodingSpec = do
it "round-trips JSON encode / decode" $
J.eitherDecodeStrict (LB.toStrict (J.encode testNameRecord)) `shouldBe` Right testNameRecord
it "emits keys in spec-documented order (resolver shape)" $ do
let bytes = LB.toStrict (J.encode testNameRecord)
offset k = B.length (fst (B.breakSubstring k bytes))
offsets =
map
offset
[ "name",
"nickname",
"website",
"location",
"simplexContact",
"simplexChannel",
"eth",
"btc",
"xmr",
"dot",
"owner",
"resolver"
]
offsets `shouldBe` sort offsets
it "emits unset coin fields as null (not absent)" $ do
let bytes = LB.toStrict (J.encode testNameRecord)
B.isInfixOf "\"btc\":null" bytes `shouldBe` True
B.isInfixOf "\"xmr\":null" bytes `shouldBe` True
B.isInfixOf "\"dot\":null" bytes `shouldBe` True
it "emits unset link fields as empty arrays (not null)" $ do
let bytes = LB.toStrict (J.encode testNameRecord)
B.isInfixOf "\"simplexChannel\":[]" bytes `shouldBe` True
B.isInfixOf "\"simplexChannel\":null" bytes `shouldBe` False
errorWireSpec :: Spec
errorWireSpec =
it "ErrorType NAME family round-trips smpEncode / smpDecode" $ do
smpDecode (smpEncode (NAME NO_RESOLVER)) `shouldBe` Right (NAME NO_RESOLVER)
smpDecode (smpEncode (NAME NOT_FOUND)) `shouldBe` Right (NAME NOT_FOUND)
-- RESOLVER detail may contain spaces - must survive the round-trip
smpDecode (smpEncode (NAME (RESOLVER "HTTP 502"))) `shouldBe` Right (NAME (RESOLVER "HTTP 502"))
availabilitySpec :: Spec
availabilitySpec = do
it "unregistered name is available" $
answers status404 "{\"error\":\"unregistered\"}" NAVailable
it "expired name is available" $
answers status410 "{\"error\":\"expired\"}" NAVailable
it "name in grace carries graceEnds" $
answers status410 "{\"error\":\"grace\",\"graceEnds\":1796377221}" (NAInGrace 1796377221)
it "auction carries premium and auctionEnds" $
answers
status410
"{\"error\":\"auction\",\"premium\":\"99999952316384526016153087\",\"auctionEnds\":1798191621}"
(NAAuction "99999952316384526016153087" 1798191621)
it "reserved name carries the reason" $
answers status404 "{\"error\":\"reserved\",\"reasonCode\":\"trademark\"}" (NAReserved NRTrademark)
-- an older resolver sends no reasonCode; that is not the chain saying "none"
it "no reasonCode still reads as reserved" $
answers status404 "{\"error\":\"reserved\"}" (NAReserved NRUnknown)
-- a later version may name reasons this one cannot; the reservation must
-- survive that, or a client would offer a name it cannot register
it "a reason from a later version still reads as reserved" $
smpDecode "RESERVED SOMETHING_NEW" `shouldBe` Right (NAReserved NRUnknown)
-- the resolver names this one explicitly; it is not the same as not knowing
it "unspecified reason reads as unspecified" $
answers status404 "{\"error\":\"reserved\",\"reasonCode\":\"unspecified\"}" (NAReserved NRUnspecified)
it "unknown reason still reads as reserved" $
answers status404 "{\"error\":\"reserved\",\"reasonCode\":\"astrology\"}" (NAReserved NRUnknown)
it "registered name is taken, with expiry" $
answers status200 "{\"status\":\"registered\",\"expires\":1811232000}" (NATaken (Just 1811232000))
it "registered without expiry is taken" $
answers status200 "{\"status\":\"registered\",\"expires\":null}" (NATaken Nothing)
-- an answer missing its payload withholds the name: quoting the usual price
-- for one that costs a premium is the wrong answer
it "grace without graceEnds is taken" $
answers status410 "{\"error\":\"grace\"}" (NATaken Nothing)
it "auction without premium is taken" $
answers status410 "{\"error\":\"auction\",\"auctionEnds\":1798191621}" (NATaken Nothing)
it "noResolver is taken" $
answers status404 "{\"error\":\"noResolver\",\"expires\":1811232000}" (NATaken (Just 1811232000))
-- the wire length-prefixes the price with one byte, so a longer or
-- non-numeric string is dropped rather than re-encoded
it "over-long premium is dropped" $
answers status410 (jsonBody ("{\"error\":\"auction\",\"premium\":\"" <> replicate 300 '9' <> "\",\"auctionEnds\":1798191621}")) (NATaken Nothing)
it "non-decimal premium is dropped" $
answers status410 "{\"error\":\"auction\",\"premium\":\"1e26\",\"auctionEnds\":1798191621}" (NATaken Nothing)
-- a resolver that could not answer must not look like an answer: TAKEN would
-- assert a registration nobody read, NOT_FOUND would read as "free"
it "upstream failure is a resolver error" $
refuses status502 "{\"error\":\"upstreamError\"}" (RESOLVER "upstreamError")
it "unconfigured TLD is a resolver error" $
refuses status400 "{\"error\":\"tldNotConfigured\"}" (RESOLVER "tldNotConfigured")
it "unreadable status is a resolver error" $
refuses status200 "{\"status\":\"unknown\",\"expires\":null}" (RESOLVER "unknown")
it "long status is truncated" $
refuses status502 (jsonBody ("{\"error\":\"" <> replicate 400 'e' <> "\"}")) (RESOLVER (T.replicate 32 "e"))
it "non-JSON body is never NOT_FOUND" $
refuses status404 "<html>gateway</html>" (RESOLVER "HTTP 404")
it "over-cap body is a resolver error" $
withResolverServer (resolveResp status200 (jsonBody ("{\"status\":\"registered\",\"pad\":\"" <> replicate 400 'x' <> "\"}"))) $ \port _ -> do
env <- newNamesEnv (testNamesConfig port) {resolverMaxResponseBytes = 200}
getNameAvailability env navlDomain `shouldReturn` Left (RESOLVER "response too large")
it "every answer survives the wire" $
mapM_
(\a -> smpDecode (smpEncode a) `shouldBe` Right a)
[ NAVailable,
NATaken (Just 1811232000),
NATaken Nothing,
NAInGrace 1796377221,
NAAuction "99999952316384526016153087" 1798191621,
NAReserved NRUnspecified,
NAReserved NRTrademark,
NAReserved NRPublicInterest,
NAReserved NROffensive,
NAReserved NRInternal,
NAReserved NRPremium,
NAReserved NRUnknown
]
where
jsonBody = LB.fromStrict . B.pack
answers st body a = resolverSays st body (Right a)
refuses st body e = resolverSays st body (Left e)
resolverSays st body expected =
withResolverServer (resolveResp st body) $ \port _ -> do
env <- newNamesEnv (testNamesConfig port)
getNameAvailability env navlDomain `shouldReturn` expected
navlDomain = SimplexDomain {nameTLD = TLDSimplex, domain = "alice", subDomain = []}
parseNameSpec :: Spec
parseNameSpec = do
-- asking by hash tells the client if a name is taken without naming it
it "accepts a labelhash label" $
parseN ("[" <> T.replicate 64 "b" <> "].simplex") `shouldSatisfy` isRight
it "refuses a hash of the wrong width" $
parseN ("[" <> T.replicate 63 "b" <> "].simplex") `shouldSatisfy` isLeft
-- only the bracketed form is a key; a bare hex string would be hashed again
it "refuses a bare hex string" $
parseN ("0x" <> T.replicate 64 "b" <> ".simplex") `shouldSatisfy` isLeft
it "keeps the brackets" $
(strEncode <$> parseN ("[" <> T.replicate 64 "b" <> "].simplex"))
`shouldBe` Right (encodeUtf8 ("[" <> T.replicate 64 "b" <> "].simplex"))
-- only the 2LD is a registry key; subname labels are needed as text
it "accepts a hashed 2LD under a subname" $
parseN ("x.[" <> T.replicate 64 "b" <> "].simplex") `shouldSatisfy` isRight
it "refuses a hashed subname label" $
parseN ("[" <> T.replicate 64 "b" <> "].alice.simplex") `shouldSatisfy` isLeft
it "refuses a labelhash under a web TLD" $
parseN ("[" <> T.replicate 64 "b" <> "].com") `shouldSatisfy` isLeft
-- keccak-256("alice"), the same constant the resolver's own tests use
it "hashes the 2LD to the registry key" $
(fullDomainName . hashedDomain <$> parseN "alice.simplex")
`shouldBe` Right "[9c0257114eb9399a2985f8e75dad7600c5d89fe3824ffa99ec1c3eb8bf3b0501].simplex"
it "leaves subname labels as text" $
(fullDomainName . hashedDomain <$> parseN "x.alice.simplex")
`shouldBe` Right "x.[9c0257114eb9399a2985f8e75dad7600c5d89fe3824ffa99ec1c3eb8bf3b0501].simplex"
it "leaves a web name alone" $
(fullDomainName . hashedDomain <$> parseN "example.com") `shouldBe` Right "example.com"
it "does not hash a hash" $
(fullDomainName . hashedDomain . hashedDomain <$> parseN "alice.simplex")
`shouldBe` Right "[9c0257114eb9399a2985f8e75dad7600c5d89fe3824ffa99ec1c3eb8bf3b0501].simplex"
it "accepts a valid simplex-TLD name" $
case parseN "privacy.simplex" of
Right d -> do
nameTLD d `shouldBe` TLDSimplex
domain d `shouldBe` "privacy"
Left e -> expectationFailure ("expected Right, got Left " <> e)
it "normalises case across labels (Alice.SIMPLEX = alice.simplex)" $
parseN "alice.simplex" `shouldBe` parseN "Alice.SIMPLEX"
it "accepts a testing-TLD name" $
case parseN "bob.testing" of
Right d -> nameTLD d `shouldBe` TLDTesting
Left e -> expectationFailure ("expected Right, got Left " <> e)
it "accepts a TLDWeb name (server forwards to resolver, which will likely 404/400)" $
parseN "example.com" `shouldSatisfy` isRight
it "rejects a bare (no-TLD) name" $
parseN "privacy" `shouldSatisfy` isLeft
it "rejects non-ASCII labels (homograph attacks)" $
parseN "\1072lice.simplex" `shouldSatisfy` isLeft
it "rejects oversized inputs (>253 bytes)" $
parseN (T.replicate 254 "a" <> ".simplex") `shouldSatisfy` isLeft
it "rejects a label longer than 63 bytes (DNS label limit)" $
parseN (T.replicate 64 "a" <> ".simplex") `shouldSatisfy` isLeft
it "accepts a label of exactly 63 bytes" $
parseN (T.replicate 63 "a" <> ".simplex") `shouldSatisfy` isRight
where
parseN :: T.Text -> Either String SimplexDomain
parseN = strDecode . encodeUtf8
resolverSpec :: Spec
resolverSpec = do
it "returns NameRecord on 200 OK" $
withResolverServer (resolveResp status200 (J.encode testNameRecord)) $ \port _ -> do
env <- newNamesEnv (testNamesConfig port)
resolveName env aliceDomain `shouldReturn` Right testNameRecord
it "returns NOT_FOUND on 404" $
withResolverServer (resolveResp status404 "{}") $ \port _ -> do
env <- newNamesEnv (testNamesConfig port)
resolveName env aliceDomain `shouldReturn` Left NOT_FOUND
it "returns NOT_FOUND on 400 (unknown TLD)" $
withResolverServer (resolveResp status400 "{}") $ \port _ -> do
env <- newNamesEnv (testNamesConfig port)
resolveName env aliceDomain `shouldReturn` Left NOT_FOUND
it "returns NOT_FOUND on 410 (registration lapsed)" $
withResolverServer (resolveResp status410 "{}") $ \port _ -> do
env <- newNamesEnv (testNamesConfig port)
resolveName env aliceDomain `shouldReturn` Left NOT_FOUND
it "returns RESOLVER on 502 (upstream failure)" $
withResolverServer (resolveResp status502 "{}") $ \port _ -> do
env <- newNamesEnv (testNamesConfig port)
resolveName env aliceDomain `shouldReturn` Left (RESOLVER "HTTP 502")
it "returns RESOLVER when the body exceeds the response cap" $
withResolverServer (resolveResp status200 (LB.fromStrict (B.replicate 500 'x'))) $ \port _ -> do
env <- newNamesEnv (testNamesConfig port) {resolverMaxResponseBytes = 100}
resolveName env aliceDomain `shouldReturn` Left (RESOLVER "response too large")
it "returns RESOLVER on malformed JSON from the resolver" $
withResolverServer (resolveResp status200 "this is not json") $ \port _ -> do
env <- newNamesEnv (testNamesConfig port)
resolveName env aliceDomain `shouldReturn` Left (RESOLVER "invalid response")
it "returns RESOLVER when JSON parses but isn't a NameRecord shape" $
withResolverServer (resolveResp status200 "{}") $ \port _ -> do
env <- newNamesEnv (testNamesConfig port)
resolveName env aliceDomain `shouldReturn` Left (RESOLVER "invalid response")
it "returns RESOLVER (timeout) when the resolver is slower than resolverTimeoutMs" $
withResolverServerDelayed 1500 (resolveResp status200 (J.encode testNameRecord)) $ \port _ -> do
env <- newNamesEnv (testNamesConfig port) {resolverTimeoutMs = 300}
resolveName env aliceDomain `shouldReturn` Left (RESOLVER "timeout")
it "sends one HTTP request per lookup (no cache)" $
withResolverServer (resolveResp status200 (J.encode testNameRecord)) $ \port reqs -> do
env <- newNamesEnv (testNamesConfig port)
_ <- resolveName env aliceDomain
_ <- resolveName env aliceDomain
readIORef reqs >>= \rs -> length rs `shouldBe` 2
it "addresses the resolver with the full canonical domain name" $
withResolverServer (resolveResp status200 (J.encode testNameRecord)) $ \port reqs -> do
env <- newNamesEnv (testNamesConfig port)
_ <- resolveName env aliceDomain
readIORef reqs `shouldReturn` [["resolve", "alice.simplex"]]
where
aliceDomain = SimplexDomain {nameTLD = TLDSimplex, domain = "alice", subDomain = []}
healthSpec :: Spec
healthSpec = do
it "pingEndpoint succeeds on a 200 OK /health response" $
withResolverServer (resolveResp status200 "{}") $ \port _ -> do
env <- newNamesEnv (testNamesConfig port)
pingEndpoint env >>= \case
Right () -> pure ()
Left e -> expectationFailure $ "expected Right (), got Left " <> show e
it "pingEndpoint fails on a 500 /health response" $
withResolverServer healthFails $ \port _ -> do
env <- newNamesEnv (testNamesConfig port)
pingEndpoint env >>= \case
Left (HttpStatusErr 500) -> pure ()
r -> expectationFailure $ "expected Left (HttpStatusErr 500), got " <> show r
it "pingEndpoint queries /health" $
withResolverServer (resolveResp status200 "{}") $ \port reqs -> do
env <- newNamesEnv (testNamesConfig port)
_ <- pingEndpoint env
readIORef reqs `shouldReturn` [["health"]]
where
healthFails = \case
["health"] -> (status500, "{}")
_ -> (status404, "{}")
validateUrlSpec :: Spec
validateUrlSpec = do
it "accepts an https URL with a path prefix" $
validateUrl "https://gw.example.com:443/snrc" Nothing `shouldSatisfy` isRight
it "accepts an http URL" $
validateUrl "http://127.0.0.1:8000" Nothing `shouldSatisfy` isRight
it "accepts a URL without an explicit port" $
validateUrl "https://gw.example.com/snrc" Nothing `shouldSatisfy` isRight
it "rejects a relative / non-absolute URI" $
validateUrl "gw.example.com/snrc" Nothing `shouldSatisfy` isLeft
it "rejects a non-http(s) scheme" $
validateUrl "ftp://gw.example.com:21" Nothing `shouldSatisfy` isLeft
it "rejects an empty host" $
validateUrl "http://" Nothing `shouldSatisfy` isLeft
it "accepts https with auth (Authorization is TLS-protected)" $
validateUrl "https://gw.example.com" (Just auth) `shouldSatisfy` isRight
it "accepts loopback http with auth (no cleartext exposure)" $
validateUrl "http://localhost:8000" (Just auth) `shouldSatisfy` isRight
it "rejects non-loopback http with auth (cleartext credential leak)" $
validateUrl "http://gw.example.com:8000" (Just auth) `shouldSatisfy` isLeft
it "rejects URL-embedded userinfo (credentials belong in resolver_auth)" $
validateUrl "https://user:pass@gw.example.com" Nothing `shouldSatisfy` isLeft
it "rejects http+auth to a 127.-prefixed non-loopback host (not real loopback)" $
validateUrl "http://127.evil.com:8000" (Just auth) `shouldSatisfy` isLeft
where
auth = AuthBasic "user" "pass"
Reference in New Issue View Git Blame Copy Permalink