summaryrefslogtreecommitdiff
path: root/main/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'main/Main.hs')
-rw-r--r--main/Main.hs87
1 files changed, 83 insertions, 4 deletions
diff --git a/main/Main.hs b/main/Main.hs
index 6591239..960e3be 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -24,6 +24,7 @@ import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.IO qualified as T
+import Data.Time.Format
import Data.Time.LocalTime
import Data.Typeable
@@ -238,6 +239,7 @@ interactiveLoop st opts = runInputT inputSettings $ do
PeerIdentityRef wref _ -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">"
PeerIdentityUnknown _ -> "<unknown>"
SelectedContact contact -> return $ T.unpack $ contactName contact
+ SelectedChatroom rstate -> return $ T.unpack $ fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate
SelectedConversation conv -> return $ T.unpack $ conversationName conv
return $ pname ++ "> "
Right prompt -> return prompt
@@ -290,6 +292,7 @@ interactiveLoop st opts = runInputT inputSettings $ do
peers <- liftIO $ newMVar []
contextOptions <- liftIO $ newMVar []
+ chatroomSetVar <- liftIO $ newEmptyMVar
void $ liftIO $ forkIO $ void $ forever $ do
peer <- getNextPeerChange server
@@ -328,6 +331,8 @@ interactiveLoop st opts = runInputT inputSettings $ do
return (ps', ps')
, ciContextOptions = liftIO $ readMVar contextOptions
, ciSetContextOptions = \ctxs -> liftIO $ modifyMVar_ contextOptions $ const $ return ctxs
+ , ciContextOptionsVar = contextOptions
+ , ciChatroomSetVar = chatroomSetVar
}
case res of
Right cstate'
@@ -346,6 +351,7 @@ interactiveLoop st opts = runInputT inputSettings $ do
, csIceSessions = []
#endif
, csIcePeer = Nothing
+ , csWatchChatrooms = Nothing
, csQuit = False
}
@@ -357,6 +363,8 @@ data CommandInput = CommandInput
, ciPeers :: CommandM [(Peer, String)]
, ciContextOptions :: CommandM [CommandContext]
, ciSetContextOptions :: [CommandContext] -> Command
+ , ciContextOptionsVar :: MVar [ CommandContext ]
+ , ciChatroomSetVar :: MVar (Set ChatroomState)
}
data CommandState = CommandState
@@ -366,12 +374,14 @@ data CommandState = CommandState
, csIceSessions :: [IceSession]
#endif
, csIcePeer :: Maybe Peer
+ , csWatchChatrooms :: Maybe WatchedHead
, csQuit :: Bool
}
data CommandContext = NoContext
| SelectedPeer Peer
| SelectedContact Contact
+ | SelectedChatroom ChatroomState
| SelectedConversation Conversation
newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT String IO)) a)
@@ -413,6 +423,10 @@ getSelectedConversation = gets csContext >>= \case
SelectedContact contact -> case contactIdentity contact of
Just cid -> directMessageConversation cid
Nothing -> throwError "contact without erebos identity"
+ SelectedChatroom rstate ->
+ chatroomConversation rstate >>= \case
+ Just conv -> return conv
+ Nothing -> throwError "invalid chatroom"
SelectedConversation conv -> reloadConversation conv
_ -> throwError "no contact, peer or conversation selected"
@@ -537,13 +551,67 @@ cmdAttachAccept = attachAccept =<< getSelectedPeer
cmdAttachReject :: Command
cmdAttachReject = attachReject =<< getSelectedPeer
+watchChatroomsForCli :: (String -> IO ()) -> Head LocalState -> MVar (Set ChatroomState) -> MVar [ CommandContext ] -> IO WatchedHead
+watchChatroomsForCli eprint h chatroomSetVar contextVar = do
+ let ctxUpdate updateType (idx :: Int) rstate = \case
+ SelectedChatroom rstate' : rest
+ | currentRoots <- filterAncestors (concatMap storedRoots $ roomStateData rstate)
+ , any ((`intersectsSorted` currentRoots) . storedRoots) $ roomStateData rstate'
+ -> do
+ eprint $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name
+ return (SelectedChatroom rstate : rest)
+ selected : rest
+ -> do
+ (selected : ) <$> ctxUpdate updateType (idx + 1) rstate rest
+ []
+ -> do
+ eprint $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name
+ return [ SelectedChatroom rstate ]
+ where
+ name = maybe "<unnamed>" T.unpack $ roomName =<< roomStateRoom rstate
+
+ watchChatrooms h $ \set -> \case
+ Nothing -> putMVar chatroomSetVar set
+ Just diff -> do
+ modifyMVar_ chatroomSetVar $ return . const set
+ forM_ diff $ \case
+ AddedChatroom rstate -> modifyMVar_ contextVar $ ctxUpdate "NEW" 1 rstate
+ RemovedChatroom rstate -> modifyMVar_ contextVar $ ctxUpdate "DEL" 1 rstate
+ UpdatedChatroom oldroom rstate -> do
+ when (any ((\rsd -> not (null (rsdRoom rsd))) . fromStored) (roomStateData rstate)) $ do
+ modifyMVar_ contextVar $ ctxUpdate "UPD" 1 rstate
+ when (any (not . null . rsdMessages . fromStored) (roomStateData rstate)) $ do
+ tzone <- getCurrentTimeZone
+ forM_ (reverse $ getMessagesSinceState rstate oldroom) $ \msg -> do
+ eprint $ concat $
+ [ maybe "<unnamed>" T.unpack $ roomName =<< cmsgRoom msg
+ , formatTime defaultTimeLocale " [%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ cmsgTime msg
+ , maybe "<unnamed>" T.unpack $ idName $ cmsgFrom msg
+ , ": "
+ , maybe "<no message>" T.unpack $ cmsgText msg
+ ]
+
+ensureWatchedChatrooms :: Command
+ensureWatchedChatrooms = do
+ gets csWatchChatrooms >>= \case
+ Nothing -> do
+ eprint <- asks ciPrint
+ h <- gets csHead
+ chatroomSetVar <- asks ciChatroomSetVar
+ contextVar <- asks ciContextOptionsVar
+ watched <- liftIO $ watchChatroomsForCli eprint h chatroomSetVar contextVar
+ modify $ \s -> s { csWatchChatrooms = Just watched }
+ Just _ -> return ()
+
cmdChatrooms :: Command
cmdChatrooms = do
- conversations <- return . catMaybes =<< mapM chatroomConversation =<< listChatrooms
+ ensureWatchedChatrooms
+ chatroomSetVar <- asks ciChatroomSetVar
+ chatroomList <- fromSetBy (comparing roomStateData) <$> liftIO (readMVar chatroomSetVar)
set <- asks ciSetContextOptions
- set $ map SelectedConversation conversations
- forM_ (zip [1..] conversations) $ \(i :: Int, conv) -> do
- liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv)
+ set $ map SelectedChatroom chatroomList
+ forM_ (zip [1..] chatroomList) $ \(i :: Int, rstate) -> do
+ liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ maybe "<unnamed>" T.unpack (roomName =<< roomStateRoom rstate)
cmdChatroomCreatePublic :: Command
cmdChatroomCreatePublic = do
@@ -554,6 +622,7 @@ cmdChatroomCreatePublic = do
hFlush stdout
T.getLine
+ ensureWatchedChatrooms
void $ createChatroom
(if T.null name then Nothing else Just name)
Nothing
@@ -615,6 +684,9 @@ cmdDetails = do
SelectedContact contact -> do
printContactDetails contact
+ SelectedChatroom rstate -> do
+ liftIO $ putStrLn $ "Chatroom: " <> (T.unpack $ fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate)
+
SelectedConversation conv -> do
case conversationPeer conv of
Just pid -> printContactOrIdentityDetails pid
@@ -732,3 +804,10 @@ cmdIceSend = void $ do
cmdQuit :: Command
cmdQuit = modify $ \s -> s { csQuit = True }
+
+
+intersectsSorted :: Ord a => [a] -> [a] -> Bool
+intersectsSorted (x:xs) (y:ys) | x < y = intersectsSorted xs (y:ys)
+ | x > y = intersectsSorted (x:xs) ys
+ | otherwise = True
+intersectsSorted _ _ = False