From 4232f73ed233eefa8f35f0c67817c971bffb5130 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Thu, 10 Jun 2021 20:34:52 +0100 Subject: [PATCH] support ad-hoc groups (broadcasts) (#61) * support ad-hoc groups (broadcasts) * fake group chat * use simplexmq latest --- apps/dog-food/ChatTerminal.hs | 8 +- apps/dog-food/ChatTerminal/Core.hs | 29 +++++-- apps/dog-food/Main.hs | 125 ++++++++++++++++++++++------- apps/dog-food/Types.hs | 4 +- package.yaml | 2 +- stack.yaml | 10 +-- 6 files changed, 128 insertions(+), 50 deletions(-) diff --git a/apps/dog-food/ChatTerminal.hs b/apps/dog-food/ChatTerminal.hs index e2780abfa5..27683c77bc 100644 --- a/apps/dog-food/ChatTerminal.hs +++ b/apps/dog-food/ChatTerminal.hs @@ -30,14 +30,14 @@ newChatTerminal :: Natural -> TermMode -> IO ChatTerminal newChatTerminal qSize termMode = do inputQ <- newTBQueueIO qSize outputQ <- newTBQueueIO qSize - activeContact <- newTVarIO Nothing + activeTo <- newTVarIO ActiveNone termSize <- withTerminal . runTerminalT $ getWindowSize let lastRow = height termSize - 1 termState <- newTVarIO newTermState termLock <- newTMVarIO () nextMessageRow <- newTVarIO lastRow threadDelay 500000 -- this delay is the same as timeout in getTerminalSize - return ChatTerminal {inputQ, outputQ, activeContact, termMode, termState, termSize, nextMessageRow, termLock} + return ChatTerminal {inputQ, outputQ, activeTo, termMode, termState, termSize, nextMessageRow, termLock} newTermState :: TerminalState newTermState = @@ -72,7 +72,7 @@ withTermLock ChatTerminal {termLock} action = do atomically $ putTMVar termLock () receiveFromTTY :: ChatTerminal -> IO () -receiveFromTTY ct@ChatTerminal {inputQ, activeContact, termSize, termState} = +receiveFromTTY ct@ChatTerminal {inputQ, activeTo, termSize, termState} = withTerminal . runTerminalT . forever $ getKey >>= processKey >> withTermLock ct (updateInput ct) where @@ -80,7 +80,7 @@ receiveFromTTY ct@ChatTerminal {inputQ, activeContact, termSize, termState} = processKey = \case (EnterKey, _) -> submitInput key -> atomically $ do - ac <- readTVar activeContact + ac <- readTVar activeTo modifyTVar termState $ updateTermState ac (width termSize) key submitInput :: MonadTerminal m => m () diff --git a/apps/dog-food/ChatTerminal/Core.hs b/apps/dog-food/ChatTerminal/Core.hs index 653b5c3f84..d47e822059 100644 --- a/apps/dog-food/ChatTerminal/Core.hs +++ b/apps/dog-food/ChatTerminal/Core.hs @@ -16,10 +16,13 @@ import System.Console.ANSI.Types import System.Terminal hiding (insertChars) import Types +data ActiveTo = ActiveNone | ActiveC Contact | ActiveG Group + deriving (Eq) + data ChatTerminal = ChatTerminal { inputQ :: TBQueue String, outputQ :: TBQueue [StyledString], - activeContact :: TVar (Maybe Contact), + activeTo :: TVar ActiveTo, termMode :: TermMode, termState :: TVar TerminalState, termSize :: Size, @@ -43,7 +46,7 @@ positionRowColumn wid pos = col = pos - row * wid in Position {row, col} -updateTermState :: Maybe Contact -> Int -> (Key, Modifiers) -> TerminalState -> TerminalState +updateTermState :: ActiveTo -> Int -> (Key, Modifiers) -> TerminalState -> TerminalState updateTermState ac tw (key, ms) ts@TerminalState {inputString = s, inputPosition = p} = case key of CharKey c | ms == mempty || ms == shiftKey -> insertCharsWithContact [c] @@ -68,15 +71,16 @@ updateTermState ac tw (key, ms) ts@TerminalState {inputString = s, inputPosition _ -> ts where insertCharsWithContact cs - | null s && cs /= "@" && cs /= "/" = + | null s && cs /= "@" && cs /= "#" && cs /= "/" = insertChars $ contactPrefix <> cs | otherwise = insertChars cs insertChars = ts' . if p >= length s then append else insert append cs = let s' = s <> cs in (s', length s') insert cs = let (b, a) = splitAt p s in (b <> cs <> a, p + length cs) contactPrefix = case ac of - Just (Contact c) -> "@" <> B.unpack c <> " " - Nothing -> "" + ActiveNone -> "" + ActiveC (Contact c) -> "@" <> B.unpack c <> " " + ActiveG (Group g) -> "#" <> B.unpack g <> " " backDeleteChar | p == 0 || null s = ts | p >= length s = ts' (init s, length s - 1) @@ -116,11 +120,14 @@ styleMessage :: String -> String -> StyledString styleMessage time msg = do case msg of "" -> "" - s@('@' : _) -> do - let (c, rest) = span (/= ' ') s - styleTime time <> " " <> styled (Colored Cyan) c <> markdown rest + s@('@' : _) -> sentMessage s + s@('#' : _) -> sentMessage s s -> markdown s where + sentMessage :: String -> StyledString + sentMessage s = + let (c, rest) = span (/= ' ') s + in styleTime time <> " " <> styled (Colored Cyan) c <> markdown rest markdown :: String -> StyledString markdown = styleMarkdownText . T.pack @@ -137,3 +144,9 @@ ttyContact (Contact a) = styled (Colored Green) a ttyFromContact :: Contact -> StyledString ttyFromContact (Contact a) = styled (Colored Yellow) $ a <> "> " + +ttyGroup :: Group -> StyledString +ttyGroup (Group g) = styled (Colored Blue) $ "#" <> g + +ttyFromGroup :: Group -> Contact -> StyledString +ttyFromGroup (Group g) (Contact a) = styled (Colored Yellow) $ "#" <> g <> " " <> a <> "> " diff --git a/apps/dog-food/Main.hs b/apps/dog-food/Main.hs index 272fdba463..a3e097e04e 100644 --- a/apps/dog-food/Main.hs +++ b/apps/dog-food/Main.hs @@ -70,19 +70,31 @@ data ChatCommand | Connect Contact SMPQueueInfo | DeleteConnection Contact | SendMessage Contact ByteString + | NewGroup Group + | AddToGroup Group Contact + | RemoveFromGroup Group Contact + | DeleteGroup Group + | ListGroup Group + | SendGroupMessage Group ByteString + deriving (Show) chatCommandP :: Parser ChatCommand chatCommandP = ("/help" <|> "/h") $> ChatHelp - <|> ("/markdown" <|> "/m") $> MarkdownHelp + <|> ("/group #" <|> "/g #") *> (NewGroup <$> group) + <|> ("/add #" <|> "/a #") *> (AddToGroup <$> group <* A.space <*> contact) + <|> ("/remove #" <|> "/rm #") *> (RemoveFromGroup <$> group <* A.space <*> contact) + <|> ("/delete #" <|> "/d #") *> (DeleteGroup <$> group) + <|> ("/members #" <|> "/ms #") *> (ListGroup <$> group) + <|> A.char '#' *> (SendGroupMessage <$> group <* A.space <*> A.takeByteString) <|> ("/add " <|> "/a ") *> (AddConnection <$> contact) - <|> ("/connect " <> "/c ") *> connect - <|> ("/delete " <> "/d ") *> (DeleteConnection <$> contact) - <|> "@" *> sendMessage + <|> ("/connect " <|> "/c ") *> (Connect <$> contact <* A.space <*> smpQueueInfoP) + <|> ("/delete " <|> "/d ") *> (DeleteConnection <$> contact) + <|> A.char '@' *> (SendMessage <$> contact <* A.space <*> A.takeByteString) + <|> ("/markdown" <|> "/m") $> MarkdownHelp where - connect = Connect <$> contact <* A.space <*> smpQueueInfoP - sendMessage = SendMessage <$> contact <* A.space <*> A.takeByteString contact = Contact <$> A.takeTill (== ' ') + group = Group <$> A.takeTill (== ' ') data ChatResponse = ChatHelpInfo @@ -92,8 +104,12 @@ data ChatResponse | Confirmation Contact | ReceivedMessage Contact UTCTime ByteString MsgIntegrity | Disconnected Contact + | GroupMembers Group [Contact] + | ReceivedGroupMessage Group Contact UTCTime ByteString MsgIntegrity + | GroupConfirmation Group | YesYes | ContactError ConnectionErrorType Contact + | GroupError AgentErrorType Group | ErrorInput ByteString | ChatError AgentErrorType | NoChatResponse @@ -111,19 +127,30 @@ serializeChatResponse _ localTz currentTime = \case ] Connected c -> [ttyContact c <> " connected"] Confirmation c -> [ttyContact c <> " ok"] - ReceivedMessage c utcTime t mi -> - prependFirst (formatUTCTime utcTime <> " " <> ttyFromContact c) (msgPlain t) - ++ showIntegrity mi + ReceivedMessage c utcTime t mi -> receivedMessage utcTime t mi $ ttyFromContact c + ReceivedGroupMessage g c utcTime t mi -> receivedMessage utcTime t mi $ ttyFromGroup g c Disconnected c -> ["disconnected from " <> ttyContact c <> " - restart chat"] + GroupMembers g cs -> [ttyGroup g <> ": " <> plain (B.unpack . B.intercalate ", " $ map toBs cs)] + GroupConfirmation g -> [ttyGroup g <> " ok"] YesYes -> ["you got it!"] ContactError e c -> case e of - UNKNOWN -> ["no contact " <> ttyContact c] + NOT_FOUND -> ["no contact " <> ttyContact c] DUPLICATE -> ["contact " <> ttyContact c <> " already exists"] SIMPLEX -> ["contact " <> ttyContact c <> " did not accept invitation yet"] + GroupError e g -> case e of + BCAST B_NOT_FOUND -> ["no group " <> ttyGroup g] + BCAST B_DUPLICATE -> ["group " <> ttyGroup g <> " already exists"] + CONN NOT_FOUND -> ["cannot add unknown contact to the group " <> ttyGroup g] + CONN DUPLICATE -> ["this contact is already in the group " <> ttyGroup g] + CONN SIMPLEX -> ["this contact did not not accept invitation yet"] + _ -> ["chat error: " <> plain (show e)] ErrorInput t -> ["invalid input: " <> bPlain t] ChatError e -> ["chat error: " <> plain (show e)] NoChatResponse -> [""] where + receivedMessage :: UTCTime -> ByteString -> MsgIntegrity -> StyledString -> [StyledString] + receivedMessage utcTime t mi from = + prependFirst (formatUTCTime utcTime <> " " <> from) (msgPlain t) ++ showIntegrity mi prependFirst :: StyledString -> [StyledString] -> [StyledString] prependFirst s [] = [s] prependFirst s (s' : ss) = (s <> s') : ss @@ -257,16 +284,18 @@ sendToChatTerm ChatClient {outQ} ChatTerminal {outputQ} opts localTz = forever $ sendToAgent :: ChatClient -> ChatTerminal -> AgentClient -> IO () sendToAgent ChatClient {inQ} ct AgentClient {rcvQ} = do - atomically $ writeTBQueue rcvQ ("1", "", SUBALL) -- hack for subscribing to all + atomically $ writeTBQueue rcvQ $ ATransmission "1" (Conn "") SUBALL -- hack for subscribing to all forever . atomically $ do cmd <- readTBQueue inQ writeTBQueue rcvQ `mapM_` agentTransmission cmd - setActiveContact cmd + setActiveTo cmd where - setActiveContact :: ChatCommand -> STM () - setActiveContact = \case - SendMessage a _ -> setActive ct a - DeleteConnection a -> unsetActive ct a + setActiveTo :: ChatCommand -> STM () + setActiveTo = \case + SendMessage a _ -> setActive ct $ ActiveC a + SendGroupMessage g _ -> setActive ct $ ActiveG g + DeleteConnection a -> unsetActive ct $ ActiveC a + DeleteGroup g -> unsetActive ct $ ActiveG g _ -> pure () agentTransmission :: ChatCommand -> Maybe (ATransmission 'Client) agentTransmission = \case @@ -274,40 +303,74 @@ sendToAgent ChatClient {inQ} ct AgentClient {rcvQ} = do Connect a qInfo -> transmission a $ JOIN qInfo $ ReplyMode On DeleteConnection a -> transmission a DEL SendMessage a msg -> transmission a $ SEND msg + NewGroup g -> bTransmission g NEW + AddToGroup g a -> bTransmission g $ ADD (Conn $ toBs a) + RemoveFromGroup g a -> bTransmission g $ REM (Conn $ toBs a) + DeleteGroup g -> bTransmission g DEL + ListGroup g -> bTransmission g LS + SendGroupMessage g msg -> bTransmission g $ SEND $ serializeGroupMessage g msg ChatHelp -> Nothing MarkdownHelp -> Nothing - transmission :: Contact -> ACommand 'Client -> Maybe (ATransmission 'Client) - transmission (Contact a) cmd = Just ("1", a, cmd) + transmission :: EntityCommand 'Conn_ c => Contact -> ACommand 'Client c -> Maybe (ATransmission 'Client) + transmission (Contact a) cmd = Just $ ATransmission "1" (Conn a) cmd + bTransmission :: EntityCommand 'Broadcast_ c => Group -> ACommand 'Client c -> Maybe (ATransmission 'Client) + bTransmission (Group g) cmd = Just $ ATransmission "1" (Broadcast g) cmd receiveFromAgent :: ChatClient -> ChatTerminal -> AgentClient -> IO () receiveFromAgent t ct c = forever . atomically $ do resp <- chatResponse <$> readTBQueue (sndQ c) writeTBQueue (outQ t) resp - setActiveContact resp + setActiveTo resp where chatResponse :: ATransmission 'Agent -> ChatResponse - chatResponse (_, a, resp) = case resp of + chatResponse (ATransmission _ entity resp) = case entity of + Conn a -> connectionResponse a resp + Broadcast g -> broadcastResponse g resp + _ -> NoChatResponse + connectionResponse :: EntityCommand 'Conn_ c => ByteString -> ACommand 'Agent c -> ChatResponse + connectionResponse a = \case INV qInfo -> Invitation qInfo CON -> Connected contact END -> Disconnected contact - MSG {msgBody, msgIntegrity, brokerMeta} -> ReceivedMessage contact (snd brokerMeta) msgBody msgIntegrity + MSG {msgBody, msgIntegrity, brokerMeta} -> case parseAll groupMessageP msgBody of + Right (group, msg) -> ReceivedGroupMessage group contact (snd brokerMeta) msg msgIntegrity + _ -> ReceivedMessage contact (snd brokerMeta) msgBody msgIntegrity SENT _ -> NoChatResponse OK -> Confirmation contact ERR (CONN e) -> ContactError e contact ERR e -> ChatError e where contact = Contact a - setActiveContact :: ChatResponse -> STM () - setActiveContact = \case - Connected a -> setActive ct a - ReceivedMessage a _ _ _ -> setActive ct a - Disconnected a -> unsetActive ct a + broadcastResponse :: EntityCommand 'Broadcast_ c => ByteString -> ACommand 'Agent c -> ChatResponse + broadcastResponse g = \case + MS as -> GroupMembers group $ map (Contact . fromConn) as + SENT _ -> NoChatResponse + OK -> GroupConfirmation group + ERR e@(CONN _) -> GroupError e group + ERR e@(BCAST _) -> GroupError e group + ERR e -> ChatError e + where + group = Group g + setActiveTo :: ChatResponse -> STM () + setActiveTo = \case + Connected a -> setActive ct $ ActiveC a + ReceivedMessage a _ _ _ -> setActive ct $ ActiveC a + ReceivedGroupMessage g _ _ _ _ -> setActive ct $ ActiveG g + Disconnected a -> unsetActive ct $ ActiveC a _ -> pure () -setActive :: ChatTerminal -> Contact -> STM () -setActive ct = writeTVar (activeContact ct) . Just +groupMessageP :: Parser (Group, ByteString) +groupMessageP = + let group = Group <$> A.takeTill (== ' ') + in "####" *> ((,) <$> group <* A.space <*> A.takeByteString) -unsetActive :: ChatTerminal -> Contact -> STM () -unsetActive ct a = modifyTVar (activeContact ct) unset +serializeGroupMessage :: Group -> ByteString -> ByteString +serializeGroupMessage (Group g) msg = "####" <> g <> " " <> msg + +setActive :: ChatTerminal -> ActiveTo -> STM () +setActive ct = writeTVar (activeTo ct) + +unsetActive :: ChatTerminal -> ActiveTo -> STM () +unsetActive ct a = modifyTVar (activeTo ct) unset where - unset a' = if Just a == a' then Nothing else a' + unset a' = if a == a' then ActiveNone else a' diff --git a/apps/dog-food/Types.hs b/apps/dog-food/Types.hs index 016073cbd0..f31c97d9bd 100644 --- a/apps/dog-food/Types.hs +++ b/apps/dog-food/Types.hs @@ -4,7 +4,9 @@ module Types where import Data.ByteString.Char8 (ByteString) -newtype Contact = Contact {toBs :: ByteString} deriving (Eq) +newtype Contact = Contact {toBs :: ByteString} deriving (Eq, Show) + +newtype Group = Group {fromGroup :: ByteString} deriving (Eq, Show) data TermMode = TermModeBasic | TermModeEditor deriving (Eq) diff --git a/package.yaml b/package.yaml index 479e460e2a..cd8ba49cda 100644 --- a/package.yaml +++ b/package.yaml @@ -14,7 +14,7 @@ extra-source-files: dependencies: - ansi-terminal == 0.10.* - attoparsec == 0.13.* - - base == 4.13.* + - base >= 4.7 && < 5 - containers == 0.6.* - text == 1.2.* diff --git a/stack.yaml b/stack.yaml index 1ed7bd8cf5..0023ad2b1b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-16.17 +resolver: lts-17.12 # User packages to be built. # Various formats can be used as shown in the example below. @@ -40,10 +40,10 @@ extra-deps: - simple-logger-0.1.0@sha256:be8ede4bd251a9cac776533bae7fb643369ebd826eb948a9a18df1a8dd252ff8,1079 - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 - terminal-0.2.0.0@sha256:de6770ecaae3197c66ac1f0db5a80cf5a5b1d3b64a66a05b50f442de5ad39570,2977 - - simplexmq-0.3.1@sha256:f247aaff3c16c5d3974a4ab4d5882ab50ac78073110997c0bceb05a74d10a325,6688 -# - network-run-0.2.4@sha256:7dbb06def522dab413bce4a46af476820bffdff2071974736b06f52f4ab57c96,885 -# - git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a + # - simplexmq-0.3.1@sha256:f247aaff3c16c5d3974a4ab4d5882ab50ac78073110997c0bceb05a74d10a325,6688 + # - ../simplexmq + - github: simplex-chat/simplexmq + commit: dffa7a61006aa5c4050c954857aaf1357fe33242 # # extra-deps: []