diff --git a/apps/simplex-store-service/src/StoreService/Names/Links.hs b/apps/simplex-store-service/src/StoreService/Names/Links.hs index 72fa71040e..ec606b3af4 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Links.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Links.hs @@ -7,6 +7,8 @@ module StoreService.Names.Links ( LinkKind (..), linkMaxBytes, linkKindOf, + parseShortLink, + shortLinkHosts, linkHosts, ) where @@ -16,6 +18,7 @@ import Data.Attoparsec.Text (Parser) import qualified Data.Attoparsec.Text as A import qualified Data.ByteString as B import Data.Char (isAsciiLower, isAsciiUpper, isDigit) +import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) @@ -50,9 +53,13 @@ shortLinkP = do -- simplexmq escapes the comma between a link's hosts, and no other character of its query hostSeparator = "%2C" +-- the link as the chat core reads it +parseShortLink :: Text -> Maybe (ConnShortLink 'CMContact) +parseShortLink = either (const Nothing) Just . strDecode . encodeUtf8 + +shortLinkHosts :: ConnShortLink 'CMContact -> NonEmpty TransportHost +shortLinkHosts (CSLContact _ _ ProtocolServer {host} _) = host + -- the hosts as the chat core reads them, empty for a link it cannot read linkHosts :: Text -> [TransportHost] -linkHosts = either (const []) hosts . strDecode . encodeUtf8 - where - hosts :: ConnShortLink 'CMContact -> [TransportHost] - hosts (CSLContact _ _ ProtocolServer {host} _) = L.toList host +linkHosts = maybe [] (L.toList . shortLinkHosts) . parseShortLink diff --git a/apps/simplex-store-service/src/StoreService/Names/Profiles.hs b/apps/simplex-store-service/src/StoreService/Names/Profiles.hs index 2931540677..b1724050fd 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Profiles.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Profiles.hs @@ -10,7 +10,6 @@ module StoreService.Names.Profiles ProfileLimits (..), ProfileFetcher, HostResolver, - EntityType (..), ChatKind (..), LinkProfile (..), ProfileRead (..), @@ -38,12 +37,13 @@ import Data.Bits (shiftL, shiftR, (.|.)) import Data.Char (toLower) import Data.Int (Int64) import Data.List (dropWhileEnd, isSuffixOf) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as L 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) @@ -52,9 +52,10 @@ 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, simplexShortLink) -import Simplex.Messaging.Encoding.String (strDecode, strEncode) +import Simplex.Messaging.Encoding.String (strEncode) import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Util (anyM, safeDecodeUtf8) +import StoreService.Names.Links (LinkKind (..), parseShortLink, shortLinkHosts) import System.Timeout (timeout) data ProfileLimits = ProfileLimits @@ -102,10 +103,6 @@ newProfiles limits@ProfileLimits {searchFetchSlots, previewFetchSlots} clock fet 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) @@ -121,7 +118,7 @@ data LinkProfile = LinkProfile data ProfileRead = ProfileOk LinkProfile | ProfileUnread | ProfileUnavailable deriving (Eq, Show) -data Preview = Preview {previewType :: EntityType, previewProfile :: ProfileRead} +data Preview = Preview {previewType :: LinkKind, previewProfile :: ProfileRead} deriving (Eq, Show) data Entity = Entity {entityPreview :: Preview, link :: Text, deepLink :: Text} @@ -135,7 +132,7 @@ instance J.ToJSON Entity where previewPairs :: Preview -> [JT.Pair] previewPairs (Preview t r) = - [ "type" .= entityTypeText t, + [ "type" .= linkKindText t, "kind" .= chatKindText kind, "displayName" .= displayName, "fullName" .= fullName, @@ -148,15 +145,16 @@ previewPairs (Preview t r) = 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 + emptyProfile = LinkProfile {kind = chatKind t, displayName = "", fullName = "", image = Nothing, subscribers = Nothing} + chatKind = \case + LKContact -> CKContact + LKChannel -> CKChannel -entityTypeText :: EntityType -> Text -entityTypeText = \case - ETAddress -> "address" - ETChannel -> "channel" +-- | The record the link came from, as the contract names it: @simplex.contact@ holds an address. +linkKindText :: LinkKind -> Text +linkKindText = \case + LKContact -> "address" + LKChannel -> "channel" chatKindText :: ChatKind -> Text chatKindText = \case @@ -165,25 +163,22 @@ chatKindText = \case 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. +-- | A search answer's entity, within the search bound. Every server host of the link 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 sl_ +linkEntity :: Profiles -> LinkKind -> Text -> IO Entity +linkEntity ps@Profiles {searchSlots} t link = do + r <- boundedProfile ps searchSlots 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 (parseShortLink link) - -parseShortLink :: Text -> Maybe (ConnShortLink 'CMContact) -parseShortLink = either (const Nothing) Just . strDecode . encodeUtf8 +linkPreview :: Profiles -> LinkKind -> Text -> IO Preview +linkPreview ps@Profiles {previewSlots} t link = Preview t <$> boundedProfile ps previewSlots link (parseShortLink 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 -> Maybe (ConnShortLink 'CMContact) -> IO ProfileRead -boundedProfile Profiles {limits = ProfileLimits {fetchTimeout, cacheSeconds, maxCachedProfiles}, clock, fetchLink, resolveHost, cache} slots hosts link sl_ = +boundedProfile :: Profiles -> TVar Int -> Text -> Maybe (ConnShortLink 'CMContact) -> IO ProfileRead +boundedProfile Profiles {limits = ProfileLimits {fetchTimeout, cacheSeconds, maxCachedProfiles}, clock, fetchLink, resolveHost, cache} slots link sl_ = cached >>= \case Just p -> pure $ ProfileOk p Nothing -> case sl_ of @@ -194,7 +189,7 @@ boundedProfile Profiles {limits = ProfileLimits {fetchTimeout, cacheSeconds, max 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 + hostsFetchable resolveHost (shortLinkHosts sl) >>= \case False -> pure ProfileUnavailable True -> withSlot (fetchLink sl) >>= maybe (pure ProfileUnread) (\p -> ProfileOk p <$ remember p) withSlot = @@ -266,10 +261,8 @@ imageURI (ImageData 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) +hostsFetchable :: HostResolver -> NonEmpty TransportHost -> IO Bool +hostsFetchable resolve hosts = not <$> anyM (map refused $ L.toList hosts) where refused = \case THDomainName name diff --git a/tests/Bots/StoreService/NamesProfilesTests.hs b/tests/Bots/StoreService/NamesProfilesTests.hs index c5c31b151d..be0f1948e7 100644 --- a/tests/Bots/StoreService/NamesProfilesTests.hs +++ b/tests/Bots/StoreService/NamesProfilesTests.hs @@ -22,6 +22,7 @@ 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.List.NonEmpty as L import qualified Data.Map.Strict as Map import Data.Text (Text) import qualified Data.Text as T @@ -35,6 +36,7 @@ import Simplex.Messaging.Agent.Protocol (ConnShortLink (..), ConnectionMode (..) import Simplex.Messaging.Encoding.String (strDecode, strEncode) import Simplex.Messaging.Protocol (SMPServer) import Simplex.Messaging.Transport.Client (TransportHost (..)) +import StoreService.Names.Links (LinkKind (..)) import StoreService.Names.Profiles import Test.Hspec hiding (it) import qualified Test.Hspec as H @@ -166,7 +168,7 @@ 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 <- linkEntity ps LKContact 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\",\ @@ -177,13 +179,13 @@ testEntityContactJSON = do testEntityChannelJSON :: IO () testEntityChannelJSON = do ps <- quietProfiles (pure . Just . const news) publicResolver - e <- linkEntity ps ETChannel [publicHost] newsLink + e <- linkEntity ps LKChannel 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?h=smp9.simplex.im\"}" let simplexLink = "simplex:/c#Rk27xN4pDe9Tz1Wb3Yc5Vd7Xf9Hg2Jk4LmAAAAAAAAA?h=smp9.simplex.im" - Entity {link, deepLink} <- linkEntity ps ETChannel [publicHost] simplexLink + Entity {link, deepLink} <- linkEntity ps LKChannel 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} @@ -192,13 +194,13 @@ 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" + Entity {deepLink} <- linkEntity ps LKContact "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 + Entity {deepLink} <- linkEntity ps LKContact l let original = parseLink l reparsed = parseLink deepLink ("simplex:/" `T.isPrefixOf` deepLink, serverOf <$> reparsed) `shouldBe` (True, serverOf <$> original) @@ -210,11 +212,11 @@ testDeepLinkParses = do testPreviewEmptyJSON :: IO () testPreviewEmptyJSON = do - Preview ETChannel ProfileUnread + Preview LKChannel ProfileUnread `shouldEncodeAs` "{\"type\": \"channel\", \"kind\": \"channel\", \"displayName\": \"\", \"fullName\": \"\", \"image\": null, \"subscribers\": null, \"profile\": \"unread\"}" - Preview ETAddress ProfileUnavailable + Preview LKContact 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}) + Preview LKContact (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 @@ -248,7 +250,10 @@ 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 '.')))) +addressLink = addressLinkAt "smp8.simplex.im" + +addressLinkAt :: Text -> Int -> Text +addressLinkAt host n = "https://" <> host <> "/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} @@ -260,10 +265,10 @@ 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 +preview Fake {profiles} l = (\(Preview _ r) -> r) <$> linkPreview profiles LKContact l search :: Fake -> Text -> IO ProfileRead -search Fake {profiles} l = (\Entity {entityPreview = Preview _ r} -> r) <$> linkEntity profiles ETAddress [publicHost] l +search Fake {profiles} l = (\Entity {entityPreview = Preview _ r} -> r) <$> linkEntity profiles LKContact l testCacheExpiry :: IO () testCacheExpiry = do @@ -370,9 +375,6 @@ testUnparseableLink = do -- 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 @@ -394,7 +396,7 @@ publicResolver :: HostResolver publicResolver _ = pure ["1.1.1.1"] fetchable :: [TransportHost] -> IO Bool -fetchable hosts = newTVarIO [] >>= \asked -> hostsFetchable (stubResolver asked) hosts +fetchable hosts = newTVarIO [] >>= \asked -> hostsFetchable (stubResolver asked) (L.fromList hosts) testPublicHosts :: IO () testPublicHosts = do @@ -415,15 +417,14 @@ 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 + hostsFetchable (stubResolver asked) (L.singleton "abcdefghij234567.onion") `shouldReturn` False + hostsFetchable (stubResolver asked) (L.singleton $ THDomainName "abcdefghij234567.ONION.") `shouldReturn` False readTVarIO asked `shouldReturn` [] - hostsFetchable (stubResolver asked) ["unknown.test"] `shouldReturn` False + hostsFetchable (stubResolver asked) (L.singleton "unknown.test") `shouldReturn` False readTVarIO asked `shouldReturn` ["unknown.test"] -- | An IPv4-mapped IPv6 address, @::ffff:a.b.c.d@. @@ -441,10 +442,10 @@ 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 + (\(Preview _ r) -> r) <$> linkPreview profiles LKContact (l <> "?h=private.test") `shouldReturn` ProfileUnavailable + (\Entity {entityPreview = Preview _ r} -> r) <$> linkEntity profiles LKContact (addressLinkAt "127.0.0.1" 1) `shouldReturn` ProfileUnavailable fetchCount fake `shouldReturn` 0 - (\(Preview _ r) -> r) <$> linkPreview profiles ETAddress ["smp8.simplex.im"] l `shouldReturn` ProfileOk (profileFor l) + (\(Preview _ r) -> r) <$> linkPreview profiles LKContact l `shouldReturn` ProfileOk (profileFor l) fetchCount fake `shouldReturn` 1 -- Through the chat core