support ad-hoc groups (broadcasts)

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,15 +72,15 @@ 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
     processKey :: MonadTerminal m => (Key, Modifiers) -> m ()
     processKey = \case
       (EnterKey, _) -> submitInput
       key -> atomically $ do
-        ac <- readTVar activeContact
+        ac <- readTVar activeTo
         modifyTVar termState $ updateTermState ac (width termSize) key
 
     submitInput :: MonadTerminal m => m ()

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 <> "> "

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,57 +284,93 @@ 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
       AddConnection a -> transmission a NEW
       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)
+
+serializeGroupMessage :: Group -> ByteString -> ByteString
+serializeGroupMessage (Group g) msg = "####" <> g <> " " <> msg
+
+setActive :: ChatTerminal -> ActiveTo -> STM ()
+setActive ct = writeTVar (activeTo ct)
 
-unsetActive :: ChatTerminal -> Contact -> STM ()
-unsetActive ct a = modifyTVar (activeContact ct) unset
+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'

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)
 

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.*
 

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: []