From 11987749fc6e6d3e53ea737d46d5ab13a16faeb8 Mon Sep 17 00:00:00 2001 From: James Crayne Date: Sat, 28 Sep 2019 13:43:29 -0400 Subject: Factor out some new libraries word64-map: Data.Word64Map network-addr: Network.Address tox-crypto: Crypto.Tox lifted-concurrent: Control.Concurrent.Lifted.Instrument Control.Concurrent.Async.Lifted.Instrument psq-wrap: Data.Wrapper.PSQInt Data.Wrapper.PSQ minmax-psq: Data.MinMaxPSQ tasks: Control.Concurrent.Tasks kad: Network.Kademlia Network.Kademlia.Bootstrap Network.Kademlia.Routing Network.Kademlia.CommonAPI Network.Kademlia.Persistence Network.Kademlia.Search --- Presence/Chat.hs | 227 ------------------------------------------------------- 1 file changed, 227 deletions(-) delete mode 100644 Presence/Chat.hs (limited to 'Presence/Chat.hs') diff --git a/Presence/Chat.hs b/Presence/Chat.hs deleted file mode 100644 index 03bea44b..00000000 --- a/Presence/Chat.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -module Chat where - -import Debug.Trace -import Data.Semigroup -import Control.Concurrent.STM -import Control.Monad -import qualified Data.Map as Map - ;import Data.Map (Map) -import Data.Text (Text) -import Data.Word - -import Util (stripResource) - --- To join a chat room, add a 'ClientRoomLink' to 'roomDesiredLink' with --- 'desireStreamEvent' set to 'Nothing'. --- --- To leave a chat room, remove the 'ClientRoomLink' from the map. - -data Room k = Room - { roomDesiredTransaction :: TVar (Map k (TVar (Maybe ChatTransaction))) - , roomChan :: TChan ChatTransaction - , roomFutureSeqNo :: TVar Word64 - , roomMembers :: TVar (Map Text{-nick-} (PerMember k)) - , roomAffiliations :: TVar (Map Text{-jid-} Affiliation) - , roomReservations :: TVar (Map Text{-nick-} Text{-jid-}) - } - -newtype PerMember k = PerMember - { memberKey :: k - } - -newtype Affiliation = Affiliation - { reservedNick :: Text - } - -data ChatEvent = Join | Part | Action Text | Talk Text -- | NickChange Text - deriving (Eq,Ord,Show) - -data Membership = Outside | Inside - deriving (Eq,Ord,Read,Show) - -data MembershipEffect = MembershipEffect { fromMembership :: Membership - , toMembership :: Membership - } - | NoMembershipEffect - | InvalidMembershipEffect - deriving (Eq,Ord,Read,Show) - -instance Semigroup MembershipEffect - -instance Monoid MembershipEffect where - mempty = NoMembershipEffect - MembershipEffect a x `mappend` MembershipEffect y b - | x == y = MembershipEffect a b - | otherwise = InvalidMembershipEffect - NoMembershipEffect `mappend` b = b - a `mappend` NoMembershipEffect = a - _ `mappend` _ = InvalidMembershipEffect - -chatEffect :: ChatEvent -> MembershipEffect -chatEffect Join = MembershipEffect Outside Inside -chatEffect Part = MembershipEffect Inside Outside -chatEffect _ = MembershipEffect Inside Inside - -membershipEffect :: [ChatEvent] -> MembershipEffect -membershipEffect xs = foldMap chatEffect xs - - -data ChatTransaction = ChatTransaction - { chatSeqNo :: Word64 - , chatSenderJID :: Maybe Text - , chatSender :: Text - , chatMessage :: [ChatEvent] - } - deriving (Eq,Ord,Show) - -newtype RoomHandle = RH (TVar (Maybe ChatTransaction)) - -data JoinedRoom k = JoinedRoom - { joinedRoom :: Room k - , joinedNick :: Text - , roomHandle :: RoomHandle - , roomTransactions :: TChan ChatTransaction - } - -newRoom :: STM (Room k) -newRoom = do - m <- newTVar Map.empty - c <- newTChan -- newBroadcastTChan - n <- newTVar 0 - cs <- newTVar Map.empty - as <- newTVar Map.empty - rs <- newTVar Map.empty - return Room - { roomDesiredTransaction = m - , roomChan = c - , roomFutureSeqNo = n - , roomMembers = cs - , roomAffiliations = as - , roomReservations = rs - } - - ---- Client interface - -joinRoom :: Ord k => k - -> Room k - -> Maybe Text - -> Text - -> STM (JoinedRoom k) -joinRoom k room jid nick = do - no <- readTVar $ roomFutureSeqNo room - v <- newTVar (Just $ ChatTransaction no jid nick [Join]) - modifyTVar' (roomDesiredTransaction room) $ Map.insert k v - c <- dupTChan (roomChan room) - return $ JoinedRoom room nick (RH v) c - -partRoom :: JoinedRoom k -> Maybe Text -> STM () -partRoom (JoinedRoom room nick (RH v) c) jid = do - writeTVar v Nothing -- Cancel pending chat. - sendChat (JoinedRoom room nick (RH v) c) jid [Part] - return () - -sendChat :: JoinedRoom k -> Maybe Text -> [ChatEvent] -> STM Bool -sendChat (JoinedRoom room nick (RH v) _) jid chat = do - mpending <- readTVar v - no <- readTVar $ roomFutureSeqNo room - case mpending of - Just (ChatTransaction no' _ _ _) | no' >= no -> return False - _ -> do - writeTVar v (Just $ ChatTransaction no jid nick chat) - return True - --- | Blocks until a transaction occurs. Optionally, a failed transaction will --- be automatically renewed. -readRoom :: Ord k => k -> JoinedRoom k -> STM (Bool, ChatTransaction) -readRoom k (JoinedRoom room _ (RH v) c) = do - mpending <- readTVar v - final <- readTChan c - case mpending of - Just pending -> do - if pending == final - then do - writeTVar v Nothing - when (Part `elem` chatMessage final) $ do - modifyTVar' (roomDesiredTransaction room) - $ Map.delete k - return (True,final) - else do - no <- readTVar $ roomFutureSeqNo room - writeTVar v $ Just pending { chatSeqNo = no } - return (False,final) - Nothing -> return (False,final) - -roomOccupants :: Room k-> STM [(Text{-nick-},Maybe Text{-friendly name-})] -roomOccupants room = do - ns <- Map.keys <$> readTVar (roomMembers room) - return $ map (\n -> (n,Just n)) ns - -roomReservedNick :: Room k -> Text{-JID-} -> STM (Maybe Text{-nick-}) -roomReservedNick room jid = do - a <- Map.lookup jid <$> readTVar (roomAffiliations room) - return $ reservedNick <$> a - -roomFriendlyName :: Room k -> STM (Maybe Text) -roomFriendlyName _ = return Nothing - --- Room implementation interface - -data Validation = Malformed | Requires Membership | Denied | Valid Membership Membership - deriving (Eq,Ord,Show,Read) - -validateTransaction :: Ord k => Room k -> k -> ChatTransaction -> STM Validation -validateTransaction room k t@(ChatTransaction no mjid nick xs) - | null xs = return Malformed - | otherwise = case membershipEffect xs of - MembershipEffect Inside what -> - Map.lookup nick <$> readTVar (roomMembers room) >>= \case - Nothing -> return (Requires Inside) - Just p | memberKey p /= k -> return Denied - _ -> return (Valid Inside what) - MembershipEffect Outside what -> do - Map.lookup k <$> return Map.empty {- readTVar (roomDesiredTransaction room) -} >>= \case - Nothing -> Map.lookup nick <$> readTVar (roomMembers room) >>= \case - Nothing -> Map.lookup nick <$> readTVar (roomReservations room) >>= \case - Just rjid | Just jid <- mjid - , stripResource jid == rjid - -> return (Valid Outside what) - Just _ -> return Denied - Nothing -> return (Valid Outside what) - Just _ -> return Denied -- Nick already taken. - Just _ -> return (Requires Outside) - _ -> return Malformed - - -roomCommit :: Ord k => Room k -> k -> ChatTransaction -> STM () -roomCommit room k t = do - let fin = do - trace "increment seqno!" $ return () - modifyTVar' (roomFutureSeqNo room) succ - writeTChan (roomChan room) t - v <- validateTransaction room k t - trace ("roomCommit " ++ show v ++ " " ++ show t) $ return () - case v of - Valid Outside Inside -> do - modifyTVar' (roomMembers room) $ Map.insert (chatSender t) PerMember - { memberKey = k - } - fin - Valid Inside Outside -> do - modifyTVar' (roomMembers room) $ Map.delete (chatSender t) - fin - Valid _ _ -> fin - bad -> trace ("validateTransaction: " ++ show bad) $ return () - -roomPending :: Ord k => Room k -> STM (Map k ChatTransaction) -roomPending room = do - no <- readTVar $ roomFutureSeqNo room - m <- Map.mapMaybe (>>= \t -> do guard (chatSeqNo t == no) - return t) - <$> do readTVar (roomDesiredTransaction room) - >>= mapM readTVar - fmap (Map.mapMaybe id) - $ sequence $ Map.mapWithKey (\k t -> validateTransaction room k t >>= \case - Valid _ _ -> return (Just t) - _ -> return Nothing) m -- cgit v1.2.3