diff options
| -rw-r--r-- | README.md | 17 | ||||
| -rw-r--r-- | erebos.cabal | 1 | ||||
| -rw-r--r-- | main/Main.hs | 46 | ||||
| -rw-r--r-- | src/Erebos/Conversation.hs | 75 | ||||
| -rw-r--r-- | src/Erebos/Message.hs | 7 |
5 files changed, 120 insertions, 26 deletions
@@ -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 , ": " |