wip

apps/simplex-directory-service/src/Directory/Events.hs

@@ -25,6 +25,7 @@ import Control.Applicative (optional, (<|>))
 import Data.Attoparsec.Text (Parser)
 import qualified Data.Attoparsec.Text as A
 import Data.Char (isSpace)
+import qualified Data.Aeson as J
 import Data.Either (fromRight)
 import Data.Functor (($>))
 import Data.Maybe (fromMaybe, isNothing)
@@ -66,6 +67,7 @@ data DirectoryEvent
   | DEItemEditIgnored Contact
   | DEItemDeleteIgnored Contact
   | DEContactCommand Contact ChatItemId ADirectoryCmd
+  | DEServiceRequest AgentInvId J.Object
   | DELogChatResponse Text
   deriving (Show)
 
@@ -110,6 +112,7 @@ crDirectoryEvent_ = \case
     where
       ciId = chatItemId' ci
       err = ADC SDRUser DCUnknownCommand
+  CEvtServiceRequest {requestId, requestData} -> Just $ DEServiceRequest requestId requestData
   CEvtMessageError {severity, errorMessage} -> Just $ DELogChatResponse $ "message error: " <> severity <> ", " <> errorMessage
   CEvtChatErrors {chatErrors} -> Just $ DELogChatResponse $ "chat errors: " <> T.intercalate ", " (map tshow chatErrors)
   _ -> Nothing

apps/simplex-directory-service/src/Directory/Listing.hs

@@ -123,13 +123,8 @@ groupDirectoryEntry now g@GroupInfo {groupProfile, chatTs, createdAt, groupSumma
                 }
             imgData = imgFileData groupLink =<< image
          in (de, imgData)
-   in case publicGroup of
-        Just PublicGroupProfile {groupLink = sLnk} ->
-          Just $ entry $ PublicLink Nothing (Just sLnk)
-        Nothing ->
-          entry . toPublicLink . connLinkContact <$> gLink_
+   in entry <$> groupPublicLink g gLink_
   where
-    toPublicLink (CCLink fullLink shortLink) = PublicLink (Just fullLink) shortLink
     imgFileData :: PublicLink -> ImageData -> Maybe (FilePath, ByteString)
     imgFileData PublicLink {connFullLink, connShortLink} (ImageData img) =
       let (img', imgExt) =
@@ -145,6 +140,14 @@ groupDirectoryEntry now g@GroupInfo {groupProfile, chatTs, createdAt, groupSumma
             Right img'' -> Just (imgFile, img'')
             Left _ -> Nothing
 
+-- a public group publishes its own link in the profile; other groups only have the link the service created
+groupPublicLink :: GroupInfo -> Maybe GroupLink -> Maybe PublicLink
+groupPublicLink GroupInfo {groupProfile = GroupProfile {publicGroup}} gLink_ = case publicGroup of
+  Just PublicGroupProfile {groupLink = sLnk} -> Just $ PublicLink Nothing (Just sLnk)
+  Nothing -> toPublicLink . connLinkContact <$> gLink_
+  where
+    toPublicLink (CCLink fullLink shortLink) = PublicLink (Just fullLink) shortLink
+
 generateListing :: FilePath -> [(GroupInfo, GroupReg, Maybe GroupLink)] -> IO ()
 generateListing dir gs = do
   createDirectoryIfMissing True dir

apps/simplex-directory-service/src/Directory/Rpc.hs

@@ -0,0 +1,67 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
+
+module Directory.Rpc where
+
+import qualified Data.Aeson.TH as JQ
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import Data.Time.Clock (UTCTime)
+import Directory.Listing
+import Directory.Search
+import Directory.Store
+import Simplex.Chat.Types
+import Simplex.Messaging.SimplexName (SimplexNameInfo (..), SimplexNameType (..), shortNameInfoStr)
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON)
+
+data DirectoryRequest = DRSearch
+  { searchText :: Text,
+    -- opaque to the client: it is stored and echoed back, never inspected
+    searchCursor :: Maybe SearchCursor
+  }
+
+data DirectorySearchEntry = DirectorySearchEntry
+  { entryType :: DirectoryEntryType,
+    displayName :: Text,
+    simplexName :: Maybe Text,
+    groupLink :: PublicLink,
+    -- stored text, not DirectoryEntry's MarkdownList: the apps parse markdown locally
+    shortDescr :: Maybe Text,
+    image :: Maybe ImageData,
+    activeAt :: Maybe UTCTime,
+    createdAt :: Maybe UTCTime
+  }
+
+data DirectoryResponse
+  = DRSearchResults
+      { entries :: [DirectorySearchEntry],
+        searchCursor :: Maybe SearchCursor -- Nothing when there are no more results
+      }
+  | DRError {errorMessage :: Text}
+
+$(JQ.deriveJSON defaultJSON ''DirectorySearchEntry)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "DR") ''DirectoryRequest)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "DR") ''DirectoryResponse)
+
+-- Entries without any link are dropped: there would be nothing to connect to.
+searchEntry :: UTCTime -> GroupInfo -> Maybe GroupLink -> Maybe DirectorySearchEntry
+searchEntry now g@GroupInfo {groupProfile, chatTs, createdAt = groupCreatedAt, groupSummary} gLink_ =
+  entry <$> groupPublicLink g gLink_
+  where
+    GroupProfile {displayName, shortDescr, image, memberAdmission, publicGroup} = groupProfile
+    entry groupLink =
+      DirectorySearchEntry
+        { entryType = DETGroup ((\PublicGroupProfile {groupType} -> groupType) <$> publicGroup) memberAdmission groupSummary,
+          displayName,
+          simplexName = shortNameInfoStr . SimplexNameInfo NTPublicGroup <$> verifiedGroupDomain g,
+          groupLink,
+          shortDescr,
+          image,
+          activeAt = recentRoundedTime 900 now $ fromMaybe groupCreatedAt chatTs,
+          createdAt = recentRoundedTime 86400 now groupCreatedAt
+        }

apps/simplex-directory-service/src/Directory/Search.hs

@@ -1,9 +1,13 @@
+{-# LANGUAGE TemplateHaskell #-}
+
 module Directory.Search where
 
+import qualified Data.Aeson.TH as JQ
 import Data.Int (Int64)
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Simplex.Chat.Types
+import Simplex.Messaging.Parsers (defaultJSON)
 
 data SearchRequest = SearchRequest
   { searchType :: SearchType,
@@ -20,3 +24,5 @@ data SearchCursor = SearchCursor
   }
 
 data SearchType = STAll | STRecent | STSearch Text
+
+$(JQ.deriveJSON defaultJSON ''SearchCursor)

apps/simplex-directory-service/src/Directory/Service.hs

@@ -20,17 +20,22 @@ where
 
 import Control.Concurrent (forkIO, threadDelay)
 import Control.Concurrent.STM
-import Control.Exception (SomeException, try)
+import Control.Exception (SomeException, finally, try)
 import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Class
 import qualified Data.Attoparsec.Text as A
+import qualified Data.Aeson as J
+import qualified Data.Aeson.Types as JT
 import Data.Bifunctor (first)
-import Data.Either (fromRight)
+import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Either (fromRight, isRight)
+import Data.Foldable (foldl')
 import Data.List (find, intercalate)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.Map.Strict as M
+import Data.Functor (($>))
 import Data.Maybe (fromMaybe, isJust, isNothing, maybeToList)
 import qualified Data.Set as S
 import Data.Text (Text)
@@ -43,6 +48,7 @@ import Directory.Captcha
 import Directory.Events
 import Directory.Listing
 import Directory.Options
+import Directory.Rpc
 import Directory.Search
 import Directory.Store
 import Directory.Store.Migrate
@@ -54,7 +60,7 @@ import Simplex.Chat.Core
 import Simplex.Chat.Markdown (Format (..), FormattedText (..), SimplexLinkType (..), parseMaybeMarkdownList, viewName)
 import Simplex.Chat.Messages
 import Simplex.Chat.Options
-import Simplex.Chat.Protocol (GroupShortLinkData (..), LinkOwnerSig (..), MsgChatLink (..), MsgContent (..), memberSupportVoiceVersion)
+import Simplex.Chat.Protocol (GroupShortLinkData (..), compressServiceBody, LinkOwnerSig (..), MsgChatLink (..), MsgContent (..), memberSupportVoiceVersion)
 import Simplex.Chat.Store.Direct (getContact)
 import Simplex.Chat.Store.Groups (getGroupLink, getGroupMember, getGroupMemberByMemberId, setGroupCustomData) -- TODO remove setGroupCustomData
 import Simplex.Chat.Store.Profiles (GroupLinkInfo (..), getGroupLinkInfo)
@@ -103,7 +109,9 @@ data ServiceState = ServiceState
     pendingCaptchas :: TMap GroupMemberId PendingCaptcha,
     serviceCC :: TMVar ChatController,
     eventQ :: TQueue DirectoryEvent,
-    updateListingsJob :: TMVar ()
+    updateListingsJob :: TMVar (),
+    -- service requests carry no caller identity, so the only possible bound is global
+    serviceRequestsInFlight :: TVar Int
   }
 
 data CaptchaMode = CMText | CMAudio
@@ -132,7 +140,14 @@ newServiceState opts = do
   serviceCC <- newEmptyTMVarIO
   eventQ <- newTQueueIO
   updateListingsJob <- newEmptyTMVarIO
-  pure ServiceState {searchRequests, blockedWordsCfg, pendingCaptchas, serviceCC, eventQ, updateListingsJob}
+  serviceRequestsInFlight <- newTVarIO 0
+  pure ServiceState {searchRequests, blockedWordsCfg, pendingCaptchas, serviceCC, eventQ, updateListingsJob, serviceRequestsInFlight}
+
+-- Requests are answered off the event loop, which is shared with registrations and captchas,
+-- so the bound has to be here rather than in the loop. Over the bound requests are refused
+-- immediately: a caller gets an error rather than waiting out its timeout.
+maxServiceRequestsInFlight :: Int
+maxServiceRequestsInFlight = 8
 
 welcomeGetOpts :: IO DirectoryOpts
 welcomeGetOpts = do
@@ -318,7 +333,7 @@ readBlockedWordsConfig DirectoryOpts {blockedFragmentsFile, blockedWordsFile, na
   pure BlockedWordsConfig {blockedFragments, blockedWords, extensionRules, spelling}
 
 directoryServiceEvent :: DirectoryOpts -> ServiceState -> User -> ChatController -> DirectoryEvent -> IO ()
-directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults, prohibitedToObserver, alwaysCaptcha} env@ServiceState {searchRequests} user@User {userId} cc = \case
+directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults, prohibitedToObserver, alwaysCaptcha} env@ServiceState {searchRequests, serviceRequestsInFlight} user@User {userId} cc = \case
     DEContactConnected ct -> deContactConnected ct
     DEGroupInvitation {contact = ct, groupInfo = g, fromMemberRole, memberRole} -> deGroupInvitation ct g fromMemberRole memberRole
     DEServiceJoinedGroup ctId g owner -> deServiceJoinedGroup ctId g owner
@@ -344,8 +359,64 @@ directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, o
         SDRUser -> deUserCommand ct ciId cmd
         SDRAdmin -> deAdminCommand ct ciId cmd
         SDRSuperUser -> deSuperUserCommand ct ciId cmd
+    DEServiceRequest reqId req -> deServiceRequest reqId req
     DELogChatResponse r -> logInfo r
   where
+    deServiceRequest :: AgentInvId -> J.Object -> IO ()
+    deServiceRequest reqId req = do
+      accepted <- atomically $ stateTVar serviceRequestsInFlight $ \n ->
+        if n < maxServiceRequestsInFlight then (True, n + 1) else (False, n)
+      if accepted
+        then void $ forkIO $ (respond =<< requestResponse) `finally` releaseSlot
+        else reject "service is busy"
+      where
+        releaseSlot = atomically $ modifyTVar' serviceRequestsInFlight (subtract 1)
+        -- rejecting is cheaper than answering and fails the caller immediately
+        reject reason =
+          sendChatCmd cc (APIRejectServiceRequest userId reqId $ Just reason) >>= \case
+            Right _ -> pure ()
+            Left e -> logError $ "service reject error: " <> tshow e
+        requestResponse = case JT.parseMaybe JT.parseJSON (J.Object req) of
+          Nothing -> pure $ DRError "unsupported request"
+          Just DRSearch {searchText, searchCursor} -> directorySearch searchText searchCursor
+        respond resp = case J.toJSON resp of
+          J.Object o ->
+            sendChatCmd cc (APISendServiceResponse userId reqId o) >>= \case
+              Right _ -> pure ()
+              Left e -> logError $ "service response error: " <> tshow e
+          _ -> logError "service response is not an object"
+    directorySearch :: Text -> Maybe SearchCursor -> IO DirectoryResponse
+    directorySearch searchText cursor_ =
+      searchListedGroups cc user (STSearch searchText) cursor_ searchResults >>= \case
+        Left e -> logError ("searchListedGroups error: " <> T.pack e) $> DRError "search failed"
+        Right (gs, _) ->
+          getGroupLinks cc user (map fst gs) >>= \case
+            Left e -> logError ("getGroupLinks error: " <> T.pack e) $> DRError "search failed"
+            Right links -> do
+              now <- getCurrentTime
+              -- rows without a link are dropped, so entries and their cursors must stay paired
+              let rows = [(gr, e) | (gr, Just e) <- zipWith (\gr@(g, _) l -> (gr, searchEntry now g l)) gs links]
+              pure $ searchResults_ $ fitRows rows
+      where
+        -- send as many entries as the padded envelope allows; a lone entry that does not fit
+        -- is sent without its image, so paging always makes progress
+        fitRows [] = []
+        fitRows rows
+          | fits rows = rows
+          | [(gr, e)] <- rows = [(gr, dropImage e)]
+          | otherwise = fitRows $ init rows
+        dropImage :: DirectorySearchEntry -> DirectorySearchEntry
+        dropImage e = e {image = Nothing}
+        fits = isRight . compressServiceBody . LB.toStrict . J.encode . searchResults_
+        searchResults_ rows =
+          DRSearchResults
+            { entries = map snd rows,
+              -- the cursor is the last row actually sent, so truncated rows are not skipped
+              searchCursor = rowCursor . fst <$> lastMaybe rows
+            }
+        lastMaybe = foldl' (\_ x -> Just x) Nothing
+        rowCursor (GroupInfo {groupId, groupSummary = GroupSummary {currentMembers}}, GroupReg {createdAt}) =
+          SearchCursor {lastMembers = currentMembers, lastCreatedAt = createdAt, lastGroupId = groupId}
     groupLinkText (CCLink cReq sLnk_) = maybe (strEncodeTxt $ simplexChatContact cReq) strEncodeTxt sLnk_
     withAdminUsers action = void . forkIO $ do
       forM_ superUsers $ \KnownContact {contactId} -> action contactId

apps/simplex-directory-service/src/Directory/Store.hs

@@ -38,6 +38,7 @@ module Directory.Store
     listPendingGroups,
     getAllListedGroups,
     getAllListedGroups_,
+    getGroupLinks,
     searchListedGroups,
     verifiedGroupDomain,
     groupRegStatusText,
@@ -340,6 +341,12 @@ getAllListedGroups_ db cxt user@User {userId, userContactId} = do
   where
     withGroupLink (g, gr) = (g,gr,) . eitherToMaybe <$> runExceptT (getGroupLink db user g)
 
+-- only the RPC search needs links, so they are read for the returned page rather than in the search query
+getGroupLinks :: ChatController -> User -> [GroupInfo] -> IO (Either String [Maybe GroupLink])
+getGroupLinks cc user gs =
+  withDB' "getGroupLinks" cc $ \db ->
+    mapM (\g -> eitherToMaybe <$> runExceptT (getGroupLink db user g)) gs
+
 searchListedGroups :: ChatController -> User -> SearchType -> Maybe SearchCursor -> Int -> IO (Either String ([(GroupInfo, GroupReg)], Int))
 searchListedGroups cc user@User {userId, userContactId} searchType cursor_ pageSize =
   withDB' "searchListedGroups" cc $ \db -> do