move hook

apps/simplex-directory-service/Main.hs

@@ -5,7 +5,9 @@ module Main where
 import Directory.Options
 import Directory.Service
 import Directory.Store
+import Simplex.Chat.Controller (ChatConfig (..), ChatHooks (..), defaultChatHooks)
 import Simplex.Chat.Core
+import Simplex.Chat.Terminal (terminalChatConfig)
 
 main :: IO ()
 main = do
@@ -14,5 +16,5 @@ main = do
   if runCLI
     then directoryServiceCLI st opts
     else do
-      cfg <- directoryChatConfig opts
+      let cfg = terminalChatConfig {chatHooks = defaultChatHooks {acceptMember = Just acceptMemberHook}}
       simplexChatCore cfg (mkChatOpts opts) $ directoryService st opts

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

@@ -11,16 +11,16 @@ import qualified Data.Text.Normalize as TN
 
 containsBlockedWords :: Map Char [Char] -> [String] -> Text -> Bool
 containsBlockedWords spelling blockedWords s =
-    let normalizedWords = concatMap words $ normalizeText spelling s
-        -- Fully normalize the entire string (no spaces or punctuation)
-        fullNorm = normalizeText spelling $ T.filter (not . isSpace) s
-        -- Check if any individual word is a swear word
-        wordCheck = any (`elem` blockedWords) normalizedWords
-        -- Check if the full string, when normalized, matches a swear word exactly
-        fullCheck = any (\bw -> T.length s <= length bw * 2 && any (bw ==) fullNorm) blockedWords
-        -- Check if the string is a single word (no spaces)
-        isSingleWord = not $ T.any isSpace s
-     in wordCheck || (fullCheck && not isSingleWord)
+  let normalizedWords = concatMap words $ normalizeText spelling s
+      -- Fully normalize the entire string (no spaces or punctuation)
+      fullNorm = normalizeText spelling $ T.filter (not . isSpace) s
+      -- Check if any individual word is a swear word
+      wordCheck = any (`elem` blockedWords) normalizedWords
+      -- Check if the full string, when normalized, matches a swear word exactly
+      fullCheck = any (\bw -> T.length s <= length bw * 2 && any (bw ==) fullNorm) blockedWords
+      -- Check if the string is a single word (no spaces)
+      isSingleWord = not $ T.any isSpace s
+   in wordCheck || (fullCheck && not isSingleWord)
 
 normalizeText :: Map Char [Char] -> Text -> [String]
 normalizeText spelling =

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

@@ -46,6 +46,7 @@ data DirectoryEvent
   | DEGroupInvitation {contact :: Contact, groupInfo :: GroupInfo, fromMemberRole :: GroupMemberRole, memberRole :: GroupMemberRole}
   | DEServiceJoinedGroup {contactId :: ContactId, groupInfo :: GroupInfo, hostMember :: GroupMember}
   | DEGroupUpdated {contactId :: ContactId, fromGroup :: GroupInfo, toGroup :: GroupInfo}
+  | DEMemberPendingApproval GroupInfo GroupMember
   | DEContactRoleChanged GroupInfo ContactId GroupMemberRole -- contactId here is the contact whose role changed
   | DEServiceRoleChanged GroupInfo GroupMemberRole
   | DEContactRemovedFromGroup ContactId GroupInfo
@@ -65,6 +66,9 @@ crDirectoryEvent = \case
   CRReceivedGroupInvitation {contact, groupInfo, fromMemberRole, memberRole} -> Just $ DEGroupInvitation {contact, groupInfo, fromMemberRole, memberRole}
   CRUserJoinedGroup {groupInfo, hostMember} -> (\contactId -> DEServiceJoinedGroup {contactId, groupInfo, hostMember}) <$> memberContactId hostMember
   CRGroupUpdated {fromGroup, toGroup, member_} -> (\contactId -> DEGroupUpdated {contactId, fromGroup, toGroup}) <$> (memberContactId =<< member_)
+  CRJoinedGroupMember {groupInfo, member}
+    | memberStatus member == GSMemPendingApproval -> Just $ DEMemberPendingApproval groupInfo member
+    | otherwise -> Nothing
   CRMemberRole {groupInfo, member, toRole}
     | groupMemberId' member == groupMemberId' (membership groupInfo) -> Just $ DEServiceRoleChanged groupInfo toRole
     | otherwise -> (\ctId -> DEContactRoleChanged groupInfo ctId toRole) <$> memberContactId member

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

@@ -29,6 +29,7 @@ data DirectoryOpts = DirectoryOpts
     nameSpellingFile :: Maybe FilePath,
     profileNameLimit :: Int,
     acceptAsObserver :: Maybe AcceptAsObserver,
+    captchaGenerator :: Maybe FilePath,
     directoryLog :: Maybe FilePath,
     serviceName :: T.Text,
     runCLI :: Bool,
@@ -99,6 +100,13 @@ directoryOpts appDir defaultDbName = do
             <> metavar "ACCEPT_AS_OBSERVER"
             <> help "Whether to accept all or some of the joining members without posting rights ('all', 'no-image', 'incognito')"
         )
+  captchaGenerator <-
+    optional $
+      strOption
+        ( long "captcha-generator"
+            <> metavar "CAPTCHA_GENERATOR"
+            <> help "Executable to generate captcha files, must accept text as parameter and save file to stdout as base64 up to 12500 bytes"
+        )
   directoryLog <-
     Just
       <$> strOption
@@ -129,6 +137,7 @@ directoryOpts appDir defaultDbName = do
         nameSpellingFile,
         profileNameLimit,
         acceptAsObserver,
+        captchaGenerator,
         directoryLog,
         serviceName = T.pack serviceName,
         runCLI,

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

@@ -11,7 +11,7 @@ module Directory.Service
   ( welcomeGetOpts,
     directoryService,
     directoryServiceCLI,
-    directoryChatConfig
+    acceptMemberHook
   )
 where
 
@@ -43,6 +43,7 @@ import Simplex.Chat.Core
 import Simplex.Chat.Messages
 import Simplex.Chat.Options
 import Simplex.Chat.Protocol (MsgContent (..))
+import Simplex.Chat.Store.Profiles (GroupLinkInfo (..))
 import Simplex.Chat.Store.Shared (StoreError (..))
 import Simplex.Chat.Terminal (terminalChatConfig)
 import Simplex.Chat.Terminal.Main (simplexChatCLI')
@@ -70,13 +71,15 @@ data GroupRolesStatus
   deriving (Eq)
 
 data ServiceState = ServiceState
-  { searchRequests :: TMap ContactId SearchRequest
+  { searchRequests :: TMap ContactId SearchRequest,
+    blockedWords :: TVar [String]
   }
 
 newServiceState :: IO ServiceState
 newServiceState = do
   searchRequests <- TM.emptyIO
-  pure ServiceState {searchRequests}
+  blockedWords <- newTVarIO []
+  pure ServiceState {searchRequests, blockedWords}
 
 welcomeGetOpts :: IO DirectoryOpts
 welcomeGetOpts = do
@@ -103,9 +106,9 @@ directoryServiceCLI st opts = do
   env <- newServiceState
   eventQ <- newTQueueIO
   let eventHook cc resp = atomically $ resp <$ writeTQueue eventQ (cc, resp)
-  cfg <- directoryChatConfig opts
+      chatHooks = defaultChatHooks {eventHook = Just eventHook, acceptMember = Just acceptMemberHook}
   race_
-    (simplexChatCLI' cfg {chatHooks = defaultChatHooks {eventHook}} (mkChatOpts opts) Nothing)
+    (simplexChatCLI' terminalChatConfig {chatHooks} (mkChatOpts opts) Nothing)
     (processEvents eventQ env)
   where
     processEvents eventQ env = forever $ do
@@ -121,23 +124,27 @@ directoryService st opts@DirectoryOpts {testing} user cc = do
     (_, _, resp) <- atomically . readTBQueue $ outputQ cc
     directoryServiceEvent st opts env user cc resp
 
-directoryChatConfig :: DirectoryOpts -> IO ChatConfig
-directoryChatConfig DirectoryOpts {blockedWordsFile, nameSpellingFile, blockedExtensionRules, profileNameLimit, acceptAsObserver} = do
-  blockedWords <- mapM (fmap lines . readFile) blockedWordsFile
-  spelling <- maybe (pure M.empty) (fmap (M.fromList . read) . readFile) nameSpellingFile
-  extensionRules <- maybe (pure []) (fmap read . readFile) blockedExtensionRules
-  let !bws = nubOrd . concatMap (wordVariants extensionRules) <$> blockedWords
-      !allowedProfileName = not .: containsBlockedWords spelling <$> bws
-  putStrLn $ "Blocked words: " <> show (maybe 0 length bws) <> ", spelling rules: " <> show (M.size spelling)
-  pure terminalChatConfig {allowedProfileName, profileNameLimit, acceptAsObserver}
+acceptMemberHook :: GroupInfo -> GroupLinkInfo -> Profile -> IO (Either GroupRejectionReason GroupMemberRole)
+acceptMemberHook _ GroupLinkInfo {memberRole} _ = pure $ Right memberRole
+
+-- directoryChatConfig :: DirectoryOpts -> IO ChatConfig
+-- directoryChatConfig DirectoryOpts {blockedWordsFile, nameSpellingFile, blockedExtensionRules, profileNameLimit, acceptAsObserver} = do
+  -- blockedWords <- mapM (fmap lines . readFile) blockedWordsFile
+  -- spelling <- maybe (pure M.empty) (fmap (M.fromList . read) . readFile) nameSpellingFile
+  -- extensionRules <- maybe (pure []) (fmap read . readFile) blockedExtensionRules
+  -- let !bws = nubOrd . concatMap (wordVariants extensionRules) <$> blockedWords
+  --     allowedProfileName name = not .: containsBlockedWords spelling <$> bws
+  -- putStrLn $ "Blocked words: " <> show (maybe 0 length bws) <> ", spelling rules: " <> show (M.size spelling)
+  -- pure terminalChatConfig {allowedProfileName, profileNameLimit, acceptAsObserver}
 
 directoryServiceEvent :: DirectoryStore -> DirectoryOpts -> ServiceState -> User -> ChatController -> ChatResponse -> IO ()
-directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults} ServiceState {searchRequests} user@User {userId} cc event =
+directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults} ServiceState {searchRequests, blockedWords} user@User {userId} cc event =
   forM_ (crDirectoryEvent event) $ \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
     DEGroupUpdated {contactId, fromGroup, toGroup} -> deGroupUpdated contactId fromGroup toGroup
+    DEMemberPendingApproval g m -> deMemberPendingApproval g m
     DEContactRoleChanged g ctId role -> deContactRoleChanged g ctId role
     DEServiceRoleChanged g role -> deServiceRoleChanged g role
     DEContactRemovedFromGroup ctId g -> deContactRemovedFromGroup ctId g
@@ -163,7 +170,7 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own
     notifyOwner GroupReg {dbContactId} = sendMessage' cc dbContactId
     ctId `isOwner` GroupReg {dbContactId} = ctId == dbContactId
     withGroupReg GroupInfo {groupId, localDisplayName} err action = do
-      atomically (getGroupReg st groupId) >>= \case
+      getGroupReg st groupId >>= \case
         Just gr -> action gr
         Nothing -> logError $ "Error: " <> err <> ", group: " <> localDisplayName <> ", can't find group registration ID " <> tshow groupId
     groupInfoText GroupProfile {displayName = n, fullName = fn, description = d} =
@@ -373,6 +380,9 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own
             Just (Just msg) -> notifyOwner gr msg
             Just Nothing -> sendToApprove toGroup gr gaId
 
+    deMemberPendingApproval :: GroupInfo -> GroupMember -> IO ()
+    deMemberPendingApproval _g _m = pure ()
+
     sendToApprove :: GroupInfo -> GroupReg -> GroupApprovalId -> IO ()
     sendToApprove GroupInfo {groupProfile = p@GroupProfile {displayName, image = image'}} GroupReg {dbGroupId, dbContactId} gaId = do
       ct_ <- getContact cc dbContactId
@@ -518,8 +528,13 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own
                 _ -> processInvitation ct g
             _ -> sendReply $ "Error: the group ID " <> tshow ugrId <> " (" <> displayName <> ") is not pending confirmation."
       DCListUserGroups ->
-        atomically (getUserGroupRegs st $ contactId' ct) >>= \grs -> do
+        getUserGroupRegs st (contactId' ct) >>= \grs -> do
           sendReply $ tshow (length grs) <> " registered group(s)"
+          -- debug how it can be that user has 0 registered groups
+          when (length grs == 0) $ do
+            total <- length <$> readTVarIO (groupRegs st)
+            withSuperUsers $ \ctId -> sendMessage' cc ctId $
+              "0 registered groups for " <> localDisplayName' ct <> " (" <> tshow (contactId' ct) <> ") out of " <> tshow total <> " registrations"
           void . forkIO $ forM_ (reverse grs) $ \gr@GroupReg {userGroupRegId} ->
             sendGroupInfo ct gr userGroupRegId Nothing
       DCDeleteGroup ugrId gName ->
@@ -541,7 +556,7 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own
         knownCt = knownContact ct
         isAdmin = knownCt `elem` adminUsers || knownCt `elem` superUsers
         withUserGroupReg ugrId gName action =
-          atomically (getUserGroupReg st (contactId' ct) ugrId) >>= \case
+          getUserGroupReg st (contactId' ct) ugrId >>= \case
             Nothing -> sendReply $ "Group ID " <> tshow ugrId <> " not found"
             Just gr@GroupReg {dbGroupId} -> do
               getGroup cc dbGroupId >>= \case
@@ -552,7 +567,7 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own
         sendReply = mkSendReply ct ciId
         withFoundListedGroups s_ action =
           getGroups_ s_ >>= \case
-            Just groups -> atomically (filterListedGroups st groups) >>= action
+            Just groups -> filterListedGroups st groups >>= action
             Nothing -> sendReply "Error: getGroups. Please notify the developers."
         sendSearchResults s = \case
           [] -> sendReply "No groups found"
@@ -765,7 +780,7 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own
         Nothing -> sendReply $ "Group ID " <> tshow gId <> " not found (getGroup)"
         Just g@GroupInfo {groupProfile = GroupProfile {displayName}}
           | displayName == gName ->
-              atomically (getGroupReg st gId) >>= \case
+              getGroupReg st gId >>= \case
                 Nothing -> sendReply $ "Registration for group ID " <> tshow gId <> " not found (getGroupReg)"
                 Just gr -> action g gr
           | otherwise ->

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

@@ -3,6 +3,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Directory.Store
   ( DirectoryStore (..),
@@ -10,6 +11,7 @@ module Directory.Store
     GroupRegStatus (..),
     UserGroupRegId,
     GroupApprovalId,
+    DirectoryGroupData,
     restoreDirectoryStore,
     addGroupReg,
     delGroupReg,
@@ -21,25 +23,31 @@ module Directory.Store
     filterListedGroups,
     groupRegStatusText,
     pendingApproval,
+    fromCustomData,
+    toCustomData,
   )
 where
 
 import Control.Concurrent.STM
 import Control.Monad
+import Data.Aeson ((.=), (.:), (.:?))
+import qualified Data.Aeson.KeyMap as JM
+import qualified Data.Aeson.TH as JQ
+import qualified Data.Aeson.Types as JT
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Composition ((.:))
 import Data.Int (Int64)
 import Data.List (find, foldl', sortOn)
 import Data.Map (Map)
 import qualified Data.Map.Strict as M
-import Data.Maybe (isJust)
+import Data.Maybe (fromMaybe, isJust)
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text (Text)
 import Simplex.Chat.Types
 import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON)
 import Simplex.Messaging.Util (ifM)
 import System.Directory (doesFileExist, renameFile)
 import System.IO (BufferMode (..), Handle, IOMode (..), hSetBuffering, openFile)
@@ -67,6 +75,13 @@ data GroupRegData = GroupRegData
     groupRegStatus_ :: GroupRegStatus
   }
 
+data DirectoryGroupData = DirectoryGroupData
+  { nameProfanityFilter :: Bool,
+    memberAcceptance :: Maybe DirectoryMemberAcceptance
+  }
+
+data DirectoryMemberAcceptance = DMAMemberWithImage | DMACaptcha
+
 type UserGroupRegId = Int64
 
 type GroupApprovalId = Int64
@@ -106,16 +121,32 @@ grDirectoryStatus = \case
   GRSSuspendedBadRoles -> DSReserved
   _ -> DSRegistered
 
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "MA") ''DirectoryMemberAcceptance)
+
+$(JQ.deriveJSON defaultJSON ''DirectoryGroupData)
+
+fromCustomData :: Maybe CustomData -> DirectoryGroupData
+fromCustomData = \case
+  Just (CustomData o) ->
+    let nameProfanityFilter = fromMaybe False $ JT.parseMaybe (.: "nameProfanityFilter") o
+        memberAcceptance = fromMaybe Nothing $ JT.parseMaybe (.:? "memberAcceptance") o
+     in DirectoryGroupData {nameProfanityFilter, memberAcceptance}
+  Nothing -> DirectoryGroupData False Nothing
+
+toCustomData :: DirectoryGroupData -> CustomData
+toCustomData DirectoryGroupData {nameProfanityFilter = on, memberAcceptance = ma} =
+  CustomData $ JM.fromList ["nameProfanityFilter" .= on, "memberAcceptance" .= ma]
+
 addGroupReg :: DirectoryStore -> Contact -> GroupInfo -> GroupRegStatus -> IO UserGroupRegId
 addGroupReg st ct GroupInfo {groupId} grStatus = do
-  grData <- atomically addGroupReg_
+  grData <- addGroupReg_
   logGCreate st grData
   pure $ userGroupRegId_ grData
   where
     addGroupReg_ = do
       let grData = GroupRegData {dbGroupId_ = groupId, userGroupRegId_ = 1, dbContactId_ = ctId, dbOwnerMemberId_ = Nothing, groupRegStatus_ = grStatus}
       gr <- dataToGroupReg grData
-      stateTVar (groupRegs st) $ \grs ->
+      atomically $ stateTVar (groupRegs st) $ \grs ->
         let ugrId = 1 + foldl' maxUgrId 0 grs
             grData' = grData {userGroupRegId_ = ugrId}
             gr' = gr {userGroupRegId = ugrId}
@@ -149,18 +180,18 @@ setGroupRegOwner st gr owner = do
   logGUpdateOwner st (dbGroupId gr) memberId
   atomically $ writeTVar (dbOwnerMemberId gr) (Just memberId)
 
-getGroupReg :: DirectoryStore -> GroupId -> STM (Maybe GroupReg)
-getGroupReg st gId = find ((gId ==) . dbGroupId) <$> readTVar (groupRegs st)
+getGroupReg :: DirectoryStore -> GroupId -> IO (Maybe GroupReg)
+getGroupReg st gId = find ((gId ==) . dbGroupId) <$> readTVarIO (groupRegs st)
 
-getUserGroupReg :: DirectoryStore -> ContactId -> UserGroupRegId -> STM (Maybe GroupReg)
-getUserGroupReg st ctId ugrId = find (\r -> ctId == dbContactId r && ugrId == userGroupRegId r) <$> readTVar (groupRegs st)
+getUserGroupReg :: DirectoryStore -> ContactId -> UserGroupRegId -> IO (Maybe GroupReg)
+getUserGroupReg st ctId ugrId = find (\r -> ctId == dbContactId r && ugrId == userGroupRegId r) <$> readTVarIO (groupRegs st)
 
-getUserGroupRegs :: DirectoryStore -> ContactId -> STM [GroupReg]
-getUserGroupRegs st ctId = filter ((ctId ==) . dbContactId) <$> readTVar (groupRegs st)
+getUserGroupRegs :: DirectoryStore -> ContactId -> IO [GroupReg]
+getUserGroupRegs st ctId = filter ((ctId ==) . dbContactId) <$> readTVarIO (groupRegs st)
 
-filterListedGroups :: DirectoryStore -> [(GroupInfo, GroupSummary)] -> STM [(GroupInfo, GroupSummary)]
+filterListedGroups :: DirectoryStore -> [(GroupInfo, GroupSummary)] -> IO [(GroupInfo, GroupSummary)]
 filterListedGroups st gs = do
-  lgs <- readTVar $ listedGroups st
+  lgs <- readTVarIO $ listedGroups st
   pure $ filter (\(GroupInfo {groupId}, _) -> groupId `S.member` lgs) gs
 
 listGroup :: DirectoryStore -> GroupId -> STM ()
@@ -200,10 +231,10 @@ logGDelete :: DirectoryStore -> GroupId -> IO ()
 logGDelete st = logDLR st . GRDelete
 
 logGUpdateStatus :: DirectoryStore -> GroupId -> GroupRegStatus -> IO ()
-logGUpdateStatus st = logDLR st .: GRUpdateStatus
+logGUpdateStatus st gId = logDLR st . GRUpdateStatus gId
 
 logGUpdateOwner :: DirectoryStore -> GroupId -> GroupMemberId -> IO ()
-logGUpdateOwner st = logDLR st .: GRUpdateOwner
+logGUpdateOwner st gId = logDLR st . GRUpdateOwner gId
 
 instance StrEncoding DLRTag where
   strEncode = \case
@@ -271,10 +302,10 @@ instance StrEncoding GroupRegStatus where
       "removed" -> pure GRSRemoved
       _ -> fail "invalid GroupRegStatus"
 
-dataToGroupReg :: GroupRegData -> STM GroupReg
+dataToGroupReg :: GroupRegData -> IO GroupReg
 dataToGroupReg GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_} = do
-  dbOwnerMemberId <- newTVar dbOwnerMemberId_
-  groupRegStatus <- newTVar groupRegStatus_
+  dbOwnerMemberId <- newTVarIO dbOwnerMemberId_
+  groupRegStatus <- newTVarIO groupRegStatus_
   pure
     GroupReg
       { dbGroupId = dbGroupId_,
@@ -286,10 +317,9 @@ dataToGroupReg GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerM
 
 restoreDirectoryStore :: Maybe FilePath -> IO DirectoryStore
 restoreDirectoryStore = \case
-  Just f -> ifM (doesFileExist f) (restore f) (newFile f >>= new . Just)
-  Nothing -> new Nothing
+  Just f -> ifM (doesFileExist f) (restore f) (newFile f >>= newDirectoryStore . Just)
+  Nothing -> newDirectoryStore Nothing
   where
-    new = atomically . newDirectoryStore
     newFile f = do
       h <- openFile f WriteMode
       hSetBuffering h LineBuffering
@@ -298,15 +328,15 @@ restoreDirectoryStore = \case
       grs <- readDirectoryData f
       renameFile f (f <> ".bak")
       h <- writeDirectoryData f grs -- compact
-      atomically $ mkDirectoryStore h grs
+      mkDirectoryStore h grs
 
 emptyStoreData :: ([GroupReg], Set GroupId, Set GroupId)
 emptyStoreData = ([], S.empty, S.empty)
 
-newDirectoryStore :: Maybe Handle -> STM DirectoryStore
+newDirectoryStore :: Maybe Handle -> IO DirectoryStore
 newDirectoryStore = (`mkDirectoryStore_` emptyStoreData)
 
-mkDirectoryStore :: Handle -> [GroupRegData] -> STM DirectoryStore
+mkDirectoryStore :: Handle -> [GroupRegData] -> IO DirectoryStore
 mkDirectoryStore h groups =
   foldM addGroupRegData emptyStoreData groups >>= mkDirectoryStore_ (Just h)
   where
@@ -318,11 +348,11 @@ mkDirectoryStore h groups =
         DSReserved -> (grs', listed, S.insert gId reserved)
         DSRegistered -> (grs', listed, reserved)
 
-mkDirectoryStore_ :: Maybe Handle -> ([GroupReg], Set GroupId, Set GroupId) -> STM DirectoryStore
+mkDirectoryStore_ :: Maybe Handle -> ([GroupReg], Set GroupId, Set GroupId) -> IO DirectoryStore
 mkDirectoryStore_ h (grs, listed, reserved) = do
-  groupRegs <- newTVar grs
-  listedGroups <- newTVar listed
-  reservedGroups <- newTVar reserved
+  groupRegs <- newTVarIO grs
+  listedGroups <- newTVarIO listed
+  reservedGroups <- newTVarIO reserved
   pure DirectoryStore {groupRegs, listedGroups, reservedGroups, directoryLogFile = h}
 
 readDirectoryData :: FilePath -> IO [GroupRegData]