summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--README.md17
-rw-r--r--erebos.cabal1
-rw-r--r--main/Main.hs46
-rw-r--r--src/Erebos/Conversation.hs75
-rw-r--r--src/Erebos/Message.hs7
5 files changed, 120 insertions, 26 deletions
diff --git a/README.md b/README.md
index 516c785..66e471c 100644
--- a/README.md
+++ b/README.md
@@ -36,9 +36,9 @@ to be attached to already existing identity on other device.
After the initial setup, the erebos tool presents interactive prompt for
messages and commands. All commands start with the slash (`/`) character,
-followed by command name and parameters (if any) separated by spaces. When a
-peer or contact is selected, message to send him can be entered directly on the
-command prompt.
+followed by command name and parameters (if any) separated by spaces. When
+a conversation is selected, message to send there is entered directly on
+the command prompt.
### Messaging
@@ -49,15 +49,18 @@ on local network or can be manually added.
`/contacts`
List known contacts (see below).
+`/conversations`
+List started conversations with contacts or other peers.
+
`/<number>`
-Select contact or peer `<number>` based on previous `/contacts` or `/peers`
-output list.
+Select conversation, contact or peer `<number>` based on the last
+`/conversations`, `/contacts` or `/peers` output list.
`<message>`
-Send `<message>` to selected contact.
+Send `<message>` to selected conversation.
`/history`
-Show message history for selected contact or peer.
+Show message history of the selected conversation.
### Add contacts
diff --git a/erebos.cabal b/erebos.cabal
index e0bf927..3c2d54e 100644
--- a/erebos.cabal
+++ b/erebos.cabal
@@ -97,6 +97,7 @@ library
Erebos.Channel
Erebos.Chatroom
Erebos.Contact
+ Erebos.Conversation
Erebos.Identity
Erebos.Message
Erebos.Network
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
diff --git a/src/Erebos/Conversation.hs b/src/Erebos/Conversation.hs
new file mode 100644
index 0000000..94d2399
--- /dev/null
+++ b/src/Erebos/Conversation.hs
@@ -0,0 +1,75 @@
+module Erebos.Conversation (
+ Message,
+ messageFrom,
+ messageText,
+ messageUnread,
+ formatMessage,
+
+ Conversation,
+ directMessageConversation,
+ reloadConversation,
+ lookupConversations,
+
+ conversationName,
+ conversationPeer,
+ conversationHistory,
+
+ sendMessage,
+) where
+
+import Control.Monad.Except
+
+import Data.List
+import Data.Maybe
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Time.LocalTime
+
+import Erebos.Identity
+import Erebos.Message hiding (formatMessage)
+import Erebos.State
+import Erebos.Storage
+
+
+data Message = DirectMessageMessage DirectMessage Bool
+
+messageFrom :: Message -> ComposedIdentity
+messageFrom (DirectMessageMessage msg _) = msgFrom msg
+
+messageText :: Message -> Maybe Text
+messageText (DirectMessageMessage msg _) = Just $ msgText msg
+
+messageUnread :: Message -> Bool
+messageUnread (DirectMessageMessage _ unread) = unread
+
+formatMessage :: TimeZone -> Message -> String
+formatMessage tzone (DirectMessageMessage msg _) = formatDirectMessage tzone msg
+
+
+data Conversation = DirectMessageConversation DirectMessageThread
+
+directMessageConversation :: MonadHead LocalState m => ComposedIdentity -> m Conversation
+directMessageConversation peer = do
+ (find (sameIdentity peer . msgPeer) . toThreadList . lookupSharedValue . lsShared . fromStored <$> getLocalHead) >>= \case
+ Just thread -> return $ DirectMessageConversation thread
+ Nothing -> return $ DirectMessageConversation $ DirectMessageThread peer [] [] []
+
+reloadConversation :: MonadHead LocalState m => Conversation -> m Conversation
+reloadConversation (DirectMessageConversation thread) = directMessageConversation (msgPeer thread)
+
+lookupConversations :: MonadHead LocalState m => m [Conversation]
+lookupConversations = map DirectMessageConversation . toThreadList . lookupSharedValue . lsShared . fromStored <$> getLocalHead
+
+
+conversationName :: Conversation -> Text
+conversationName (DirectMessageConversation thread) = fromMaybe (T.pack "<unnamed>") $ idName $ msgPeer thread
+
+conversationPeer :: Conversation -> Maybe ComposedIdentity
+conversationPeer (DirectMessageConversation thread) = Just $ msgPeer thread
+
+conversationHistory :: Conversation -> [Message]
+conversationHistory (DirectMessageConversation thread) = map (\msg -> DirectMessageMessage msg False) $ threadToList thread
+
+
+sendMessage :: (MonadHead LocalState m, MonadError String m) => Conversation -> Text -> m Message
+sendMessage (DirectMessageConversation thread) text = DirectMessageMessage <$> (fromStored <$> sendDirectMessage (msgPeer thread) text) <*> pure False
diff --git a/src/Erebos/Message.hs b/src/Erebos/Message.hs
index ea86ca0..f8ad2cf 100644
--- a/src/Erebos/Message.hs
+++ b/src/Erebos/Message.hs
@@ -14,6 +14,7 @@ module Erebos.Message (
watchReceivedMessages,
formatMessage,
+ formatDirectMessage,
) where
import Control.Monad
@@ -258,8 +259,12 @@ watchReceivedMessages h f = do
forM_ (map fromStored sms) $ \ms -> do
mapM_ f $ filter (not . sameIdentity self . msgFrom . fromStored) $ msReceived ms
+{-# DEPRECATED formatMessage "use formatDirectMessage instead" #-}
formatMessage :: TimeZone -> DirectMessage -> String
-formatMessage tzone msg = concat
+formatMessage = formatDirectMessage
+
+formatDirectMessage :: TimeZone -> DirectMessage -> String
+formatDirectMessage tzone msg = concat
[ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg
, maybe "<unnamed>" T.unpack $ idName $ msgFrom msg
, ": "