From af4f4137c6d6cd086fd58bfec7facdda9a2022d8 Mon Sep 17 00:00:00 2001
From: shum <github.shum@liber.li>
Date: Wed, 21 Oct 2026 22:56:52 +0000
Subject: [PATCH 1/3] store: read link profiles behind a host check

---
 .../src/StoreService/Names/Env.hs             |   7 +-
 .../src/StoreService/Names/Profiles.hs        | 331 ++++++++++++++++++
 simplex-chat.cabal                            |   2 +
 3 files changed, 338 insertions(+), 2 deletions(-)
 create mode 100644 apps/simplex-store-service/src/StoreService/Names/Profiles.hs

diff --git a/apps/simplex-store-service/src/StoreService/Names/Env.hs b/apps/simplex-store-service/src/StoreService/Names/Env.hs
index 325ff4538c..abb9a018b8 100644
--- a/apps/simplex-store-service/src/StoreService/Names/Env.hs
+++ b/apps/simplex-store-service/src/StoreService/Names/Env.hs
@@ -7,6 +7,7 @@ import Simplex.Messaging.Agent.Protocol (UserId)
 import Simplex.Messaging.Agent.Store.Common (DBStore)
 import StoreService.Config (NamesConfig)
 import StoreService.Names.Phases (Phases, newPhases)
+import StoreService.Names.Profiles (Profiles, chatProfile, defaultProfileLimits, monotonicSeconds, newProfiles, systemResolver)
 import StoreService.Names.Turns (Turns, newTurns)
 
 data NamesEnv = NamesEnv
@@ -15,11 +16,13 @@ data NamesEnv = NamesEnv
     neConfig :: NamesConfig,
     neStore :: DBStore,
     nePhases :: Phases,
-    neTurns :: Turns
+    neTurns :: Turns,
+    neProfiles :: Profiles
   }
 
 newNamesEnv :: ChatController -> UserId -> NamesConfig -> DBStore -> IO NamesEnv
 newNamesEnv neChat neUserId neConfig neStore = do
   nePhases <- newPhases
   neTurns <- newTurns
-  pure NamesEnv {neChat, neUserId, neConfig, neStore, nePhases, neTurns}
+  neProfiles <- newProfiles defaultProfileLimits monotonicSeconds (chatProfile neChat neUserId) systemResolver
+  pure NamesEnv {neChat, neUserId, neConfig, neStore, nePhases, neTurns, neProfiles}
diff --git a/apps/simplex-store-service/src/StoreService/Names/Profiles.hs b/apps/simplex-store-service/src/StoreService/Names/Profiles.hs
new file mode 100644
index 0000000000..e8599db42c
--- /dev/null
+++ b/apps/simplex-store-service/src/StoreService/Names/Profiles.hs
@@ -0,0 +1,331 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | The host rule is best effort: the chat core resolves a host again when it connects, so the deployment's egress rule is the real guard.
+module StoreService.Names.Profiles
+  ( Profiles,
+    ProfileLimits (..),
+    ProfileFetcher,
+    HostResolver,
+    EntityType (..),
+    ChatKind (..),
+    LinkProfile (..),
+    ProfileRead (..),
+    Preview (..),
+    Entity (..),
+    defaultProfileLimits,
+    newProfiles,
+    monotonicSeconds,
+    chatProfile,
+    systemResolver,
+    planProfile,
+    hostsFetchable,
+    linkEntity,
+    linkPreview,
+  )
+where
+
+import Control.Concurrent (forkFinally)
+import Control.Concurrent.STM
+import Control.Exception (bracket_)
+import Data.Aeson ((.=))
+import qualified Data.Aeson as J
+import qualified Data.Aeson.Types as JT
+import Data.Bits (shiftL, shiftR, (.|.))
+import Data.Char (toLower)
+import Data.Int (Int64)
+import Data.List (dropWhileEnd, isSuffixOf)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Data.Word (Word32, Word64, Word8)
+import GHC.Clock (getMonotonicTimeNSec)
+import Network.Socket (AddrInfo (..), HostName, SockAddr (..), SocketType (..), defaultHints, getAddrInfo, hostAddressToTuple)
+import Simplex.Chat.Controller (ChatResponse (..), ChatCommand (APIConnectPlan), ChatController, ConnectionPlan (..), ContactAddressPlan (..), GroupLinkPlan (..), PlanResolveMode (..))
+import Simplex.Chat.Core (sendChatCmd)
+import Simplex.Chat.Protocol (ContactShortLinkData (..), GroupShortLinkData (..), PublicGroupData (..))
+import Simplex.Chat.Types (AConnectTarget (..), ChatPeerType (..), Contact (..), ContactNameOrLink (..), ConnectTarget (..), GroupInfo (..), GroupProfile (..), GroupSummary (..), ImageData (..), Profile (..), User (..), fromLocalProfile)
+import Simplex.Messaging.Agent.Protocol (ConnShortLink, ConnectionMode (..), SConnectionMode (..), UserId)
+import Simplex.Messaging.Encoding.String (strDecode)
+import Simplex.Messaging.Transport.Client (TransportHost (..))
+import Simplex.Messaging.Util (anyM)
+import System.Timeout (timeout)
+
+data ProfileLimits = ProfileLimits
+  { searchFetchSlots :: Int,
+    previewFetchSlots :: Int,
+    -- | Microseconds for one fetch, the wait for its slot and its host check included.
+    fetchTimeout :: Int,
+    cacheSeconds :: Word64,
+    maxCachedProfiles :: Int
+  }
+
+defaultProfileLimits :: ProfileLimits
+defaultProfileLimits =
+  ProfileLimits
+    { searchFetchSlots = 4,
+      previewFetchSlots = 2,
+      fetchTimeout = 3000000,
+      cacheSeconds = 600,
+      maxCachedProfiles = 2048
+    }
+
+-- | Nothing when the link data could not be read.
+type ProfileFetcher = ConnShortLink 'CMContact -> IO (Maybe LinkProfile)
+
+-- | The addresses a name resolves to, none when it does not resolve.
+type HostResolver = HostName -> IO [TransportHost]
+
+data Profiles = Profiles
+  { limits :: ProfileLimits,
+    clock :: IO Word64,
+    fetchLink :: ProfileFetcher,
+    resolveHost :: HostResolver,
+    searchSlots :: TVar Int,
+    previewSlots :: TVar Int,
+    cache :: TVar (Map Text (Word64, LinkProfile))
+  }
+
+newProfiles :: ProfileLimits -> IO Word64 -> ProfileFetcher -> HostResolver -> IO Profiles
+newProfiles limits@ProfileLimits {searchFetchSlots, previewFetchSlots} clock fetchLink resolveHost = do
+  searchSlots <- newTVarIO searchFetchSlots
+  previewSlots <- newTVarIO previewFetchSlots
+  cache <- newTVarIO Map.empty
+  pure Profiles {limits, clock, fetchLink, resolveHost, searchSlots, previewSlots, cache}
+
+monotonicSeconds :: IO Word64
+monotonicSeconds = (`div` 1000000000) <$> getMonotonicTimeNSec
+
+-- | The record a link came from: @simplex.contact@ or @simplex.channel@.
+data EntityType = ETAddress | ETChannel
+  deriving (Eq, Show)
+
+data ChatKind = CKContact | CKBusiness | CKBot | CKChannel
+  deriving (Eq, Show)
+
+data LinkProfile = LinkProfile
+  { kind :: ChatKind,
+    displayName :: Text,
+    fullName :: Text,
+    image :: Maybe Text,
+    subscribers :: Maybe Int64
+  }
+  deriving (Eq, Show)
+
+data ProfileRead = ProfileOk LinkProfile | ProfileUnread | ProfileUnavailable
+  deriving (Eq, Show)
+
+data Preview = Preview {previewType :: EntityType, previewProfile :: ProfileRead}
+  deriving (Eq, Show)
+
+data Entity = Entity {entityPreview :: Preview, link :: Text, deepLink :: Text}
+  deriving (Eq, Show)
+
+instance J.ToJSON Preview where
+  toJSON = J.object . previewPairs
+
+instance J.ToJSON Entity where
+  toJSON Entity {entityPreview, link, deepLink} = J.object $ previewPairs entityPreview <> ["link" .= link, "deepLink" .= deepLink]
+
+previewPairs :: Preview -> [JT.Pair]
+previewPairs (Preview t r) =
+  [ "type" .= entityTypeText t,
+    "kind" .= chatKindText kind,
+    "displayName" .= displayName,
+    "fullName" .= fullName,
+    "image" .= image,
+    "subscribers" .= subscribers,
+    "profile" .= readText
+  ]
+  where
+    (LinkProfile {kind, displayName, fullName, image, subscribers}, readText) = case r of
+      ProfileOk p -> (p, "ok" :: Text)
+      ProfileUnread -> (emptyProfile, "unread")
+      ProfileUnavailable -> (emptyProfile, "unavailable")
+    emptyProfile = LinkProfile {kind = linkKind t, displayName = "", fullName = "", image = Nothing, subscribers = Nothing}
+    linkKind = \case
+      ETAddress -> CKContact
+      ETChannel -> CKChannel
+
+entityTypeText :: EntityType -> Text
+entityTypeText = \case
+  ETAddress -> "address"
+  ETChannel -> "channel"
+
+chatKindText :: ChatKind -> Text
+chatKindText = \case
+  CKContact -> "contact"
+  CKBusiness -> "business"
+  CKBot -> "bot"
+  CKChannel -> "channel"
+
+-- | A search answer's entity, within the search bound. The hosts are the link's servers, every one of which must pass the host rule.
+linkEntity :: Profiles -> EntityType -> [TransportHost] -> Text -> IO Entity
+linkEntity ps@Profiles {searchSlots} t hosts link = do
+  r <- boundedProfile ps searchSlots hosts link
+  pure Entity {entityPreview = Preview t r, link, deepLink = deepLinkOf link}
+
+-- | A link preview, within the preview bound.
+linkPreview :: Profiles -> EntityType -> [TransportHost] -> Text -> IO Preview
+linkPreview ps@Profiles {previewSlots} t hosts link = Preview t <$> boundedProfile ps previewSlots hosts link
+
+deepLinkOf :: Text -> Text
+deepLinkOf link = maybe link (("simplex:/" <>) . T.drop 1 . T.dropWhile (/= '/')) (T.stripPrefix "https://" link)
+
+-- | A link the chat core cannot parse names no server it could fetch from, so it is not fetched.
+boundedProfile :: Profiles -> TVar Int -> [TransportHost] -> Text -> IO ProfileRead
+boundedProfile Profiles {limits = ProfileLimits {fetchTimeout, cacheSeconds, maxCachedProfiles}, clock, fetchLink, resolveHost, cache} slots hosts link =
+  cached >>= \case
+    Just p -> pure $ ProfileOk p
+    Nothing -> case strDecode (encodeUtf8 link) of
+      Left _ -> pure ProfileUnavailable
+      Right sl -> fromMaybe ProfileUnread <$> timeout fetchTimeout (checkAndFetch sl)
+  where
+    cached = do
+      now <- clock
+      (\m -> case Map.lookup link m of Just (expiry, p) | expiry > now -> Just p; _ -> Nothing) <$> readTVarIO cache
+    checkAndFetch sl =
+      hostsFetchable resolveHost hosts >>= \case
+        False -> pure ProfileUnavailable
+        True -> withSlot (fetchLink sl) >>= maybe (pure ProfileUnread) (\p -> ProfileOk p <$ remember p)
+    withSlot =
+      bracket_
+        (atomically $ readTVar slots >>= \n -> check (n > 0) >> writeTVar slots (n - 1))
+        (atomically $ modifyTVar' slots (+ 1))
+    remember p = do
+      now <- clock
+      atomically $ modifyTVar' cache $ Map.insert link (now + cacheSeconds, p) . makeRoom now
+    makeRoom now m
+      | Map.size m < maxCachedProfiles || Map.member link m = m
+      | otherwise =
+          let live = Map.filter ((> now) . fst) m
+           in if Map.size live < maxCachedProfiles then live else maybe live (`Map.delete` live) (soonestExpiry live)
+    soonestExpiry = fmap fst . Map.foldrWithKey (\k (e, _) acc -> if maybe True ((e <) . snd) acc then Just (k, e) else acc) Nothing
+
+-- | Runs the connect plan, which reads the link data without connecting. A known chat answers with its stored profile.
+chatProfile :: ChatController -> UserId -> ProfileFetcher
+chatProfile cc userId sl =
+  sendChatCmd cc (APIConnectPlan userId (Just $ ACTarget SCMContact $ CTShortContact $ CTLink sl) PRMUnknown Nothing) >>= \case
+    Right CRConnectionPlan {user = User {profile}, connectionPlan} -> pure $ planProfile (fromLocalProfile profile) connectionPlan
+    _ -> pure Nothing
+
+-- | The first argument is the profile of the user who ran the plan, which their own address shows.
+planProfile :: Profile -> ConnectionPlan -> Maybe LinkProfile
+planProfile own = \case
+  CPContactAddress plan _ -> case plan of
+    CAPOk {contactSLinkData_} -> (\ContactShortLinkData {profile, business} -> contactProfile business profile) <$> contactSLinkData_
+    CAPOwnLink -> Just $ contactProfile False own
+    CAPConnectingConfirmReconnect -> Nothing
+    CAPConnectingProhibit {contact} -> Just $ knownContact contact
+    CAPKnown {contact} -> Just $ knownContact contact
+    CAPContactViaAddress {contact} -> Just $ knownContact contact
+  CPGroupLink plan _ -> case plan of
+    GLPOk {groupSLinkData_} -> channelProfile <$> groupSLinkData_
+    GLPNoRelays {groupSLinkData_} -> channelProfile <$> groupSLinkData_
+    GLPUpdateRequired {groupSLinkData_} -> channelProfile <$> groupSLinkData_
+    GLPOwnLink {groupInfo} -> Just $ knownGroup groupInfo
+    GLPConnectingConfirmReconnect -> Nothing
+    GLPConnectingProhibit {groupInfo_} -> knownGroup <$> groupInfo_
+    GLPKnown {groupInfo} -> Just $ knownGroup groupInfo
+  CPInvitationLink _ -> Nothing
+  CPError _ -> Nothing
+  where
+    knownContact Contact {profile} = contactProfile False (fromLocalProfile profile)
+    channelProfile GroupShortLinkData {groupProfile, publicGroupData} =
+      groupProfileOf CKChannel groupProfile ((\PublicGroupData {publicMemberCount} -> publicMemberCount) <$> publicGroupData)
+    knownGroup GroupInfo {groupProfile, businessChat, groupSummary = GroupSummary {publicMemberCount}} = case businessChat of
+      Just _ -> groupProfileOf CKBusiness groupProfile Nothing
+      Nothing -> groupProfileOf CKChannel groupProfile publicMemberCount
+
+contactProfile :: Bool -> Profile -> LinkProfile
+contactProfile business Profile {displayName, fullName, image, peerType} =
+  LinkProfile {kind, displayName, fullName, image = image >>= imageURI, subscribers = Nothing}
+  where
+    kind
+      | business || peerType == Just CPTBusiness = CKBusiness
+      | peerType == Just CPTBot = CKBot
+      | otherwise = CKContact
+
+groupProfileOf :: ChatKind -> GroupProfile -> Maybe Int64 -> LinkProfile
+groupProfileOf kind GroupProfile {displayName, fullName, image} subscribers =
+  LinkProfile {kind, displayName, fullName, image = image >>= imageURI, subscribers}
+
+-- | A profile image the page can show as it is.
+imageURI :: ImageData -> Maybe Text
+imageURI (ImageData uri)
+  | "data:image/" `T.isPrefixOf` uri = Just uri
+  | otherwise = Nothing
+
+-- | False when any host is an onion address, does not resolve, or is or resolves to an address outside the public internet.
+hostsFetchable :: HostResolver -> [TransportHost] -> IO Bool
+hostsFetchable resolve hosts
+  | null hosts = pure False
+  | otherwise = not <$> anyM (map refused hosts)
+  where
+    refused = \case
+      THDomainName name
+        | onionName name -> pure True
+        | otherwise -> (\addresses -> null addresses || not (all publicAddress addresses)) <$> resolve name
+      host -> pure $ not $ publicAddress host
+    onionName name = ".onion" `isSuffixOf` dropWhileEnd (== '.') (map toLower name)
+
+publicAddress :: TransportHost -> Bool
+publicAddress = \case
+  THIPv4 a -> publicIPv4 (ipv4Word a)
+  THIPv6 a -> publicIPv6 a
+  _ -> False
+
+-- | Unspecified ("this network"), private, CGNAT, loopback, link-local and multicast.
+refusedIPv4 :: [(Word32, Int)]
+refusedIPv4 =
+  [ (ipv4Word (0, 0, 0, 0), 8),
+    (ipv4Word (10, 0, 0, 0), 8),
+    (ipv4Word (100, 64, 0, 0), 10),
+    (ipv4Word (127, 0, 0, 0), 8),
+    (ipv4Word (169, 254, 0, 0), 16),
+    (ipv4Word (172, 16, 0, 0), 12),
+    (ipv4Word (192, 168, 0, 0), 16),
+    (ipv4Word (224, 0, 0, 0), 4)
+  ]
+
+-- | Unique-local, link-local and multicast, as prefixes of the address's first 32 bits.
+refusedIPv6 :: [(Word32, Int)]
+refusedIPv6 = [(0xfc000000, 7), (0xfe800000, 10), (0xff000000, 8)]
+
+-- | The third 32-bit word of an IPv4-mapped IPv6 address, @::ffff:a.b.c.d@.
+ipv4MappedWord :: Word32
+ipv4MappedWord = 0xffff
+
+publicIPv4 :: Word32 -> Bool
+publicIPv4 a = not $ any (inPrefix a) refusedIPv4
+
+publicIPv6 :: (Word32, Word32, Word32, Word32) -> Bool
+publicIPv6 (w0, w1, w2, w3)
+  | w0 == 0 && w1 == 0 && w2 == ipv4MappedWord = publicIPv4 w3
+  | w0 == 0 && w1 == 0 && w2 == 0 && w3 <= 1 = False
+  | otherwise = not $ any (inPrefix w0) refusedIPv6
+
+inPrefix :: Word32 -> (Word32, Int) -> Bool
+inPrefix a (net, len) = a `shiftR` (32 - len) == net `shiftR` (32 - len)
+
+ipv4Word :: (Word8, Word8, Word8, Word8) -> Word32
+ipv4Word (a, b, c, d) = fromIntegral a `shiftL` 24 .|. fromIntegral b `shiftL` 16 .|. fromIntegral c `shiftL` 8 .|. fromIntegral d
+
+-- | getAddrInfo is a foreign call that a timeout cannot interrupt, so it runs in its own thread, which a timed-out caller leaves to finish.
+systemResolver :: HostResolver
+systemResolver name = do
+  result <- newEmptyTMVarIO
+  _ <- forkFinally (getAddrInfo (Just defaultHints {addrSocketType = Stream}) (Just name) Nothing) $
+    atomically . putTMVar result . either (const []) (mapMaybe (sockHost . addrAddress))
+  atomically $ readTMVar result
+  where
+    sockHost = \case
+      SockAddrInet _ a -> Just $ THIPv4 $ hostAddressToTuple a
+      SockAddrInet6 _ _ a _ -> Just $ THIPv6 a
+      SockAddrUnix _ -> Nothing
diff --git a/simplex-chat.cabal b/simplex-chat.cabal
index b7d05448d7..4ba296a43e 100644
--- a/simplex-chat.cabal
+++ b/simplex-chat.cabal
@@ -447,6 +447,7 @@ executable simplex-store-service
       StoreService.Names.Env
       StoreService.Names.Label
       StoreService.Names.Phases
+      StoreService.Names.Profiles
       StoreService.Names.Registration
       StoreService.Names.Signatures
       StoreService.Names.Turns
@@ -777,6 +778,7 @@ test-suite simplex-chat-test
       StoreService.Names.Env
       StoreService.Names.Label
       StoreService.Names.Phases
+      StoreService.Names.Profiles
       StoreService.Names.Registration
       StoreService.Names.Signatures
       StoreService.Names.Turns

From 7ca2c54217088ad189edab9f3353cea11028640d Mon Sep 17 00:00:00 2001
From: shum <github.shum@liber.li>
Date: Wed, 21 Oct 2026 22:56:52 +0000
Subject: [PATCH 2/3] store: test link profiles and the host rule

---
 simplex-chat.cabal                            |   1 +
 tests/Bots/StoreService/NamesProfilesTests.hs | 443 ++++++++++++++++++
 tests/Test.hs                                 |   3 +
 3 files changed, 447 insertions(+)
 create mode 100644 tests/Bots/StoreService/NamesProfilesTests.hs

diff --git a/simplex-chat.cabal b/simplex-chat.cabal
index 4ba296a43e..4935d0d3ef 100644
--- a/simplex-chat.cabal
+++ b/simplex-chat.cabal
@@ -750,6 +750,7 @@ test-suite simplex-chat-test
       Bots.StoreService.GroupTests
       Bots.StoreService.NameRegistrationTests
       Bots.StoreService.NamesLabelTests
+      Bots.StoreService.NamesProfilesTests
       Bots.StoreService.NamesSignatureTests
       Bots.StoreService.NamesWiringTests
       Bots.StoreService.StripeTests
diff --git a/tests/Bots/StoreService/NamesProfilesTests.hs b/tests/Bots/StoreService/NamesProfilesTests.hs
new file mode 100644
index 0000000000..7dd839b2a2
--- /dev/null
+++ b/tests/Bots/StoreService/NamesProfilesTests.hs
@@ -0,0 +1,443 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module Bots.StoreService.NamesProfilesTests (namesProfilesTests, namesProfilesChatTests) where
+
+import ChatClient (TestCC (..), testChat2)
+import ChatTests.DBUtils (TestParams)
+import ChatTests.Groups (prepareChannel1Relay)
+import ChatTests.Utils (aliceProfile, bobProfile, getContactLinks, withRelay, (##>))
+import qualified ChatTests.Utils as CU
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async (async, concurrently, replicateConcurrently, wait)
+import Control.Concurrent.STM
+import Control.Exception (uninterruptibleMask_)
+import Control.Monad (replicateM_)
+import qualified Data.Aeson as J
+import Data.Int (Int64)
+import qualified Data.ByteString.Base64.URL as B64URL
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
+import qualified Data.Map.Strict as Map
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf8)
+import Data.Time.Clock (diffUTCTime, getCurrentTime)
+import Data.Word (Word32, Word64)
+import Simplex.Chat.Controller (ChatErrorType (..), ChatError (..), ConnectionPlan (..), ContactAddressPlan (..), GroupLinkPlan (..))
+import Simplex.Chat.Protocol (ContactShortLinkData (..), GroupShortLinkData (..), PublicGroupData (..))
+import Simplex.Chat.Types (ChatPeerType (..), GroupProfile (..), ImageData (..), Profile (..))
+import Simplex.Messaging.Agent.Protocol (ConnShortLink, ConnectionMode (..))
+import Simplex.Messaging.Encoding.String (strDecode, strEncode)
+import Simplex.Messaging.Transport.Client (TransportHost (..))
+import StoreService.Names.Profiles
+import Test.Hspec hiding (it)
+import qualified Test.Hspec as H
+
+namesProfilesTests :: Spec
+namesProfilesTests = describe "StoreService names: profiles" $ do
+  describe "plan to profile" $ do
+    H.it "reads a contact address's link data as a contact" testPlanContact
+    H.it "reads a business address by its flag or by its profile's peer type" testPlanBusiness
+    H.it "reads a bot address by its profile's peer type" testPlanBot
+    H.it "reads a channel with its subscriber count, also when it has no relays or needs an update" testPlanChannel
+    H.it "reads the user's own address from the user's profile" testPlanOwnLink
+    H.it "reads nothing from an error, missing link data or a connection being made" testPlanNothing
+    H.it "drops an image that is not a data:image URI" testPlanImage
+  describe "JSON" $ do
+    H.it "encodes a contact entity as the contract's example" testEntityContactJSON
+    H.it "encodes a channel entity with subscribers and a simplex:/ deep link" testEntityChannelJSON
+    H.it "encodes previews without a profile as empty, kind from the link" testPreviewEmptyJSON
+  describe "bounds and cache" $ do
+    H.it "answers a link again from the cache, and fetches it again once the cache expires" testCacheExpiry
+    H.it "does not cache a failed fetch" testFailureNotCached
+    H.it "evicts the entry that expires soonest when the cache is full" testCacheBound
+    H.it "gives up a fetch that takes longer than the timeout, freeing its slot" testFetchTimeout
+    H.it "fills the preview bound while search still fetches, and a preview with no slot in time is unread" testPreviewBound
+    H.it "fills the search bound while previews still fetch" testSearchBound
+    H.it "lets a fetch wait for a slot that frees within the timeout" testSlotFreesInTime
+    H.it "answers a link the chat core cannot parse unavailable without fetching" testUnparseableLink
+  describe "host rule" $ do
+    H.it "passes public IP literals and a name resolving to public addresses" testPublicHosts
+    H.it "refuses private, loopback, CGNAT, link-local and unique-local literals" testPrivateLiterals
+    H.it "refuses names resolving to those addresses" testPrivateNames
+    H.it "refuses unspecified, multicast and IPv4-mapped private addresses" testOtherRefused
+    H.it "refuses .onion hosts without resolving them, and unresolvable names" testOnionUnresolvable
+    H.it "refuses a link with one public and one private host, and a name with one private address" testMixedHosts
+    H.it "answers a refused link unavailable without fetching it" testRefusedNotFetched
+
+namesProfilesChatTests :: SpecWith TestParams
+namesProfilesChatTests =
+  describe "StoreService names: profiles" $
+    CU.it "reads an address and a channel through the chat core, and the owner's own from its store" testChatProfiles
+
+-- Plans
+
+ownProfile :: Profile
+ownProfile = linkDataProfile "store" "SimpleX store" Nothing
+
+contactData :: Bool -> Profile -> ConnectionPlan
+contactData business profile =
+  CPContactAddress CAPOk {contactSLinkData_ = Just ContactShortLinkData {profile, message = Nothing, business, localBadge = Nothing}, ownerVerification = Nothing} Nothing
+
+channelData :: Maybe Int64 -> GroupShortLinkData
+channelData count =
+  GroupShortLinkData
+    { groupProfile = GroupProfile {displayName = "news", fullName = "Bakery news", shortDescr = Nothing, description = Nothing, image = Nothing, publicGroup = Nothing, groupPreferences = Nothing, memberAdmission = Nothing},
+      publicGroupData = PublicGroupData <$> count
+    }
+
+alice :: Profile
+alice = bakeryWith (Just (ImageData jpeg))
+
+bakeryWith :: Maybe ImageData -> Profile
+bakeryWith = linkDataProfile "Alice's Bakery" "Sourdough and pastries, Lisbon"
+
+linkDataProfile :: Text -> Text -> Maybe ImageData -> Profile
+linkDataProfile displayName fullName image =
+  Profile {displayName, fullName, shortDescr = Nothing, description = Nothing, image, contactLink = Nothing, preferences = Nothing, peerType = Nothing, badge = Nothing, contactDomain = Nothing}
+
+jpeg :: Text
+jpeg = "data:image/jpeg;base64,/9j/4AAQSkZJRg=="
+
+testPlanContact :: IO ()
+testPlanContact =
+  planProfile ownProfile (contactData False alice)
+    `shouldBe` Just LinkProfile {kind = CKContact, displayName = "Alice's Bakery", fullName = "Sourdough and pastries, Lisbon", image = Just jpeg, subscribers = Nothing}
+
+testPlanBusiness :: IO ()
+testPlanBusiness = do
+  kindOf (contactData True alice) `shouldBe` Just CKBusiness
+  kindOf (contactData False alice {peerType = Just CPTBusiness}) `shouldBe` Just CKBusiness
+  kindOf (contactData False alice {peerType = Just CPTHuman}) `shouldBe` Just CKContact
+
+testPlanBot :: IO ()
+testPlanBot = do
+  kindOf (contactData False alice {peerType = Just CPTBot}) `shouldBe` Just CKBot
+  kindOf (contactData True alice {peerType = Just CPTBot}) `shouldBe` Just CKBusiness
+
+testPlanChannel :: IO ()
+testPlanChannel = do
+  let news count = Just LinkProfile {kind = CKChannel, displayName = "news", fullName = "Bakery news", image = Nothing, subscribers = count}
+  planProfile ownProfile (CPGroupLink GLPOk {groupSLinkInfo_ = Nothing, groupSLinkData_ = Just (channelData (Just 1204)), ownerVerification = Nothing} Nothing) `shouldBe` news (Just 1204)
+  planProfile ownProfile (CPGroupLink GLPOk {groupSLinkInfo_ = Nothing, groupSLinkData_ = Just (channelData Nothing), ownerVerification = Nothing} Nothing) `shouldBe` news Nothing
+  planProfile ownProfile (CPGroupLink (GLPNoRelays (Just (channelData (Just 3)))) Nothing) `shouldBe` news (Just 3)
+  planProfile ownProfile (CPGroupLink (GLPUpdateRequired (Just (channelData (Just 4)))) Nothing) `shouldBe` news (Just 4)
+
+testPlanOwnLink :: IO ()
+testPlanOwnLink =
+  planProfile ownProfile (CPContactAddress CAPOwnLink Nothing)
+    `shouldBe` Just LinkProfile {kind = CKContact, displayName = "store", fullName = "SimpleX store", image = Nothing, subscribers = Nothing}
+
+testPlanNothing :: IO ()
+testPlanNothing = do
+  planProfile ownProfile (CPError (ChatError CEInvalidConnReq)) `shouldBe` Nothing
+  planProfile ownProfile (CPContactAddress CAPOk {contactSLinkData_ = Nothing, ownerVerification = Nothing} Nothing) `shouldBe` Nothing
+  planProfile ownProfile (CPGroupLink GLPOk {groupSLinkInfo_ = Nothing, groupSLinkData_ = Nothing, ownerVerification = Nothing} Nothing) `shouldBe` Nothing
+  planProfile ownProfile (CPContactAddress CAPConnectingConfirmReconnect Nothing) `shouldBe` Nothing
+  planProfile ownProfile (CPGroupLink GLPConnectingConfirmReconnect Nothing) `shouldBe` Nothing
+  planProfile ownProfile (CPGroupLink (GLPConnectingProhibit Nothing) Nothing) `shouldBe` Nothing
+
+testPlanImage :: IO ()
+testPlanImage = do
+  let imageOf p = planProfile ownProfile (contactData False p) >>= \LinkProfile {image} -> image
+  imageOf (bakeryWith (Just (ImageData "javascript:alert(1)"))) `shouldBe` Nothing
+  imageOf (bakeryWith (Just (ImageData "https://example.com/a.png"))) `shouldBe` Nothing
+  imageOf alice `shouldBe` Just jpeg
+
+kindOf :: ConnectionPlan -> Maybe ChatKind
+kindOf plan = (\LinkProfile {kind} -> kind) <$> planProfile ownProfile plan
+
+-- JSON
+
+bakeryLink, newsLink :: Text
+bakeryLink = "https://smp8.simplex.im/a#Y8m3qT0vLw2Ab7cD9eF1gH3jK5mN7pQ9rSAAAAAAAAA"
+newsLink = "https://smp9.simplex.im/c#Rk27xN4pDe9Tz1Wb3Yc5Vd7Xf9Hg2Jk4LmAAAAAAAAA"
+
+shouldEncodeAs :: J.ToJSON a => a -> LB.ByteString -> Expectation
+shouldEncodeAs v expected = Just (J.toJSON v) `shouldBe` J.decode expected
+
+testEntityContactJSON :: IO ()
+testEntityContactJSON = do
+  ps <- quietProfiles (pure . Just . const bakery) publicResolver
+  e <- linkEntity ps ETAddress [publicHost] bakeryLink
+  e
+    `shouldEncodeAs` "{\"type\": \"address\", \"kind\": \"contact\", \"displayName\": \"Alice's Bakery\", \"fullName\": \"Sourdough and pastries, Lisbon\",\
+                     \ \"image\": \"data:image/jpeg;base64,/9j/4AAQSkZJRg==\", \"subscribers\": null, \"profile\": \"ok\",\
+                     \ \"link\": \"https://smp8.simplex.im/a#Y8m3qT0vLw2Ab7cD9eF1gH3jK5mN7pQ9rSAAAAAAAAA\", \"deepLink\": \"simplex:/a#Y8m3qT0vLw2Ab7cD9eF1gH3jK5mN7pQ9rSAAAAAAAAA\"}"
+  where
+    bakery = LinkProfile {kind = CKContact, displayName = "Alice's Bakery", fullName = "Sourdough and pastries, Lisbon", image = Just jpeg, subscribers = Nothing}
+
+testEntityChannelJSON :: IO ()
+testEntityChannelJSON = do
+  ps <- quietProfiles (pure . Just . const news) publicResolver
+  e <- linkEntity ps ETChannel [publicHost] newsLink
+  e
+    `shouldEncodeAs` "{\"type\": \"channel\", \"kind\": \"channel\", \"displayName\": \"Bakery news\", \"fullName\": \"Daily bakes and opening hours\",\
+                     \ \"image\": null, \"subscribers\": 1204, \"profile\": \"ok\",\
+                     \ \"link\": \"https://smp9.simplex.im/c#Rk27xN4pDe9Tz1Wb3Yc5Vd7Xf9Hg2Jk4LmAAAAAAAAA\", \"deepLink\": \"simplex:/c#Rk27xN4pDe9Tz1Wb3Yc5Vd7Xf9Hg2Jk4LmAAAAAAAAA\"}"
+  let simplexLink = "simplex:/c#Rk27xN4pDe9Tz1Wb3Yc5Vd7Xf9Hg2Jk4LmAAAAAAAAA?h=smp9.simplex.im"
+  Entity {link, deepLink} <- linkEntity ps ETChannel [publicHost] simplexLink
+  (link, deepLink) `shouldBe` (simplexLink, simplexLink)
+  where
+    news = LinkProfile {kind = CKChannel, displayName = "Bakery news", fullName = "Daily bakes and opening hours", image = Nothing, subscribers = Just 1204}
+
+testPreviewEmptyJSON :: IO ()
+testPreviewEmptyJSON = do
+  Preview ETChannel ProfileUnread
+    `shouldEncodeAs` "{\"type\": \"channel\", \"kind\": \"channel\", \"displayName\": \"\", \"fullName\": \"\", \"image\": null, \"subscribers\": null, \"profile\": \"unread\"}"
+  Preview ETAddress ProfileUnavailable
+    `shouldEncodeAs` "{\"type\": \"address\", \"kind\": \"contact\", \"displayName\": \"\", \"fullName\": \"\", \"image\": null, \"subscribers\": null, \"profile\": \"unavailable\"}"
+  Preview ETAddress (ProfileOk LinkProfile {kind = CKBot, displayName = "helper", fullName = "", image = Nothing, subscribers = Nothing})
+    `shouldEncodeAs` "{\"type\": \"address\", \"kind\": \"bot\", \"displayName\": \"helper\", \"fullName\": \"\", \"image\": null, \"subscribers\": null, \"profile\": \"ok\"}"
+
+-- Bounds and cache
+
+-- | Long enough that a fetch which should have been answered from a slot or the cache would be seen waiting on it.
+testTimeout :: Int
+testTimeout = 500000
+
+testLimits :: ProfileLimits
+testLimits = defaultProfileLimits {fetchTimeout = testTimeout}
+
+data Fake = Fake {profiles :: Profiles, clockAt :: TVar Word64, fetched :: TVar [Text]}
+
+-- | A fetcher that records each link it is asked for, then answers with @answer@.
+newFake :: ProfileLimits -> (Text -> IO (Maybe LinkProfile)) -> HostResolver -> IO Fake
+newFake limits answer resolver = do
+  clockAt <- newTVarIO 0
+  fetched <- newTVarIO []
+  let fetcher sl = do
+        let l = linkText sl
+        atomically $ modifyTVar' fetched (l :)
+        answer l
+  profiles <- newProfiles limits (readTVarIO clockAt) fetcher resolver
+  pure Fake {profiles, clockAt, fetched}
+
+quietProfiles :: (Text -> IO (Maybe LinkProfile)) -> HostResolver -> IO Profiles
+quietProfiles answer resolver = (\Fake {profiles} -> profiles) <$> newFake testLimits answer resolver
+
+linkText :: ConnShortLink 'CMContact -> Text
+linkText = decodeUtf8 . strEncode
+
+-- | A contact address link with a distinct canonical key, so it round-trips through the chat core's parser.
+addressLink :: Int -> Text
+addressLink n = "https://smp8.simplex.im/a#" <> decodeUtf8 (B64URL.encodeUnpadded (B.pack (take 32 (show n <> repeat '.'))))
+
+profileFor :: Text -> LinkProfile
+profileFor l = LinkProfile {kind = CKContact, displayName = T.takeEnd 8 l, fullName = "", image = Nothing, subscribers = Nothing}
+
+answerAll :: Text -> IO (Maybe LinkProfile)
+answerAll = pure . Just . profileFor
+
+fetchCount :: Fake -> IO Int
+fetchCount Fake {fetched} = length <$> readTVarIO fetched
+
+preview :: Fake -> Text -> IO ProfileRead
+preview Fake {profiles} l = (\(Preview _ r) -> r) <$> linkPreview profiles ETAddress [publicHost] l
+
+search :: Fake -> Text -> IO ProfileRead
+search Fake {profiles} l = (\Entity {entityPreview = Preview _ r} -> r) <$> linkEntity profiles ETAddress [publicHost] l
+
+testCacheExpiry :: IO ()
+testCacheExpiry = do
+  fake@Fake {clockAt} <- newFake testLimits answerAll publicResolver
+  let l = addressLink 1
+  preview fake l `shouldReturn` ProfileOk (profileFor l)
+  search fake l `shouldReturn` ProfileOk (profileFor l)
+  fetchCount fake `shouldReturn` 1
+  atomically $ writeTVar clockAt 599
+  preview fake l `shouldReturn` ProfileOk (profileFor l)
+  fetchCount fake `shouldReturn` 1
+  atomically $ writeTVar clockAt 600
+  preview fake l `shouldReturn` ProfileOk (profileFor l)
+  fetchCount fake `shouldReturn` 2
+
+testFailureNotCached :: IO ()
+testFailureNotCached = do
+  failing <- newTVarIO True
+  fake <- newFake testLimits (\l -> readTVarIO failing >>= \f -> pure $ if f then Nothing else Just (profileFor l)) publicResolver
+  let l = addressLink 1
+  preview fake l `shouldReturn` ProfileUnread
+  atomically $ writeTVar failing False
+  preview fake l `shouldReturn` ProfileOk (profileFor l)
+  fetchCount fake `shouldReturn` 2
+
+testCacheBound :: IO ()
+testCacheBound = do
+  fake@Fake {clockAt} <- newFake testLimits {maxCachedProfiles = 2} answerAll publicResolver
+  let a = addressLink 1
+      b = addressLink 2
+      c = addressLink 3
+  mapM_ (\(t, l) -> atomically (writeTVar clockAt t) >> preview fake l) [(0, a), (1, b), (2, c)]
+  fetchCount fake `shouldReturn` 3
+  preview fake b `shouldReturn` ProfileOk (profileFor b)
+  preview fake c `shouldReturn` ProfileOk (profileFor c)
+  fetchCount fake `shouldReturn` 3
+  preview fake a `shouldReturn` ProfileOk (profileFor a)
+  fetchCount fake `shouldReturn` 4
+
+testFetchTimeout :: IO ()
+testFetchTimeout = do
+  gate <- newEmptyTMVarIO
+  fake <- newFake testLimits (\l -> if l == addressLink 0 then atomically (readTMVar gate) >> answerAll l else answerAll l) publicResolver
+  start <- getCurrentTime
+  replicateConcurrently 2 (preview fake (addressLink 0)) `shouldReturn` [ProfileUnread, ProfileUnread]
+  elapsed <- (`diffUTCTime` start) <$> getCurrentTime
+  elapsed `shouldSatisfy` (< 2 * micros testTimeout)
+  -- Both preview slots were taken by the timed-out fetches; they must be free again.
+  replicateConcurrently 2 (preview fake (addressLink 1)) `shouldReturn` replicate 2 (ProfileOk (profileFor (addressLink 1)))
+  where
+    micros n = fromIntegral n / 1000000
+
+-- | A fetcher for which links numbered below 100 report that they started, then hold their slot until the gate opens, past their timeout.
+gatedFake :: IO (Fake, TQueue (), TMVar ())
+gatedFake = do
+  started <- newTQueueIO
+  gate <- newEmptyTMVarIO
+  let answer l
+        | l `elem` map addressLink [0 .. 99] = atomically (writeTQueue started ()) >> uninterruptibleMask_ (atomically $ readTMVar gate) >> answerAll l
+        | otherwise = answerAll l
+  fake <- newFake testLimits answer publicResolver
+  pure (fake, started, gate)
+
+testPreviewBound :: IO ()
+testPreviewBound = do
+  (fake, started, gate) <- gatedFake
+  held <- mapM (async . preview fake . addressLink) [0, 1]
+  replicateM_ 2 (atomically $ readTQueue started)
+  (searched, waited) <- concurrently (search fake (addressLink 100)) (preview fake (addressLink 101))
+  searched `shouldBe` ProfileOk (profileFor (addressLink 100))
+  waited `shouldBe` ProfileUnread
+  readTVarIO (fetched fake) >>= (`shouldNotContain` [addressLink 101])
+  atomically $ putTMVar gate ()
+  mapM wait held >>= (`shouldSatisfy` all (`elem` [ProfileUnread, ProfileOk (profileFor (addressLink 0)), ProfileOk (profileFor (addressLink 1))]))
+
+testSearchBound :: IO ()
+testSearchBound = do
+  (fake, started, gate) <- gatedFake
+  held <- mapM (async . search fake . addressLink) [0 .. 3]
+  replicateM_ 4 (atomically $ readTQueue started)
+  (waited, previewed) <- concurrently (search fake (addressLink 100)) (preview fake (addressLink 101))
+  waited `shouldBe` ProfileUnread
+  previewed `shouldBe` ProfileOk (profileFor (addressLink 101))
+  readTVarIO (fetched fake) >>= (`shouldNotContain` [addressLink 100])
+  atomically $ putTMVar gate ()
+  mapM_ wait held
+
+testSlotFreesInTime :: IO ()
+testSlotFreesInTime = do
+  (fake, started, gate) <- gatedFake
+  held <- mapM (async . preview fake . addressLink) [0, 1]
+  replicateM_ 2 (atomically $ readTQueue started)
+  waiting <- async $ preview fake (addressLink 100)
+  threadDelay (testTimeout `div` 5)
+  atomically $ putTMVar gate ()
+  wait waiting `shouldReturn` ProfileOk (profileFor (addressLink 100))
+  mapM wait held `shouldReturn` map (ProfileOk . profileFor . addressLink) [0, 1]
+
+testUnparseableLink :: IO ()
+testUnparseableLink = do
+  fake <- newFake testLimits answerAll publicResolver
+  mapM_ (\l -> preview fake l `shouldReturn` ProfileUnavailable) ["https://smp8.simplex.im/a#x", "simplex:/c#Rk27xN4pDe9Tz1Wb3Yc5Vd7Xf9Hg2Jk4Lm"]
+  fetchCount fake `shouldReturn` 0
+
+-- Host rule
+
+publicHost :: TransportHost
+publicHost = "smp8.simplex.im"
+
+-- | Resolves the names of these tests; any other name does not resolve.
+stubResolver :: TVar [String] -> HostResolver
+stubResolver asked name = do
+  atomically $ modifyTVar' asked (name :)
+  pure $ Map.findWithDefault [] name addresses
+  where
+    addresses =
+      Map.fromList
+        [ ("smp8.simplex.im", ["1.1.1.1", "2606:4700::1111"]),
+          ("loopback.test", ["127.0.0.1"]),
+          ("private.test", ["10.0.0.1"]),
+          ("cgnat.test", ["100.64.0.1"]),
+          ("link-local.test", ["fe80::1"]),
+          ("unique-local.test", ["fd00::1"]),
+          ("mixed.test", ["1.1.1.1", "192.168.1.1"])
+        ]
+
+publicResolver :: HostResolver
+publicResolver _ = pure ["1.1.1.1"]
+
+fetchable :: [TransportHost] -> IO Bool
+fetchable hosts = newTVarIO [] >>= \asked -> hostsFetchable (stubResolver asked) hosts
+
+testPublicHosts :: IO ()
+testPublicHosts = do
+  fetchable ["1.1.1.1"] `shouldReturn` True
+  fetchable ["2606:4700::1111"] `shouldReturn` True
+  fetchable ["smp8.simplex.im"] `shouldReturn` True
+  fetchable ["smp8.simplex.im", "8.8.8.8"] `shouldReturn` True
+
+testPrivateLiterals :: IO ()
+testPrivateLiterals =
+  mapM_ (\h -> (h,) <$> fetchable [h] `shouldReturn` (h, False)) ["127.0.0.1", "10.0.0.1", "172.16.5.4", "192.168.1.1", "100.64.0.1", "169.254.1.1", "::1", "fe80::1", "fd00::1"]
+
+testPrivateNames :: IO ()
+testPrivateNames =
+  mapM_ (\h -> (h,) <$> fetchable [h] `shouldReturn` (h, False)) ["loopback.test", "private.test", "cgnat.test", "link-local.test", "unique-local.test"]
+
+testOtherRefused :: IO ()
+testOtherRefused = do
+  mapM_ (\h -> (h,) <$> fetchable [h] `shouldReturn` (h, False)) ["0.0.0.0", "::", "224.0.0.1", "ff02::1", mapped (127, 0, 0, 1), mapped (10, 0, 0, 1)]
+  fetchable [mapped (1, 1, 1, 1)] `shouldReturn` True
+  fetchable [] `shouldReturn` False
+
+testOnionUnresolvable :: IO ()
+testOnionUnresolvable = do
+  asked <- newTVarIO []
+  hostsFetchable (stubResolver asked) ["abcdefghij234567.onion"] `shouldReturn` False
+  hostsFetchable (stubResolver asked) [THDomainName "abcdefghij234567.ONION."] `shouldReturn` False
+  readTVarIO asked `shouldReturn` []
+  hostsFetchable (stubResolver asked) ["unknown.test"] `shouldReturn` False
+  readTVarIO asked `shouldReturn` ["unknown.test"]
+
+-- | An IPv4-mapped IPv6 address, @::ffff:a.b.c.d@.
+mapped :: (Word32, Word32, Word32, Word32) -> TransportHost
+mapped (a, b, c, d) = THIPv6 (0, 0, 0xffff, a * 0x1000000 + b * 0x10000 + c * 0x100 + d)
+
+testMixedHosts :: IO ()
+testMixedHosts = do
+  fetchable ["smp8.simplex.im", "10.0.0.1"] `shouldReturn` False
+  fetchable ["1.1.1.1", "loopback.test"] `shouldReturn` False
+  fetchable ["mixed.test"] `shouldReturn` False
+
+testRefusedNotFetched :: IO ()
+testRefusedNotFetched = do
+  asked <- newTVarIO []
+  fake@Fake {profiles} <- newFake testLimits answerAll (stubResolver asked)
+  let l = addressLink 1
+  (\(Preview _ r) -> r) <$> linkPreview profiles ETAddress ["smp8.simplex.im", "private.test"] l `shouldReturn` ProfileUnavailable
+  (\Entity {entityPreview = Preview _ r} -> r) <$> linkEntity profiles ETAddress ["127.0.0.1"] l `shouldReturn` ProfileUnavailable
+  fetchCount fake `shouldReturn` 0
+  (\(Preview _ r) -> r) <$> linkPreview profiles ETAddress ["smp8.simplex.im"] l `shouldReturn` ProfileOk (profileFor l)
+  fetchCount fake `shouldReturn` 1
+
+-- Through the chat core
+
+testChatProfiles :: TestParams -> IO ()
+testChatProfiles ps = testChat2 aliceProfile bobProfile test ps
+  where
+    test alice' bob = withRelay ps $ \relay -> do
+      bob ##> "/ad"
+      (address, _) <- getContactLinks bob True
+      (channel, _) <- prepareChannel1Relay "news" bob relay
+      let fetch TestCC {chatController} l = either error (chatProfile chatController 1) (strDecode (B.pack l))
+          Profile {image = bobImage} = bobProfile
+          bobLinkProfile = Just LinkProfile {kind = CKContact, displayName = "bob", fullName = "", image = (\(ImageData i) -> i) <$> bobImage, subscribers = Nothing}
+          news = Just LinkProfile {kind = CKChannel, displayName = "news", fullName = "", image = Nothing, subscribers = Just 1}
+      fetch alice' address `shouldReturn` bobLinkProfile
+      fetch alice' channel `shouldReturn` news
+      fetch bob address `shouldReturn` bobLinkProfile
+      fetch bob channel `shouldReturn` news
diff --git a/tests/Test.hs b/tests/Test.hs
index 0c511ed3ed..06fa3b8322 100644
--- a/tests/Test.hs
+++ b/tests/Test.hs
@@ -11,6 +11,7 @@ import Bots.StoreService.GroupIntegrationTests
 import Bots.StoreService.GroupTests
 import Bots.StoreService.NameRegistrationTests
 import Bots.StoreService.NamesLabelTests
+import Bots.StoreService.NamesProfilesTests
 import Bots.StoreService.NamesSignatureTests
 import Bots.StoreService.NamesWiringTests
 import Bots.StoreService.StripeTests
@@ -91,6 +92,7 @@ main = do
         badgeNameRegistrationTests
       namesConfigTests
       namesLabelTests
+      namesProfilesTests
       namesSignatureTests
       namesWiringTests
       describe "SimpleX chat markdown" markdownTests
@@ -124,6 +126,7 @@ main = do
             storeServiceTests
             describe "managed group" badgeGroupIntegrationTests
           describe "StoreService names: boot" namesBootTests
+          namesProfilesChatTests
           describe "Remote session" remoteTests
 #if !defined(dbPostgres)
           sequential $ xdescribe'' "Save query plans" saveQueryPlans

From 3b9a40176570b5c332ee2269251bca1262b59855 Mon Sep 17 00:00:00 2001
From: shum <github.shum@liber.li>
Date: Wed, 21 Oct 2026 22:59:57 +0000
Subject: [PATCH 3/3] store: give deep links in the core's simplex form

---
 .../src/StoreService/Names/Profiles.hs        | 29 +++++++++--------
 tests/Bots/StoreService/NamesProfilesTests.hs | 31 ++++++++++++++++---
 2 files changed, 43 insertions(+), 17 deletions(-)

diff --git a/apps/simplex-store-service/src/StoreService/Names/Profiles.hs b/apps/simplex-store-service/src/StoreService/Names/Profiles.hs
index e8599db42c..2931540677 100644
--- a/apps/simplex-store-service/src/StoreService/Names/Profiles.hs
+++ b/apps/simplex-store-service/src/StoreService/Names/Profiles.hs
@@ -51,10 +51,10 @@ import Simplex.Chat.Controller (ChatResponse (..), ChatCommand (APIConnectPlan),
 import Simplex.Chat.Core (sendChatCmd)
 import Simplex.Chat.Protocol (ContactShortLinkData (..), GroupShortLinkData (..), PublicGroupData (..))
 import Simplex.Chat.Types (AConnectTarget (..), ChatPeerType (..), Contact (..), ContactNameOrLink (..), ConnectTarget (..), GroupInfo (..), GroupProfile (..), GroupSummary (..), ImageData (..), Profile (..), User (..), fromLocalProfile)
-import Simplex.Messaging.Agent.Protocol (ConnShortLink, ConnectionMode (..), SConnectionMode (..), UserId)
-import Simplex.Messaging.Encoding.String (strDecode)
+import Simplex.Messaging.Agent.Protocol (ConnShortLink, ConnectionMode (..), SConnectionMode (..), UserId, simplexShortLink)
+import Simplex.Messaging.Encoding.String (strDecode, strEncode)
 import Simplex.Messaging.Transport.Client (TransportHost (..))
-import Simplex.Messaging.Util (anyM)
+import Simplex.Messaging.Util (anyM, safeDecodeUtf8)
 import System.Timeout (timeout)
 
 data ProfileLimits = ProfileLimits
@@ -166,26 +166,29 @@ chatKindText = \case
   CKChannel -> "channel"
 
 -- | A search answer's entity, within the search bound. The hosts are the link's servers, every one of which must pass the host rule.
+-- The deep link is the core's @simplex:/@ form, which carries the server; a link the core cannot parse keeps its own text.
 linkEntity :: Profiles -> EntityType -> [TransportHost] -> Text -> IO Entity
 linkEntity ps@Profiles {searchSlots} t hosts link = do
-  r <- boundedProfile ps searchSlots hosts link
-  pure Entity {entityPreview = Preview t r, link, deepLink = deepLinkOf link}
+  r <- boundedProfile ps searchSlots hosts link sl_
+  pure Entity {entityPreview = Preview t r, link, deepLink = maybe link (safeDecodeUtf8 . strEncode . simplexShortLink) sl_}
+  where
+    sl_ = parseShortLink link
 
 -- | A link preview, within the preview bound.
 linkPreview :: Profiles -> EntityType -> [TransportHost] -> Text -> IO Preview
-linkPreview ps@Profiles {previewSlots} t hosts link = Preview t <$> boundedProfile ps previewSlots hosts link
+linkPreview ps@Profiles {previewSlots} t hosts link = Preview t <$> boundedProfile ps previewSlots hosts link (parseShortLink link)
 
-deepLinkOf :: Text -> Text
-deepLinkOf link = maybe link (("simplex:/" <>) . T.drop 1 . T.dropWhile (/= '/')) (T.stripPrefix "https://" link)
+parseShortLink :: Text -> Maybe (ConnShortLink 'CMContact)
+parseShortLink = either (const Nothing) Just . strDecode . encodeUtf8
 
 -- | A link the chat core cannot parse names no server it could fetch from, so it is not fetched.
-boundedProfile :: Profiles -> TVar Int -> [TransportHost] -> Text -> IO ProfileRead
-boundedProfile Profiles {limits = ProfileLimits {fetchTimeout, cacheSeconds, maxCachedProfiles}, clock, fetchLink, resolveHost, cache} slots hosts link =
+boundedProfile :: Profiles -> TVar Int -> [TransportHost] -> Text -> Maybe (ConnShortLink 'CMContact) -> IO ProfileRead
+boundedProfile Profiles {limits = ProfileLimits {fetchTimeout, cacheSeconds, maxCachedProfiles}, clock, fetchLink, resolveHost, cache} slots hosts link sl_ =
   cached >>= \case
     Just p -> pure $ ProfileOk p
-    Nothing -> case strDecode (encodeUtf8 link) of
-      Left _ -> pure ProfileUnavailable
-      Right sl -> fromMaybe ProfileUnread <$> timeout fetchTimeout (checkAndFetch sl)
+    Nothing -> case sl_ of
+      Nothing -> pure ProfileUnavailable
+      Just sl -> fromMaybe ProfileUnread <$> timeout fetchTimeout (checkAndFetch sl)
   where
     cached = do
       now <- clock
diff --git a/tests/Bots/StoreService/NamesProfilesTests.hs b/tests/Bots/StoreService/NamesProfilesTests.hs
index 7dd839b2a2..c5c31b151d 100644
--- a/tests/Bots/StoreService/NamesProfilesTests.hs
+++ b/tests/Bots/StoreService/NamesProfilesTests.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}
@@ -24,14 +25,15 @@ import qualified Data.ByteString.Lazy.Char8 as LB
 import qualified Data.Map.Strict as Map
 import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Text.Encoding (decodeUtf8)
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
 import Data.Time.Clock (diffUTCTime, getCurrentTime)
 import Data.Word (Word32, Word64)
 import Simplex.Chat.Controller (ChatErrorType (..), ChatError (..), ConnectionPlan (..), ContactAddressPlan (..), GroupLinkPlan (..))
 import Simplex.Chat.Protocol (ContactShortLinkData (..), GroupShortLinkData (..), PublicGroupData (..))
 import Simplex.Chat.Types (ChatPeerType (..), GroupProfile (..), ImageData (..), Profile (..))
-import Simplex.Messaging.Agent.Protocol (ConnShortLink, ConnectionMode (..))
+import Simplex.Messaging.Agent.Protocol (ConnShortLink (..), ConnectionMode (..), simplexShortLink)
 import Simplex.Messaging.Encoding.String (strDecode, strEncode)
+import Simplex.Messaging.Protocol (SMPServer)
 import Simplex.Messaging.Transport.Client (TransportHost (..))
 import StoreService.Names.Profiles
 import Test.Hspec hiding (it)
@@ -51,6 +53,7 @@ namesProfilesTests = describe "StoreService names: profiles" $ do
     H.it "encodes a contact entity as the contract's example" testEntityContactJSON
     H.it "encodes a channel entity with subscribers and a simplex:/ deep link" testEntityChannelJSON
     H.it "encodes previews without a profile as empty, kind from the link" testPreviewEmptyJSON
+    H.it "gives a deep link that parses back in the core with the link's server" testDeepLinkParses
   describe "bounds and cache" $ do
     H.it "answers a link again from the cache, and fetches it again once the cache expires" testCacheExpiry
     H.it "does not cache a failed fetch" testFailureNotCached
@@ -167,7 +170,7 @@ testEntityContactJSON = do
   e
     `shouldEncodeAs` "{\"type\": \"address\", \"kind\": \"contact\", \"displayName\": \"Alice's Bakery\", \"fullName\": \"Sourdough and pastries, Lisbon\",\
                      \ \"image\": \"data:image/jpeg;base64,/9j/4AAQSkZJRg==\", \"subscribers\": null, \"profile\": \"ok\",\
-                     \ \"link\": \"https://smp8.simplex.im/a#Y8m3qT0vLw2Ab7cD9eF1gH3jK5mN7pQ9rSAAAAAAAAA\", \"deepLink\": \"simplex:/a#Y8m3qT0vLw2Ab7cD9eF1gH3jK5mN7pQ9rSAAAAAAAAA\"}"
+                     \ \"link\": \"https://smp8.simplex.im/a#Y8m3qT0vLw2Ab7cD9eF1gH3jK5mN7pQ9rSAAAAAAAAA\", \"deepLink\": \"simplex:/a#Y8m3qT0vLw2Ab7cD9eF1gH3jK5mN7pQ9rSAAAAAAAAA?h=smp8.simplex.im\"}"
   where
     bakery = LinkProfile {kind = CKContact, displayName = "Alice's Bakery", fullName = "Sourdough and pastries, Lisbon", image = Just jpeg, subscribers = Nothing}
 
@@ -178,13 +181,33 @@ testEntityChannelJSON = do
   e
     `shouldEncodeAs` "{\"type\": \"channel\", \"kind\": \"channel\", \"displayName\": \"Bakery news\", \"fullName\": \"Daily bakes and opening hours\",\
                      \ \"image\": null, \"subscribers\": 1204, \"profile\": \"ok\",\
-                     \ \"link\": \"https://smp9.simplex.im/c#Rk27xN4pDe9Tz1Wb3Yc5Vd7Xf9Hg2Jk4LmAAAAAAAAA\", \"deepLink\": \"simplex:/c#Rk27xN4pDe9Tz1Wb3Yc5Vd7Xf9Hg2Jk4LmAAAAAAAAA\"}"
+                     \ \"link\": \"https://smp9.simplex.im/c#Rk27xN4pDe9Tz1Wb3Yc5Vd7Xf9Hg2Jk4LmAAAAAAAAA\", \"deepLink\": \"simplex:/c#Rk27xN4pDe9Tz1Wb3Yc5Vd7Xf9Hg2Jk4LmAAAAAAAAA?h=smp9.simplex.im\"}"
   let simplexLink = "simplex:/c#Rk27xN4pDe9Tz1Wb3Yc5Vd7Xf9Hg2Jk4LmAAAAAAAAA?h=smp9.simplex.im"
   Entity {link, deepLink} <- linkEntity ps ETChannel [publicHost] simplexLink
   (link, deepLink) `shouldBe` (simplexLink, simplexLink)
   where
     news = LinkProfile {kind = CKChannel, displayName = "Bakery news", fullName = "Daily bakes and opening hours", image = Nothing, subscribers = Just 1204}
 
+testDeepLinkParses :: IO ()
+testDeepLinkParses = do
+  ps <- quietProfiles answerAll publicResolver
+  mapM_ (deepLinkKeepsServer ps) [bakeryLink, keyedLink, twoHostLink]
+  Entity {deepLink} <- linkEntity ps ETAddress [] "https://smp8.simplex.im/a#x"
+  deepLink `shouldBe` "https://smp8.simplex.im/a#x"
+  where
+    keyedLink = "https://smp.example.com/a#Y8m3qT0vLw2Ab7cD9eF1gH3jK5mN7pQ9rSAAAAAAAAA?p=5224&c=LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI"
+    twoHostLink = "simplex:/c#Rk27xN4pDe9Tz1Wb3Yc5Vd7Xf9Hg2Jk4LmAAAAAAAAA?h=a.example.com%2Cb.example.com"
+    deepLinkKeepsServer ps l = do
+      Entity {deepLink} <- linkEntity ps ETAddress [publicHost] l
+      let original = parseLink l
+          reparsed = parseLink deepLink
+      ("simplex:/" `T.isPrefixOf` deepLink, serverOf <$> reparsed) `shouldBe` (True, serverOf <$> original)
+      reparsed `shouldBe` (simplexShortLink <$> original)
+    parseLink :: Text -> Either String (ConnShortLink 'CMContact)
+    parseLink = strDecode . encodeUtf8
+    serverOf :: ConnShortLink 'CMContact -> SMPServer
+    serverOf (CSLContact _ _ srv _) = srv
+
 testPreviewEmptyJSON :: IO ()
 testPreviewEmptyJSON = do
   Preview ETChannel ProfileUnread