From c6d2fb81847407ba3a0ce3c5c9e890cc4de87cf2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Tue, 12 Nov 2024 19:15:12 +0100 Subject: Rename Message module to DirectMessage Changelog: API: Rename `Erebos.Message` module to `Erebos.DirectMessage` --- erebos.cabal | 2 +- main/Main.hs | 2 +- main/Test.hs | 2 +- src/Erebos/Conversation.hs | 2 +- src/Erebos/DirectMessage.hs | 268 ++++++++++++++++++++++++++++++++++++++++++++ src/Erebos/Message.hs | 268 -------------------------------------------- 6 files changed, 272 insertions(+), 272 deletions(-) create mode 100644 src/Erebos/DirectMessage.hs delete mode 100644 src/Erebos/Message.hs diff --git a/erebos.cabal b/erebos.cabal index c76224d..ba00538 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -97,8 +97,8 @@ library Erebos.Chatroom Erebos.Contact Erebos.Conversation + Erebos.DirectMessage Erebos.Identity - Erebos.Message Erebos.Network Erebos.Network.Channel Erebos.Network.Protocol diff --git a/main/Main.hs b/main/Main.hs index 8a1a851..7f9250b 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -40,12 +40,12 @@ import Erebos.Attach import Erebos.Contact import Erebos.Chatroom import Erebos.Conversation +import Erebos.DirectMessage #ifdef ENABLE_ICE_SUPPORT import Erebos.Discovery import Erebos.ICE #endif import Erebos.Identity -import Erebos.Message import Erebos.Network import Erebos.Object import Erebos.PubKey diff --git a/main/Test.hs b/main/Test.hs index 9c68165..628e351 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -34,8 +34,8 @@ import System.IO.Error import Erebos.Attach import Erebos.Chatroom import Erebos.Contact +import Erebos.DirectMessage import Erebos.Identity -import Erebos.Message import Erebos.Network import Erebos.Object import Erebos.Pairing diff --git a/src/Erebos/Conversation.hs b/src/Erebos/Conversation.hs index 415bdc0..fce8780 100644 --- a/src/Erebos/Conversation.hs +++ b/src/Erebos/Conversation.hs @@ -30,8 +30,8 @@ import Data.Time.Format import Data.Time.LocalTime import Erebos.Chatroom +import Erebos.DirectMessage import Erebos.Identity -import Erebos.Message import Erebos.State import Erebos.Storable diff --git a/src/Erebos/DirectMessage.hs b/src/Erebos/DirectMessage.hs new file mode 100644 index 0000000..39d453c --- /dev/null +++ b/src/Erebos/DirectMessage.hs @@ -0,0 +1,268 @@ +module Erebos.DirectMessage ( + DirectMessage(..), + sendDirectMessage, + + DirectMessageAttributes(..), + defaultDirectMessageAttributes, + + DirectMessageThreads, + toThreadList, + + DirectMessageThread(..), + threadToList, + messageThreadView, + + watchReceivedMessages, + formatDirectMessage, +) where + +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader + +import Data.List +import Data.Ord +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Format +import Data.Time.LocalTime + +import Erebos.Identity +import Erebos.Network +import Erebos.Service +import Erebos.State +import Erebos.Storable +import Erebos.Storage.Head +import Erebos.Storage.Merge + +data DirectMessage = DirectMessage + { msgFrom :: ComposedIdentity + , msgPrev :: [Stored DirectMessage] + , msgTime :: ZonedTime + , msgText :: Text + } + +instance Storable DirectMessage where + store' msg = storeRec $ do + mapM_ (storeRef "from") $ idExtDataF $ msgFrom msg + mapM_ (storeRef "PREV") $ msgPrev msg + storeDate "time" $ msgTime msg + storeText "text" $ msgText msg + + load' = loadRec $ DirectMessage + <$> loadIdentity "from" + <*> loadRefs "PREV" + <*> loadDate "time" + <*> loadText "text" + +data DirectMessageAttributes = DirectMessageAttributes + { dmOwnerMismatch :: ServiceHandler DirectMessage () + } + +defaultDirectMessageAttributes :: DirectMessageAttributes +defaultDirectMessageAttributes = DirectMessageAttributes + { dmOwnerMismatch = svcPrint "Owner mismatch" + } + +instance Service DirectMessage where + serviceID _ = mkServiceID "c702076c-4928-4415-8b6b-3e839eafcb0d" + + type ServiceAttributes DirectMessage = DirectMessageAttributes + defaultServiceAttributes _ = defaultDirectMessageAttributes + + serviceHandler smsg = do + let msg = fromStored smsg + powner <- asks $ finalOwner . svcPeerIdentity + erb <- svcGetLocal + st <- getStorage + let DirectMessageThreads prev _ = lookupSharedValue $ lsShared $ fromStored erb + sent = findMsgProperty powner msSent prev + received = findMsgProperty powner msReceived prev + received' = filterAncestors $ smsg : received + if powner `sameIdentity` msgFrom msg || + filterAncestors sent == filterAncestors (smsg : sent) + then do + when (received' /= received) $ do + next <- wrappedStore st $ MessageState + { msPrev = prev + , msPeer = powner + , msReady = [] + , msSent = [] + , msReceived = received' + , msSeen = [] + } + let threads = DirectMessageThreads [next] (messageThreadView [next]) + shared <- makeSharedStateUpdate st threads (lsShared $ fromStored erb) + svcSetLocal =<< wrappedStore st (fromStored erb) { lsShared = [shared] } + + when (powner `sameIdentity` msgFrom msg) $ do + replyStoredRef smsg + + else join $ asks $ dmOwnerMismatch . svcAttributes + + serviceNewPeer = syncDirectMessageToPeer . lookupSharedValue . lsShared . fromStored =<< svcGetLocal + + serviceStorageWatchers _ = (:[]) $ + SomeStorageWatcher (lookupSharedValue . lsShared . fromStored) syncDirectMessageToPeer + + +data MessageState = MessageState + { msPrev :: [Stored MessageState] + , msPeer :: ComposedIdentity + , msReady :: [Stored DirectMessage] + , msSent :: [Stored DirectMessage] + , msReceived :: [Stored DirectMessage] + , msSeen :: [Stored DirectMessage] + } + +data DirectMessageThreads = DirectMessageThreads [Stored MessageState] [DirectMessageThread] + +instance Eq DirectMessageThreads where + DirectMessageThreads mss _ == DirectMessageThreads mss' _ = mss == mss' + +toThreadList :: DirectMessageThreads -> [DirectMessageThread] +toThreadList (DirectMessageThreads _ threads) = threads + +instance Storable MessageState where + store' MessageState {..} = storeRec $ do + mapM_ (storeRef "PREV") msPrev + mapM_ (storeRef "peer") $ idExtDataF msPeer + mapM_ (storeRef "ready") msReady + mapM_ (storeRef "sent") msSent + mapM_ (storeRef "received") msReceived + mapM_ (storeRef "seen") msSeen + + load' = loadRec $ do + msPrev <- loadRefs "PREV" + msPeer <- loadIdentity "peer" + msReady <- loadRefs "ready" + msSent <- loadRefs "sent" + msReceived <- loadRefs "received" + msSeen <- loadRefs "seen" + return MessageState {..} + +instance Mergeable DirectMessageThreads where + type Component DirectMessageThreads = MessageState + mergeSorted mss = DirectMessageThreads mss (messageThreadView mss) + toComponents (DirectMessageThreads mss _) = mss + +instance SharedType DirectMessageThreads where + sharedTypeID _ = mkSharedTypeID "ee793681-5976-466a-b0f0-4e1907d3fade" + +findMsgProperty :: Foldable m => Identity m -> (MessageState -> [a]) -> [Stored MessageState] -> [a] +findMsgProperty pid sel mss = concat $ flip findProperty mss $ \x -> do + guard $ msPeer x `sameIdentity` pid + guard $ not $ null $ sel x + return $ sel x + + +sendDirectMessage :: (Foldable f, Applicative f, MonadHead LocalState m, MonadError String m) + => Identity f -> Text -> m (Stored DirectMessage) +sendDirectMessage pid text = updateLocalHead $ \ls -> do + let self = localIdentity $ fromStored ls + powner = finalOwner pid + flip updateSharedState ls $ \(DirectMessageThreads prev _) -> do + let ready = findMsgProperty powner msReady prev + received = findMsgProperty powner msReceived prev + + time <- liftIO getZonedTime + smsg <- mstore DirectMessage + { msgFrom = toComposedIdentity $ finalOwner self + , msgPrev = filterAncestors $ ready ++ received + , msgTime = time + , msgText = text + } + next <- mstore MessageState + { msPrev = prev + , msPeer = powner + , msReady = [smsg] + , msSent = [] + , msReceived = [] + , msSeen = [] + } + return (DirectMessageThreads [next] (messageThreadView [next]), smsg) + +syncDirectMessageToPeer :: DirectMessageThreads -> ServiceHandler DirectMessage () +syncDirectMessageToPeer (DirectMessageThreads mss _) = do + pid <- finalOwner <$> asks svcPeerIdentity + peer <- asks svcPeer + let thread = messageThreadFor pid mss + mapM_ (sendToPeerStored peer) $ msgHead thread + updateLocalHead_ $ \ls -> do + let powner = finalOwner pid + flip updateSharedState_ ls $ \unchanged@(DirectMessageThreads prev _) -> do + let ready = findMsgProperty powner msReady prev + sent = findMsgProperty powner msSent prev + sent' = filterAncestors (ready ++ sent) + + if sent' /= sent + then do + next <- mstore MessageState + { msPrev = prev + , msPeer = powner + , msReady = [] + , msSent = sent' + , msReceived = [] + , msSeen = [] + } + return $ DirectMessageThreads [next] (messageThreadView [next]) + else do + return unchanged + + +data DirectMessageThread = DirectMessageThread + { msgPeer :: ComposedIdentity + , msgHead :: [Stored DirectMessage] + , msgSent :: [Stored DirectMessage] + , msgSeen :: [Stored DirectMessage] + } + +threadToList :: DirectMessageThread -> [DirectMessage] +threadToList thread = helper S.empty $ msgHead thread + where helper seen msgs + | msg : msgs' <- filter (`S.notMember` seen) $ reverse $ sortBy (comparing cmpView) msgs = + fromStored msg : helper (S.insert msg seen) (msgs' ++ msgPrev (fromStored msg)) + | otherwise = [] + cmpView msg = (zonedTimeToUTC $ msgTime $ fromStored msg, msg) + +messageThreadView :: [Stored MessageState] -> [DirectMessageThread] +messageThreadView = helper [] + where helper used ms' = case filterAncestors ms' of + mss@(sms : rest) + | any (sameIdentity $ msPeer $ fromStored sms) used -> + helper used $ msPrev (fromStored sms) ++ rest + | otherwise -> + let peer = msPeer $ fromStored sms + in messageThreadFor peer mss : helper (peer : used) (msPrev (fromStored sms) ++ rest) + _ -> [] + +messageThreadFor :: ComposedIdentity -> [Stored MessageState] -> DirectMessageThread +messageThreadFor peer mss = + let ready = findMsgProperty peer msReady mss + sent = findMsgProperty peer msSent mss + received = findMsgProperty peer msReceived mss + seen = findMsgProperty peer msSeen mss + + in DirectMessageThread + { msgPeer = peer + , msgHead = filterAncestors $ ready ++ received + , msgSent = filterAncestors $ sent ++ received + , msgSeen = filterAncestors $ ready ++ seen + } + + +watchReceivedMessages :: Head LocalState -> (Stored DirectMessage -> IO ()) -> IO WatchedHead +watchReceivedMessages h f = do + let self = finalOwner $ localIdentity $ headObject h + watchHeadWith h (lookupSharedValue . lsShared . headObject) $ \(DirectMessageThreads sms _) -> do + forM_ (map fromStored sms) $ \ms -> do + mapM_ f $ filter (not . sameIdentity self . msgFrom . fromStored) $ msReceived ms + +formatDirectMessage :: TimeZone -> DirectMessage -> String +formatDirectMessage tzone msg = concat + [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg + , maybe "" T.unpack $ idName $ msgFrom msg + , ": " + , T.unpack $ msgText msg + ] diff --git a/src/Erebos/Message.hs b/src/Erebos/Message.hs deleted file mode 100644 index 5ac0ca4..0000000 --- a/src/Erebos/Message.hs +++ /dev/null @@ -1,268 +0,0 @@ -module Erebos.Message ( - DirectMessage(..), - sendDirectMessage, - - DirectMessageAttributes(..), - defaultDirectMessageAttributes, - - DirectMessageThreads, - toThreadList, - - DirectMessageThread(..), - threadToList, - messageThreadView, - - watchReceivedMessages, - formatDirectMessage, -) where - -import Control.Monad -import Control.Monad.Except -import Control.Monad.Reader - -import Data.List -import Data.Ord -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Format -import Data.Time.LocalTime - -import Erebos.Identity -import Erebos.Network -import Erebos.Service -import Erebos.State -import Erebos.Storable -import Erebos.Storage.Head -import Erebos.Storage.Merge - -data DirectMessage = DirectMessage - { msgFrom :: ComposedIdentity - , msgPrev :: [Stored DirectMessage] - , msgTime :: ZonedTime - , msgText :: Text - } - -instance Storable DirectMessage where - store' msg = storeRec $ do - mapM_ (storeRef "from") $ idExtDataF $ msgFrom msg - mapM_ (storeRef "PREV") $ msgPrev msg - storeDate "time" $ msgTime msg - storeText "text" $ msgText msg - - load' = loadRec $ DirectMessage - <$> loadIdentity "from" - <*> loadRefs "PREV" - <*> loadDate "time" - <*> loadText "text" - -data DirectMessageAttributes = DirectMessageAttributes - { dmOwnerMismatch :: ServiceHandler DirectMessage () - } - -defaultDirectMessageAttributes :: DirectMessageAttributes -defaultDirectMessageAttributes = DirectMessageAttributes - { dmOwnerMismatch = svcPrint "Owner mismatch" - } - -instance Service DirectMessage where - serviceID _ = mkServiceID "c702076c-4928-4415-8b6b-3e839eafcb0d" - - type ServiceAttributes DirectMessage = DirectMessageAttributes - defaultServiceAttributes _ = defaultDirectMessageAttributes - - serviceHandler smsg = do - let msg = fromStored smsg - powner <- asks $ finalOwner . svcPeerIdentity - erb <- svcGetLocal - st <- getStorage - let DirectMessageThreads prev _ = lookupSharedValue $ lsShared $ fromStored erb - sent = findMsgProperty powner msSent prev - received = findMsgProperty powner msReceived prev - received' = filterAncestors $ smsg : received - if powner `sameIdentity` msgFrom msg || - filterAncestors sent == filterAncestors (smsg : sent) - then do - when (received' /= received) $ do - next <- wrappedStore st $ MessageState - { msPrev = prev - , msPeer = powner - , msReady = [] - , msSent = [] - , msReceived = received' - , msSeen = [] - } - let threads = DirectMessageThreads [next] (messageThreadView [next]) - shared <- makeSharedStateUpdate st threads (lsShared $ fromStored erb) - svcSetLocal =<< wrappedStore st (fromStored erb) { lsShared = [shared] } - - when (powner `sameIdentity` msgFrom msg) $ do - replyStoredRef smsg - - else join $ asks $ dmOwnerMismatch . svcAttributes - - serviceNewPeer = syncDirectMessageToPeer . lookupSharedValue . lsShared . fromStored =<< svcGetLocal - - serviceStorageWatchers _ = (:[]) $ - SomeStorageWatcher (lookupSharedValue . lsShared . fromStored) syncDirectMessageToPeer - - -data MessageState = MessageState - { msPrev :: [Stored MessageState] - , msPeer :: ComposedIdentity - , msReady :: [Stored DirectMessage] - , msSent :: [Stored DirectMessage] - , msReceived :: [Stored DirectMessage] - , msSeen :: [Stored DirectMessage] - } - -data DirectMessageThreads = DirectMessageThreads [Stored MessageState] [DirectMessageThread] - -instance Eq DirectMessageThreads where - DirectMessageThreads mss _ == DirectMessageThreads mss' _ = mss == mss' - -toThreadList :: DirectMessageThreads -> [DirectMessageThread] -toThreadList (DirectMessageThreads _ threads) = threads - -instance Storable MessageState where - store' MessageState {..} = storeRec $ do - mapM_ (storeRef "PREV") msPrev - mapM_ (storeRef "peer") $ idExtDataF msPeer - mapM_ (storeRef "ready") msReady - mapM_ (storeRef "sent") msSent - mapM_ (storeRef "received") msReceived - mapM_ (storeRef "seen") msSeen - - load' = loadRec $ do - msPrev <- loadRefs "PREV" - msPeer <- loadIdentity "peer" - msReady <- loadRefs "ready" - msSent <- loadRefs "sent" - msReceived <- loadRefs "received" - msSeen <- loadRefs "seen" - return MessageState {..} - -instance Mergeable DirectMessageThreads where - type Component DirectMessageThreads = MessageState - mergeSorted mss = DirectMessageThreads mss (messageThreadView mss) - toComponents (DirectMessageThreads mss _) = mss - -instance SharedType DirectMessageThreads where - sharedTypeID _ = mkSharedTypeID "ee793681-5976-466a-b0f0-4e1907d3fade" - -findMsgProperty :: Foldable m => Identity m -> (MessageState -> [a]) -> [Stored MessageState] -> [a] -findMsgProperty pid sel mss = concat $ flip findProperty mss $ \x -> do - guard $ msPeer x `sameIdentity` pid - guard $ not $ null $ sel x - return $ sel x - - -sendDirectMessage :: (Foldable f, Applicative f, MonadHead LocalState m, MonadError String m) - => Identity f -> Text -> m (Stored DirectMessage) -sendDirectMessage pid text = updateLocalHead $ \ls -> do - let self = localIdentity $ fromStored ls - powner = finalOwner pid - flip updateSharedState ls $ \(DirectMessageThreads prev _) -> do - let ready = findMsgProperty powner msReady prev - received = findMsgProperty powner msReceived prev - - time <- liftIO getZonedTime - smsg <- mstore DirectMessage - { msgFrom = toComposedIdentity $ finalOwner self - , msgPrev = filterAncestors $ ready ++ received - , msgTime = time - , msgText = text - } - next <- mstore MessageState - { msPrev = prev - , msPeer = powner - , msReady = [smsg] - , msSent = [] - , msReceived = [] - , msSeen = [] - } - return (DirectMessageThreads [next] (messageThreadView [next]), smsg) - -syncDirectMessageToPeer :: DirectMessageThreads -> ServiceHandler DirectMessage () -syncDirectMessageToPeer (DirectMessageThreads mss _) = do - pid <- finalOwner <$> asks svcPeerIdentity - peer <- asks svcPeer - let thread = messageThreadFor pid mss - mapM_ (sendToPeerStored peer) $ msgHead thread - updateLocalHead_ $ \ls -> do - let powner = finalOwner pid - flip updateSharedState_ ls $ \unchanged@(DirectMessageThreads prev _) -> do - let ready = findMsgProperty powner msReady prev - sent = findMsgProperty powner msSent prev - sent' = filterAncestors (ready ++ sent) - - if sent' /= sent - then do - next <- mstore MessageState - { msPrev = prev - , msPeer = powner - , msReady = [] - , msSent = sent' - , msReceived = [] - , msSeen = [] - } - return $ DirectMessageThreads [next] (messageThreadView [next]) - else do - return unchanged - - -data DirectMessageThread = DirectMessageThread - { msgPeer :: ComposedIdentity - , msgHead :: [Stored DirectMessage] - , msgSent :: [Stored DirectMessage] - , msgSeen :: [Stored DirectMessage] - } - -threadToList :: DirectMessageThread -> [DirectMessage] -threadToList thread = helper S.empty $ msgHead thread - where helper seen msgs - | msg : msgs' <- filter (`S.notMember` seen) $ reverse $ sortBy (comparing cmpView) msgs = - fromStored msg : helper (S.insert msg seen) (msgs' ++ msgPrev (fromStored msg)) - | otherwise = [] - cmpView msg = (zonedTimeToUTC $ msgTime $ fromStored msg, msg) - -messageThreadView :: [Stored MessageState] -> [DirectMessageThread] -messageThreadView = helper [] - where helper used ms' = case filterAncestors ms' of - mss@(sms : rest) - | any (sameIdentity $ msPeer $ fromStored sms) used -> - helper used $ msPrev (fromStored sms) ++ rest - | otherwise -> - let peer = msPeer $ fromStored sms - in messageThreadFor peer mss : helper (peer : used) (msPrev (fromStored sms) ++ rest) - _ -> [] - -messageThreadFor :: ComposedIdentity -> [Stored MessageState] -> DirectMessageThread -messageThreadFor peer mss = - let ready = findMsgProperty peer msReady mss - sent = findMsgProperty peer msSent mss - received = findMsgProperty peer msReceived mss - seen = findMsgProperty peer msSeen mss - - in DirectMessageThread - { msgPeer = peer - , msgHead = filterAncestors $ ready ++ received - , msgSent = filterAncestors $ sent ++ received - , msgSeen = filterAncestors $ ready ++ seen - } - - -watchReceivedMessages :: Head LocalState -> (Stored DirectMessage -> IO ()) -> IO WatchedHead -watchReceivedMessages h f = do - let self = finalOwner $ localIdentity $ headObject h - watchHeadWith h (lookupSharedValue . lsShared . headObject) $ \(DirectMessageThreads sms _) -> do - forM_ (map fromStored sms) $ \ms -> do - mapM_ f $ filter (not . sameIdentity self . msgFrom . fromStored) $ msReceived ms - -formatDirectMessage :: TimeZone -> DirectMessage -> String -formatDirectMessage tzone msg = concat - [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg - , maybe "" T.unpack $ idName $ msgFrom msg - , ": " - , T.unpack $ msgText msg - ] -- cgit v1.2.3