From 84d7c83bc85ff0862a39d6de3bd227550175ebce Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sun, 2 Feb 2020 21:03:02 +0100 Subject: Direct messages in shared state --- erebos.cabal | 1 - src/Identity.hs | 5 +- src/Main.hs | 22 +----- src/Message.hs | 194 +++++++++++++++++++++++++++++++++++++++---------- src/Message/Service.hs | 63 ---------------- src/State.hs | 8 -- src/Storage/Merge.hs | 10 +++ 7 files changed, 173 insertions(+), 130 deletions(-) delete mode 100644 src/Message/Service.hs diff --git a/erebos.cabal b/erebos.cabal index 766d708..e7a8cee 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -22,7 +22,6 @@ executable erebos Identity, Channel, Message, - Message.Service Network, PubKey, Service diff --git a/src/Identity.hs b/src/Identity.hs index dcf0ca4..91bd04c 100644 --- a/src/Identity.hs +++ b/src/Identity.hs @@ -6,7 +6,7 @@ module Identity ( emptyIdentityData, validateIdentity, validateIdentityF, - loadIdentity, + loadIdentity, loadUnifiedIdentity, mergeIdentity, toUnifiedIdentity, toComposedIdentity, updateIdentity, updateOwners, @@ -128,6 +128,9 @@ validateIdentityF mdata = do loadIdentity :: String -> LoadRec ComposedIdentity loadIdentity name = maybe (throwError "identity validation failed") return . validateIdentityF =<< loadRefs name +loadUnifiedIdentity :: String -> LoadRec UnifiedIdentity +loadUnifiedIdentity name = maybe (throwError "identity validation failed") return . validateIdentity =<< loadRef name + gatherPrevious :: Set (Stored (Signed IdentityData)) -> [Stored (Signed IdentityData)] -> Set (Stored (Signed IdentityData)) gatherPrevious res (n:ns) | n `S.member` res = gatherPrevious res ns diff --git a/src/Main.hs b/src/Main.hs index 696b896..6da9826 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -27,13 +27,11 @@ import System.Environment import Attach import Identity import Message -import Message.Service import Network import PubKey import Service import State import Storage -import Storage.List import Sync main :: IO () @@ -211,24 +209,9 @@ cmdSetPeer n | n < 1 = liftIO $ putStrLn "Invalid peer index" cmdSend :: Command cmdSend = void $ do self <- asks ciSelf - let st = storedStorage $ idData self Just peer <- gets csPeer - PeerIdentityFull pid <- return $ peerIdentity peer - let powner = finalOwner pid :: ComposedIdentity text <- asks ciLine - smsg <- liftIO $ updateLocalState st $ \erb -> do - threads <- storedFromSList $ lsMessages $ fromStored erb - (slist, smsg) <- case find (sameIdentity powner . msgPeer . fromStored) threads of - Just thread -> do - (smsg, thread') <- createDirectMessage self (fromStored thread) (T.pack text) - (,smsg) <$> slistReplaceS thread thread' (lsMessages $ fromStored erb) - Nothing -> do - (smsg, thread') <- createDirectMessage self (emptyDirectThread powner) (T.pack text) - (,smsg) <$> slistAddS thread' (lsMessages $ fromStored erb) - erb' <- wrappedStore st (fromStored erb) { lsMessages = slist } - return (erb', smsg) - sendToPeer self peer $ DirectMessagePacket smsg - + smsg <- sendDirectMessage self peer $ T.pack text tzone <- liftIO $ getCurrentTimeZone liftIO $ putStrLn $ formatMessage tzone $ fromStored smsg @@ -242,7 +225,8 @@ cmdHistory = void $ do Just erebosHead <- liftIO $ loadHead st "erebos" let erebos = wrappedLoad (headRef erebosHead) - Just thread <- return $ find (sameIdentity powner . msgPeer) $ fromSList $ lsMessages $ fromStored erebos + Just thread <- return $ find (sameIdentity powner . msgPeer) $ + messageThreadView $ lookupSharedValue $ lsShared $ fromStored erebos tzone <- liftIO $ getCurrentTimeZone liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 $ threadToList thread diff --git a/src/Message.hs b/src/Message.hs index 21f398c..bfb4b66 100644 --- a/src/Message.hs +++ b/src/Message.hs @@ -1,16 +1,32 @@ module Message ( - DirectMessage(..), DirectMessageThread(..), - emptyDirectThread, createDirectMessage, + DirectMessage(..), + DirectMessageService, + ServicePacket(DirectMessagePacket), + + sendDirectMessage, + + DirectMessageThread(..), threadToList, + messageThreadView, + + formatMessage, ) where +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 Identity +import Network +import Service +import State import Storage import Storage.Merge @@ -21,12 +37,6 @@ data DirectMessage = DirectMessage , msgText :: Text } -data DirectMessageThread = DirectMessageThread - { msgPeer :: ComposedIdentity - , msgHead :: [Stored DirectMessage] - , msgSeen :: [Stored DirectMessage] - } - instance Storable DirectMessage where store' msg = storeRec $ do mapM_ (storeRef "from") $ idDataF $ msgFrom msg @@ -40,43 +50,123 @@ instance Storable DirectMessage where <*> loadDate "time" <*> loadText "text" -instance Storable DirectMessageThread where - store' msg = storeRec $ do - mapM_ (storeRef "peer") $ idDataF $ msgPeer msg - mapM_ (storeRef "head") $ msgHead msg - mapM_ (storeRef "seen") $ msgSeen msg +data DirectMessageService + +instance Service DirectMessageService where + serviceID _ = mkServiceID "c702076c-4928-4415-8b6b-3e839eafcb0d" + + data ServiceState DirectMessageService = DirectMessageService + emptyServiceState = DirectMessageService + + newtype ServicePacket DirectMessageService = DirectMessagePacket (Stored DirectMessage) + + serviceHandler packet = do + let DirectMessagePacket smsg = fromStored packet + msg = fromStored smsg + powner <- asks $ finalOwner . svcPeer + tzone <- liftIO $ getCurrentTimeZone + erb <- svcGetLocal + let st = storedStorage erb + prev = lookupSharedValue $ lsShared $ fromStored erb + sent = findMsgProperty powner msSent prev + received = findMsgProperty powner msReceived prev + if powner `sameIdentity` msgFrom msg || + filterAncestors sent == filterAncestors (smsg : sent) + then do + erb' <- liftIO $ do + next <- wrappedStore st $ MessageState + { msPrev = prev + , msPeer = powner + , msSent = [] + , msReceived = filterAncestors $ smsg : received + , msSeen = [] + } + shared <- makeSharedStateUpdate st [next] (lsShared $ fromStored erb) + wrappedStore st (fromStored erb) { lsShared = [shared] } + svcSetLocal erb' + if powner `sameIdentity` msgFrom msg + then do + svcPrint $ formatMessage tzone msg + return $ Just $ DirectMessagePacket smsg + else return Nothing + + else do svcPrint "Owner mismatch" + return Nothing + +instance Storable (ServicePacket DirectMessageService) where + store' (DirectMessagePacket smsg) = store' smsg + load' = DirectMessagePacket <$> load' + - load' = loadRec $ DirectMessageThread - <$> loadIdentity "peer" - <*> loadRefs "head" +data MessageState = MessageState + { msPrev :: [Stored MessageState] + , msPeer :: ComposedIdentity + , msSent :: [Stored DirectMessage] + , msReceived :: [Stored DirectMessage] + , msSeen :: [Stored DirectMessage] + } + +instance Storable MessageState where + store' ms = storeRec $ do + mapM_ (storeRef "PREV") $ msPrev ms + mapM_ (storeRef "peer") $ idDataF $ msPeer ms + mapM_ (storeRef "sent") $ msSent ms + mapM_ (storeRef "received") $ msReceived ms + mapM_ (storeRef "seen") $ msSeen ms + + load' = loadRec $ MessageState + <$> loadRefs "PREV" + <*> loadIdentity "peer" + <*> loadRefs "sent" + <*> loadRefs "received" <*> loadRefs "seen" -instance Mergeable DirectMessageThread where - mergeSorted ts = DirectMessageThread - { msgPeer = msgPeer $ fromStored $ head ts -- TODO: merge identity - , msgHead = filterAncestors $ msgHead . fromStored =<< ts - , msgSeen = filterAncestors $ msgSeen . fromStored =<< ts - } +instance SharedType MessageState 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 -emptyDirectThread :: ComposedIdentity -> DirectMessageThread -emptyDirectThread peer = DirectMessageThread peer [] [] -createDirectMessage :: UnifiedIdentity -> DirectMessageThread -> Text -> IO (Stored DirectMessage, Stored DirectMessageThread) -createDirectMessage self thread msg = do +sendDirectMessage :: (MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> Text -> m (Stored DirectMessage) +sendDirectMessage self peer text = do + pid <- case peerIdentity peer of PeerIdentityFull pid -> return pid + _ -> throwError "incomplete peer identity" let st = storedStorage $ idData self - time <- getZonedTime - smsg <- wrappedStore st DirectMessage - { msgFrom = toComposedIdentity $ finalOwner self - , msgPrev = msgHead thread - , msgTime = time - , msgText = msg - } - sthread <- wrappedStore st thread - { msgHead = [smsg] - , msgSeen = [smsg] - } - return (smsg, sthread) + powner = finalOwner pid + + smsg <- liftIO $ updateSharedState st $ \prev -> do + let sent = findMsgProperty powner msSent prev + received = findMsgProperty powner msReceived prev + + time <- getZonedTime + smsg <- wrappedStore st DirectMessage + { msgFrom = toComposedIdentity $ finalOwner self + , msgPrev = filterAncestors $ sent ++ received + , msgTime = time + , msgText = text + } + next <- wrappedStore st $ MessageState + { msPrev = prev + , msPeer = powner + , msSent = [smsg] + , msReceived = [] + , msSeen = [] + } + return ([next], smsg) + + sendToPeer self peer $ DirectMessagePacket smsg + return smsg + + +data DirectMessageThread = DirectMessageThread + { msgPeer :: ComposedIdentity + , msgHead :: [Stored DirectMessage] + , msgSeen :: [Stored DirectMessage] + } threadToList :: DirectMessageThread -> [DirectMessage] threadToList thread = helper S.empty $ msgHead thread @@ -85,3 +175,31 @@ threadToList thread = helper S.empty $ msgHead thread 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 + sent = findMsgProperty peer msSent mss + received = findMsgProperty peer msReceived mss + seen = findMsgProperty peer msSeen mss + + in DirectMessageThread + { msgPeer = peer + , msgHead = filterAncestors $ sent ++ received + , msgSeen = filterAncestors $ sent ++ seen + } : helper (peer : used) (msPrev (fromStored sms) ++ rest) + _ -> [] + + +formatMessage :: TimeZone -> DirectMessage -> String +formatMessage 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/Message/Service.hs b/src/Message/Service.hs deleted file mode 100644 index 0a8f180..0000000 --- a/src/Message/Service.hs +++ /dev/null @@ -1,63 +0,0 @@ -module Message.Service ( - DirectMessageService, - ServicePacket(DirectMessagePacket), - formatMessage, -) where - -import Control.Monad.Reader - -import Data.List -import qualified Data.Text as T -import Data.Time.Format -import Data.Time.LocalTime - -import Identity -import Message -import Service -import State -import Storage -import Storage.List - -data DirectMessageService - -instance Service DirectMessageService where - serviceID _ = mkServiceID "c702076c-4928-4415-8b6b-3e839eafcb0d" - - data ServiceState DirectMessageService = DirectMessageService - emptyServiceState = DirectMessageService - - newtype ServicePacket DirectMessageService = DirectMessagePacket (Stored DirectMessage) - - serviceHandler packet = do - let DirectMessagePacket smsg = fromStored packet - msg = fromStored smsg - powner <- asks $ finalOwner . svcPeer - tzone <- liftIO $ getCurrentTimeZone - svcPrint $ formatMessage tzone msg - if | powner `sameIdentity` msgFrom msg - -> do erb <- svcGetLocal - let st = storedStorage erb - erb' <- liftIO $ do - threads <- storedFromSList $ lsMessages $ fromStored erb - slist <- case find (sameIdentity powner . msgPeer . fromStored) threads of - Just thread -> do thread' <- wrappedStore st (fromStored thread) { msgHead = smsg : msgHead (fromStored thread) } - slistReplaceS thread thread' $ lsMessages $ fromStored erb - Nothing -> slistAdd (emptyDirectThread powner) { msgHead = [smsg] } $ lsMessages $ fromStored erb - wrappedStore st (fromStored erb) { lsMessages = slist } - svcSetLocal erb' - return Nothing - - | otherwise -> do svcPrint "Owner mismatch" - return Nothing - -instance Storable (ServicePacket DirectMessageService) where - store' (DirectMessagePacket smsg) = store' smsg - load' = DirectMessagePacket <$> load' - -formatMessage :: TimeZone -> DirectMessage -> String -formatMessage 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/State.hs b/src/State.hs index bb7c570..15ae7d2 100644 --- a/src/State.hs +++ b/src/State.hs @@ -29,16 +29,13 @@ import qualified Data.UUID as U import System.IO import Identity -import Message import PubKey import Storage -import Storage.List import Storage.Merge data LocalState = LocalState { lsIdentity :: Stored (Signed IdentityData) , lsShared :: [Stored SharedState] - , lsMessages :: StoredList DirectMessageThread -- TODO: move to shared } data SharedState = SharedState @@ -60,12 +57,10 @@ instance Storable LocalState where store' st = storeRec $ do storeRef "id" $ lsIdentity st mapM_ (storeRef "shared") $ lsShared st - storeRef "dmsg" $ lsMessages st load' = loadRec $ LocalState <$> loadRef "id" <*> loadRefs "shared" - <*> loadRef "dmsg" instance Storable SharedState where store' st = storeRec $ do @@ -114,8 +109,6 @@ loadLocalStateHead st = loadHeadDef st "erebos" $ do , iddKeyMessage = Just devPublicMsg } - msgs <- emptySList st - shared <- wrappedStore st $ SharedState { ssPrev = [] , ssType = Just $ sharedTypeID @(Signed IdentityData) Proxy @@ -124,7 +117,6 @@ loadLocalStateHead st = loadHeadDef st "erebos" $ do return $ LocalState { lsIdentity = identity , lsShared = [shared] - , lsMessages = msgs } loadLocalIdentity :: Storage -> IO UnifiedIdentity diff --git a/src/Storage/Merge.hs b/src/Storage/Merge.hs index 17b02aa..f0eaf98 100644 --- a/src/Storage/Merge.hs +++ b/src/Storage/Merge.hs @@ -6,6 +6,8 @@ module Storage.Merge ( ancestors, precedes, filterAncestors, + + findProperty, ) where import qualified Data.ByteString.Char8 as BC @@ -58,4 +60,12 @@ precedes :: Storable a => Stored a -> Stored a -> Bool precedes x y = x `S.member` ancestors [y] filterAncestors :: Storable a => [Stored a] -> [Stored a] +filterAncestors [x] = [x] filterAncestors xs = uniq $ sort $ filter (`S.notMember` ancestors xs) xs + + +findProperty :: forall a b. Storable a => (a -> Maybe b) -> [Stored a] -> [b] +findProperty sel = map (fromJust . sel . fromStored) . filterAncestors . (findPropHeads =<<) + where findPropHeads :: Stored a -> [Stored a] + findPropHeads sobj | Just _ <- sel $ fromStored sobj = [sobj] + | otherwise = findPropHeads =<< previous sobj -- cgit v1.2.3