summaryrefslogtreecommitdiff
path: root/main
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2024-05-19 21:37:46 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2024-05-23 21:10:12 +0200
commit620e5840aba91d683bf7b4ee115079550aae8569 (patch)
treed813fa3b2be9085d45612fe381b0892d4cb119cc /main
parent49db4661634b364ea49758666623a2efc3ac7107 (diff)
Conversation interface
Changelog: Added `/conversations` command to list and select conversations
Diffstat (limited to 'main')
-rw-r--r--main/Main.hs46
1 files changed, 28 insertions, 18 deletions
diff --git a/main/Main.hs b/main/Main.hs
index 0144564..22a7831 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -36,12 +36,13 @@ import System.IO
import Erebos.Attach
import Erebos.Contact
+import Erebos.Conversation
#ifdef ENABLE_ICE_SUPPORT
import Erebos.Discovery
import Erebos.ICE
#endif
import Erebos.Identity
-import Erebos.Message
+import Erebos.Message hiding (formatMessage)
import Erebos.Network
import Erebos.PubKey
import Erebos.Service
@@ -222,7 +223,7 @@ interactiveLoop st opts = runInputT inputSettings $ do
_ <- liftIO $ do
tzone <- getCurrentTimeZone
watchReceivedMessages erebosHead $
- extPrintLn . formatMessage tzone . fromStored
+ extPrintLn . formatDirectMessage tzone . fromStored
server <- liftIO $ do
startServer (optServer opts) erebosHead extPrintLn $
@@ -264,6 +265,7 @@ interactiveLoop st opts = runInputT inputSettings $ do
PeerIdentityRef wref _ -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">"
PeerIdentityUnknown _ -> "<unknown>"
SelectedContact contact -> return $ T.unpack $ contactName contact
+ SelectedConversation conv -> return $ T.unpack $ conversationName conv
input <- getInputLines $ pname ++ "> "
let (CommandM cmd, line) = case input of
'/':rest -> let (scmd, args) = dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') rest
@@ -321,6 +323,7 @@ data CommandState = CommandState
data CommandContext = NoContext
| SelectedPeer Peer
| SelectedContact Contact
+ | SelectedConversation Conversation
newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT String IO)) a)
deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError String)
@@ -353,15 +356,16 @@ getSelectedPeer = gets csContext >>= \case
SelectedPeer peer -> return peer
_ -> throwError "no peer selected"
-getSelectedIdentity :: CommandM ComposedIdentity
-getSelectedIdentity = gets csContext >>= \case
+getSelectedConversation :: CommandM Conversation
+getSelectedConversation = gets csContext >>= \case
SelectedPeer peer -> peerIdentity peer >>= \case
- PeerIdentityFull pid -> return $ toComposedIdentity pid
+ PeerIdentityFull pid -> directMessageConversation $ finalOwner pid
_ -> throwError "incomplete peer identity"
SelectedContact contact -> case contactIdentity contact of
- Just cid -> return cid
+ Just cid -> directMessageConversation cid
Nothing -> throwError "contact without erebos identity"
- _ -> throwError "no contact or peer selected"
+ SelectedConversation conv -> reloadConversation conv
+ _ -> throwError "no contact, peer or conversation selected"
commands :: [(String, Command)]
commands =
@@ -377,6 +381,7 @@ commands =
, ("contact-add", cmdContactAdd)
, ("contact-accept", cmdContactAccept)
, ("contact-reject", cmdContactReject)
+ , ("conversations", cmdConversations)
#ifdef ENABLE_ICE_SUPPORT
, ("discovery-init", cmdDiscoveryInit)
, ("discovery", cmdDiscovery)
@@ -433,22 +438,19 @@ cmdSelectContext n = join (asks ciContextOptions) >>= \ctxs -> if
cmdSend :: Command
cmdSend = void $ do
text <- asks ciLine
- powner <- finalOwner <$> getSelectedIdentity
- smsg <- sendDirectMessage powner $ T.pack text
+ conv <- getSelectedConversation
+ msg <- sendMessage conv $ T.pack text
tzone <- liftIO $ getCurrentTimeZone
- liftIO $ putStrLn $ formatMessage tzone $ fromStored smsg
+ liftIO $ putStrLn $ formatMessage tzone msg
cmdHistory :: Command
cmdHistory = void $ do
- ehead <- gets csHead
- powner <- finalOwner <$> getSelectedIdentity
-
- case find (sameIdentity powner . msgPeer) $
- toThreadList $ lookupSharedValue $ lsShared $ headObject ehead of
- Just thread -> do
+ conv <- getSelectedConversation
+ case conversationHistory conv of
+ thread@(_:_) -> do
tzone <- liftIO $ getCurrentTimeZone
- liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 $ threadToList thread
- Nothing -> do
+ liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 thread
+ [] -> do
liftIO $ putStrLn $ "<empty history>"
cmdUpdateIdentity :: Command
@@ -493,6 +495,14 @@ cmdContactAccept = contactAccept =<< getSelectedPeer
cmdContactReject :: Command
cmdContactReject = contactReject =<< getSelectedPeer
+cmdConversations :: Command
+cmdConversations = do
+ conversations <- lookupConversations
+ set <- asks ciSetContextOptions
+ set $ map SelectedConversation conversations
+ forM_ (zip [1..] conversations) $ \(i :: Int, conv) -> do
+ liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv)
+
#ifdef ENABLE_ICE_SUPPORT
cmdDiscoveryInit :: Command