diff --git a/apps/simplex-store-service/src/StoreService/Names/Env.hs b/apps/simplex-store-service/src/StoreService/Names/Env.hs index 4743669d47..a8c4442618 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Env.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Env.hs @@ -8,6 +8,7 @@ import Simplex.Messaging.Agent.Store.Common (DBStore) import StoreService.Config (NamesConfig (..)) import StoreService.Names.Chain (ChainClient, newChainClient) 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 @@ -17,7 +18,8 @@ data NamesEnv = NamesEnv neStore :: DBStore, nePhases :: Phases, neTurns :: Turns, - neChain :: ChainClient + neChain :: ChainClient, + neProfiles :: Profiles } newNamesEnv :: ChatController -> UserId -> NamesConfig -> DBStore -> IO NamesEnv @@ -25,4 +27,5 @@ newNamesEnv neChat@ChatController {random} neUserId neConfig@NamesConfig {nChain nePhases <- newPhases neTurns <- newTurns neChain <- newChainClient random nChain - pure NamesEnv {neChat, neUserId, neConfig, neStore, nePhases, neTurns, neChain} + neProfiles <- newProfiles defaultProfileLimits monotonicSeconds (chatProfile neChat neUserId) systemResolver + pure NamesEnv {neChat, neUserId, neConfig, neStore, nePhases, neTurns, neChain, 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..2931540677 --- /dev/null +++ b/apps/simplex-store-service/src/StoreService/Names/Profiles.hs @@ -0,0 +1,334 @@ +{-# 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, simplexShortLink) +import Simplex.Messaging.Encoding.String (strDecode, strEncode) +import Simplex.Messaging.Transport.Client (TransportHost (..)) +import Simplex.Messaging.Util (anyM, safeDecodeUtf8) +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. +-- 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_ + 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 + +-- | 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_ = + cached >>= \case + Just p -> pure $ ProfileOk p + Nothing -> case sl_ of + Nothing -> pure ProfileUnavailable + Just 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 47643c7784..d2fb222221 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -448,6 +448,7 @@ executable simplex-store-service StoreService.Names.Label StoreService.Names.Links StoreService.Names.Phases + StoreService.Names.Profiles StoreService.Names.Registration StoreService.Names.Revert StoreService.Names.Signatures @@ -754,6 +755,7 @@ test-suite simplex-chat-test Bots.StoreService.NamesChainTests Bots.StoreService.NamesLabelTests Bots.StoreService.NamesLinksTests + Bots.StoreService.NamesProfilesTests Bots.StoreService.NamesSignatureTests Bots.StoreService.NamesStoreTests Bots.StoreService.NamesWiringTests @@ -784,6 +786,7 @@ test-suite simplex-chat-test StoreService.Names.Label StoreService.Names.Links StoreService.Names.Phases + StoreService.Names.Profiles StoreService.Names.Registration StoreService.Names.Revert StoreService.Names.Signatures diff --git a/tests/Bots/StoreService/NamesProfilesTests.hs b/tests/Bots/StoreService/NamesProfilesTests.hs new file mode 100644 index 0000000000..c5c31b151d --- /dev/null +++ b/tests/Bots/StoreService/NamesProfilesTests.hs @@ -0,0 +1,466 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# 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, 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 (..), 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) +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 + 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 + 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?h=smp8.simplex.im\"}" + 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?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 + `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 02e8a56702..e2622cba97 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -13,6 +13,7 @@ import Bots.StoreService.NameRegistrationTests import Bots.StoreService.NamesChainTests import Bots.StoreService.NamesLabelTests import Bots.StoreService.NamesLinksTests +import Bots.StoreService.NamesProfilesTests import Bots.StoreService.NamesSignatureTests import Bots.StoreService.NamesStoreTests import Bots.StoreService.NamesWiringTests @@ -96,6 +97,7 @@ main = do namesChainTests namesLabelTests namesLinksTests + namesProfilesTests namesSignatureTests namesStoreTests namesWiringTests @@ -130,6 +132,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