Merge branch 'stable'

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

@@ -204,7 +204,7 @@ linkCheckThread_ opts env@ServiceState {eventQ}
         threadDelay $ linkCheckInterval opts * 1000000
         u <- readTVarIO $ currentUser cc
         forM_ u $ \user ->
-          withDB' "linkCheckThread" cc (\db -> getAllGroupRegs_ db user) >>= \case
+          withDB' "linkCheckThread" cc (\db -> getAllGroupRegs_ db (storeCxt cc) user) >>= \case
             Left e -> logError $ "linkCheckThread error: " <> T.pack e
             Right grs -> forM_ grs $ \(gInfo, gr) ->
               unless (groupRemoved $ groupRegStatus gr) $
@@ -462,7 +462,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
 
     getOwnerGroupMember :: GroupId -> GroupReg -> IO (Either String GroupMember)
     getOwnerGroupMember gId GroupReg {dbOwnerMemberId} = case dbOwnerMemberId of
-      Just mId -> withDB "getGroupMember" cc $ \db -> withExceptT show $ getGroupMember db (vr cc) user gId mId
+      Just mId -> withDB "getGroupMember" cc $ \db -> withExceptT show $ getGroupMember db (storeCxt cc) user gId mId
       Nothing -> pure $ Left "no owner member in group registration"
 
     deServiceJoinedGroup :: ContactId -> GroupInfo -> GroupMember -> IO ()
@@ -556,7 +556,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
             Right (CRConnectionPlan _ _ (CPGroupLink (GLPKnown {groupInfo = g'}))) ->
               case dbOwnerMemberId gr of
                 Just ownerGMId ->
-                  withDB "getGroupMember" cc (\db -> withExceptT show $ getGroupMember db (vr cc) user groupId ownerGMId) >>= \case
+                  withDB "getGroupMember" cc (\db -> withExceptT show $ getGroupMember db (storeCxt cc) user groupId ownerGMId) >>= \case
                     Right ownerMember
                       | let GroupMember {memberRole = role} = ownerMember, role >= GROwner ->
                           setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval n') (`updatedNotification` g')
@@ -813,7 +813,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
           _ -> False
         checkValidOwner dbOwnerMemberId owners onValid = case dbOwnerMemberId of
           Just ownerGMId ->
-            withDB "checkGroupLink" cc (\db -> withExceptT show $ getGroupMember db (vr cc) user groupId ownerGMId) >>= \case
+            withDB "checkGroupLink" cc (\db -> withExceptT show $ getGroupMember db (storeCxt cc) user groupId ownerGMId) >>= \case
               Right GroupMember {memberId, memberPubKey}
                 | any (\GroupLinkOwner {memberId = mId, memberKey} -> memberId == mId && memberPubKey == Just memberKey) owners -> onValid
               _ -> setGroupStatus logError st env cc groupId GRSSuspendedBadRoles $ \gr' ->
@@ -985,7 +985,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
           addGroupReg notifyAdminUsers st cc ct gInfo GRSProposed $ \_ -> pure ()
           sendChatCmd cc (APIConnectPreparedGroup gId False (Just ownerContact) Nothing) >>= \case
             Right CRStartedConnectionToGroup {groupInfo = gInfo'} ->
-              withDB "getGroupMember" cc (\db -> withExceptT show $ getGroupMemberByMemberId db (vr cc) user gInfo' mId) >>= \case
+              withDB "getGroupMember" cc (\db -> withExceptT show $ getGroupMemberByMemberId db (storeCxt cc) user gInfo' mId) >>= \case
                 Right ownerMember ->
                   void $ setGroupRegOwner cc gId ownerMember
                 Left e -> do
@@ -998,7 +998,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
     deReregistration ct g@GroupInfo {groupId, groupProfile = GroupProfile {publicGroup = pg_}} profileChanged LinkOwnerSig {ownerId = Just (B64UrlByteString oIdBytes)} = do
       let mId = MemberId oIdBytes
           gt = maybe "group" groupTypeStr' pg_
-      withDB "getGroupMemberByMemberId" cc (\db -> withExceptT show $ getGroupMemberByMemberId db (vr cc) user g mId) >>= \case
+      withDB "getGroupMemberByMemberId" cc (\db -> withExceptT show $ getGroupMemberByMemberId db (storeCxt cc) user g mId) >>= \case
         Right ownerMember@GroupMember {memberRole = role, memberStatus} ->
           if
             | role >= GROwner && memberStatus /= GSMemUnknown ->
@@ -1451,7 +1451,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
     getOwnersInfo :: [(GroupInfo, GroupReg)] -> IO [((GroupInfo, GroupReg), Maybe (Either String Contact))]
     getOwnersInfo gs =
       fmap (either (\e -> map (,Just (Left e)) gs) id) $ withDB' "getOwnersInfo" cc $ \db ->
-        mapM (\g@(_, gr) -> fmap ((g,) . Just . first show) $ runExceptT $ getContact db (vr cc) user $ dbContactId gr) gs
+        mapM (\g@(_, gr) -> fmap ((g,) . Just . first show) $ runExceptT $ getContact db (storeCxt cc) user $ dbContactId gr) gs
 
     sendGroupsInfo :: Contact -> ChatItemId -> Bool -> ([(GroupInfo, GroupReg)], Int) -> IO ()
     sendGroupsInfo ct ciId isAdmin (gs, n) = do
@@ -1519,7 +1519,7 @@ updateGroupListingFiles cc u dir =
     Left e -> logError $ "generateListing error: failed to read groups: " <> T.pack e
 
 getContact' :: ChatController -> User -> ContactId -> IO (Either String Contact)
-getContact' cc user ctId = withDB "getContact" cc $ \db ->  withExceptT show $ getContact db (vr cc) user ctId
+getContact' cc user ctId = withDB "getContact" cc $ \db ->  withExceptT show $ getContact db (storeCxt cc) user ctId
 
 getGroupLink' :: ChatController -> User -> GroupInfo -> IO (Either String GroupLink)
 getGroupLink' cc user gInfo =

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

@@ -85,7 +85,6 @@ import Data.Time.Clock.System (systemEpochDay)
 import Directory.Search
 import Directory.Util
 import Simplex.Chat.Controller
-import Simplex.Chat.Protocol (supportedChatVRange)
 import Simplex.Chat.Options.DB (FromField (..), ToField (..))
 import Simplex.Chat.Store
 import Simplex.Chat.Store.Groups
@@ -315,28 +314,28 @@ getGroupReg_ db gId =
 getGroupAndReg :: ChatController -> User -> GroupId -> IO (Either String (GroupInfo, GroupReg))
 getGroupAndReg cc user@User {userId, userContactId} gId =
   withDB "getGroupAndReg" cc $ \db ->
-    ExceptT $ firstRow (toGroupInfoReg (vr cc) user) ("group " ++ show gId ++ " not found") $
+    ExceptT $ firstRow (toGroupInfoReg (storeCxt cc) user) ("group " ++ show gId ++ " not found") $
     DB.query db (groupReqQuery <> " AND g.group_id = ?") (userId, userContactId, gId)
 
 getUserGroupReg :: ChatController -> User -> ContactId -> UserGroupRegId -> IO (Either String (GroupInfo, GroupReg))
 getUserGroupReg cc user@User {userId, userContactId} ctId ugrId =
   withDB "getUserGroupReg" cc $ \db ->
-    ExceptT $ firstRow (toGroupInfoReg (vr cc) user) ("group " ++ show ugrId ++ " not found") $
+    ExceptT $ firstRow (toGroupInfoReg (storeCxt cc) user) ("group " ++ show ugrId ++ " not found") $
       DB.query db (groupReqQuery <> " AND r.contact_id = ? AND r.user_group_reg_id = ?") (userId, userContactId, ctId, ugrId)
 
 getUserGroupRegs :: ChatController -> User -> ContactId -> IO (Either String [(GroupInfo, GroupReg)])
 getUserGroupRegs cc user@User {userId, userContactId} ctId =
   withDB' "getUserGroupRegs" cc $ \db ->
-    map (toGroupInfoReg (vr cc) user)
+    map (toGroupInfoReg (storeCxt cc) user)
       <$> DB.query db (groupReqQuery <> " AND r.contact_id = ? ORDER BY r.user_group_reg_id") (userId, userContactId, ctId)
 
 getAllListedGroups :: ChatController -> User -> IO (Either String [(GroupInfo, GroupReg, Maybe GroupLink)])
-getAllListedGroups cc user = withDB' "getAllListedGroups" cc $ \db -> getAllListedGroups_ db (vr cc) user
+getAllListedGroups cc user = withDB' "getAllListedGroups" cc $ \db -> getAllListedGroups_ db (storeCxt cc) user
 
-getAllListedGroups_ :: DB.Connection -> VersionRangeChat -> User -> IO [(GroupInfo, GroupReg, Maybe GroupLink)]
-getAllListedGroups_ db vr' user@User {userId, userContactId} =
+getAllListedGroups_ :: DB.Connection -> StoreCxt -> User -> IO [(GroupInfo, GroupReg, Maybe GroupLink)]
+getAllListedGroups_ db cxt user@User {userId, userContactId} =
   DB.query db (groupReqQuery <> " AND r.group_reg_status = ?") (userId, userContactId, GRSActive)
-    >>= mapM (withGroupLink . toGroupInfoReg vr' user)
+    >>= mapM (withGroupLink . toGroupInfoReg cxt user)
   where
     withGroupLink (g, gr) = (g,gr,) . eitherToMaybe <$> runExceptT (getGroupLink db user g)
 
@@ -382,7 +381,7 @@ searchListedGroups cc user@User {userId, userContactId} searchType lastGroup_ pa
           countQuery' = countQuery <> " JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id WHERE r.group_reg_status = ? "
           orderBy = " ORDER BY g.summary_current_members_count DESC, r.group_reg_id ASC "
   where
-    groups = (map (toGroupInfoReg (vr cc) user) <$>)
+    groups = (map (toGroupInfoReg (storeCxt cc) user) <$>)
     count = maybeFirstRow' 0 fromOnly
     listedGroupQuery = groupReqQuery <> " AND r.group_reg_status = ? "
     countQuery = "SELECT COUNT(1) FROM groups g JOIN sx_directory_group_regs r ON g.group_id = r.group_id "
@@ -395,22 +394,22 @@ searchListedGroups cc user@User {userId, userContactId} searchType lastGroup_ pa
         )
       |]
 
-getAllGroupRegs_ :: DB.Connection -> User -> IO [(GroupInfo, GroupReg)]
-getAllGroupRegs_ db user@User {userId, userContactId} =
-  map (toGroupInfoReg supportedChatVRange user)
+getAllGroupRegs_ :: DB.Connection -> StoreCxt -> User -> IO [(GroupInfo, GroupReg)]
+getAllGroupRegs_ db cxt user@User {userId, userContactId} =
+  map (toGroupInfoReg cxt user)
     <$> DB.query db groupReqQuery (userId, userContactId)
 
 getDuplicateGroupRegs :: ChatController -> User -> Text -> IO (Either String [(GroupInfo, GroupReg)])
 getDuplicateGroupRegs cc user@User {userId, userContactId} displayName =
   withDB' "getDuplicateGroupRegs" cc $ \db ->
-    map (toGroupInfoReg (vr cc) user)
+    map (toGroupInfoReg (storeCxt cc) user)
       <$> DB.query db (groupReqQuery <> " AND gp.display_name = ?") (userId, userContactId, displayName)
 
 listLastGroups :: ChatController -> User -> Int -> IO (Either String ([(GroupInfo, GroupReg)], Int))
 listLastGroups cc user@User {userId, userContactId} count =
   withDB' "getUserGroupRegs" cc $ \db -> do
     gs <-
-      map (toGroupInfoReg (vr cc) user)
+      map (toGroupInfoReg (storeCxt cc) user)
         <$> DB.query db (groupReqQuery <> " ORDER BY group_reg_id DESC LIMIT ?") (userId, userContactId, count)
     n <- maybeFirstRow' 0 fromOnly $ DB.query_ db "SELECT COUNT(1) FROM sx_directory_group_regs"
     pure (gs, n)
@@ -419,14 +418,14 @@ listPendingGroups :: ChatController -> User -> Int -> IO (Either String ([(Group
 listPendingGroups cc user@User {userId, userContactId} count =
   withDB' "getUserGroupRegs" cc $ \db -> do
     gs <-
-      map (toGroupInfoReg (vr cc) user)
+      map (toGroupInfoReg (storeCxt cc) user)
         <$> DB.query db (groupReqQuery <> " AND r.group_reg_status LIKE 'pending_approval%' ORDER BY group_reg_id DESC LIMIT ?") (userId, userContactId, count)
     n <- maybeFirstRow' 0 fromOnly $ DB.query_ db "SELECT COUNT(1) FROM sx_directory_group_regs WHERE group_reg_status LIKE 'pending_approval%'"
     pure (gs, n)
 
-toGroupInfoReg :: VersionRangeChat -> User -> (GroupInfoRow :. GroupRegRow) -> (GroupInfo, GroupReg)
-toGroupInfoReg vr' User {userContactId} (groupRow :. grRow) =
-  (toGroupInfo vr' userContactId [] groupRow, rowToGroupReg grRow)
+toGroupInfoReg :: StoreCxt -> User -> (GroupInfoRow :. GroupRegRow) -> (GroupInfo, GroupReg)
+toGroupInfoReg cxt User {userContactId} (groupRow :. grRow) =
+  (toGroupInfo cxt userContactId [] groupRow, rowToGroupReg grRow)
 
 type GroupRegRow = (GroupId, UserGroupRegId, ContactId, Maybe GroupMemberId, GroupRegStatus, BoolInt, UTCTime)
 

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

@@ -18,10 +18,9 @@ import Directory.Listing
 import Directory.Options
 import Directory.Store
 import Simplex.Chat (createChatDatabase)
-import Simplex.Chat.Controller (ChatConfig (..), ChatDatabase (..))
+import Simplex.Chat.Controller (ChatConfig (..), ChatDatabase (..), mkStoreCxt)
 import Simplex.Chat.Options (CoreChatOpts (..))
 import Simplex.Chat.Options.DB
-import Simplex.Chat.Protocol (supportedChatVRange)
 import Simplex.Chat.Store.Groups (getHostMember)
 import Simplex.Chat.Store.Profiles (getUsers)
 import Simplex.Chat.Store.Shared (getGroupInfo)
@@ -62,7 +61,7 @@ checkDirectoryLog opts cfg =
     runDirectoryMigrations opts cfg st
     gs <- readDirectoryLogData logFile
     withActiveUser st $ \user -> withTransaction st $ \db -> do
-      mapM_ (verifyGroupRegistration db user) gs
+      mapM_ (verifyGroupRegistration (mkStoreCxt cfg) db user) gs
     putStrLn $ show (length gs) <> " group registrations OK"
 
 importDirectoryLogToDB :: DirectoryOpts -> ChatConfig -> IO ()
@@ -73,7 +72,7 @@ importDirectoryLogToDB opts cfg = do
     ctRegs <- TM.emptyIO
     withActiveUser st $ \user -> withTransaction st $ \db -> do
       forM_ gs $ \gr ->
-        whenM (verifyGroupRegistration db user gr) $ do
+        whenM (verifyGroupRegistration (mkStoreCxt cfg) db user gr) $ do
           putStrLn $ "importing group " <> show (dbGroupId gr)
           insertGroupReg db =<< fixUserGroupRegId ctRegs gr
       renamePath logFile (logFile ++ ".bak")
@@ -101,28 +100,28 @@ exportDBToDirectoryLog opts cfg =
     runDirectoryMigrations opts cfg st
     withActiveUser st $ \user -> do
       gs <- withFile logFile WriteMode $ \h -> withTransaction st $ \db -> do
-        gs <- getAllGroupRegs_ db user
+        gs <- getAllGroupRegs_ db (mkStoreCxt cfg) user
         forM_ gs $ \(_, gr) ->
-          whenM (verifyGroupRegistration db user gr) $
+          whenM (verifyGroupRegistration (mkStoreCxt cfg) db user gr) $
             B.hPutStrLn h $ strEncode $ GRCreate gr
         pure gs
       putStrLn $ show (length gs) <> " group registrations exported"
 
 saveGroupListingFiles :: DirectoryOpts -> ChatConfig -> IO ()
-saveGroupListingFiles opts _cfg = case webFolder opts of
+saveGroupListingFiles opts cfg = case webFolder opts of
   Nothing -> exit "use --web-folder to generate listings"
   Just dir ->
     withChatStore opts $ \st -> withActiveUser st $ \user ->
       withTransaction st $ \db ->
-        getAllListedGroups_ db supportedChatVRange user >>= generateListing dir
+        getAllListedGroups_ db (mkStoreCxt cfg) user >>= generateListing dir
 
-verifyGroupRegistration :: DB.Connection -> User -> GroupReg -> IO Bool
-verifyGroupRegistration db user GroupReg {dbGroupId = gId, dbContactId = ctId, dbOwnerMemberId, groupRegStatus} =
-  runExceptT (getGroupInfo db supportedChatVRange user gId) >>= \case
+verifyGroupRegistration :: StoreCxt -> DB.Connection -> User -> GroupReg -> IO Bool
+verifyGroupRegistration cxt db user GroupReg {dbGroupId = gId, dbContactId = ctId, dbOwnerMemberId, groupRegStatus} =
+  runExceptT (getGroupInfo db cxt user gId) >>= \case
     Left e -> False <$ putStrLn ("Error: loading group " <> show gId <> " (skipping): " <> show e)
     Right GroupInfo {localDisplayName} -> do
       let groupRef = show gId <> " " <> T.unpack localDisplayName
-      runExceptT (getHostMember db supportedChatVRange user gId) >>= \case
+      runExceptT (getHostMember db cxt user gId) >>= \case
         Left e -> False <$ putStrLn ("Error: loading host member of group " <> groupRef <> " (skipping): " <> show e)
         Right GroupMember {groupMemberId = mId', memberContactId = ctId'} -> case dbOwnerMemberId of
           Nothing -> True <$ putStrLn ("Warning: group " <> groupRef <> " has no owner member ID, host member ID is " <> show mId' <> ", registration status: " <> B.unpack (strEncode groupRegStatus))

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

@@ -15,9 +15,9 @@ import Simplex.Messaging.Agent.Store.Common (withTransaction)
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Util (catchAll)
 
-vr :: ChatController -> VersionRangeChat
-vr ChatController {config = ChatConfig {chatVRange}} = chatVRange
-{-# INLINE vr #-}
+storeCxt :: ChatController -> StoreCxt
+storeCxt ChatController {config} = mkStoreCxt config
+{-# INLINE storeCxt #-}
 
 withDB' :: Text -> ChatController -> (DB.Connection -> IO a) -> IO (Either String a)
 withDB' cxt cc a = withDB cxt cc $ ExceptT . fmap Right . a