From 35347e4cfbd9070d1065b1ff9600013d648c5e6e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 7 Dec 2019 22:35:55 +0100 Subject: Mergeable stored list --- src/Main.hs | 3 +- src/Message.hs | 12 ++++- src/Message/Service.hs | 3 +- src/Storage/List.hs | 140 +++++++++++++++++++++++++------------------------ src/Storage/Merge.hs | 26 +++++++++ 5 files changed, 112 insertions(+), 72 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 890cdcd..93517b2 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -206,7 +206,8 @@ cmdSend = void $ do let powner = finalOwner pid :: ComposedIdentity text <- asks ciLine smsg <- liftIO $ updateLocalState st $ \erb -> do - (slist, smsg) <- case find (sameIdentity powner . msgPeer . fromStored) (storedFromSList $ lsMessages $ fromStored erb) of + 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) diff --git a/src/Message.hs b/src/Message.hs index 61d882c..21f398c 100644 --- a/src/Message.hs +++ b/src/Message.hs @@ -12,6 +12,7 @@ import Data.Time.LocalTime import Identity import Storage +import Storage.Merge data DirectMessage = DirectMessage { msgFrom :: ComposedIdentity @@ -29,13 +30,13 @@ data DirectMessageThread = DirectMessageThread instance Storable DirectMessage where store' msg = storeRec $ do mapM_ (storeRef "from") $ idDataF $ msgFrom msg - mapM_ (storeRef "prev") $ msgPrev msg + mapM_ (storeRef "PREV") $ msgPrev msg storeDate "time" $ msgTime msg storeText "text" $ msgText msg load' = loadRec $ DirectMessage <$> loadIdentity "from" - <*> loadRefs "prev" + <*> loadRefs "PREV" <*> loadDate "time" <*> loadText "text" @@ -50,6 +51,13 @@ instance Storable DirectMessageThread where <*> loadRefs "head" <*> 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 + } + emptyDirectThread :: ComposedIdentity -> DirectMessageThread emptyDirectThread peer = DirectMessageThread peer [] [] diff --git a/src/Message/Service.hs b/src/Message/Service.hs index 044b882..1311e24 100644 --- a/src/Message/Service.hs +++ b/src/Message/Service.hs @@ -32,7 +32,8 @@ instance Service DirectMessageService where -> do erb <- gets svcLocal let st = storedStorage erb erb' <- liftIO $ do - slist <- case find (sameIdentity powner . msgPeer . fromStored) (storedFromSList $ lsMessages $ fromStored erb) of + 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 diff --git a/src/Storage/List.hs b/src/Storage/List.hs index e58c339..e112b46 100644 --- a/src/Storage/List.hs +++ b/src/Storage/List.hs @@ -1,121 +1,124 @@ module Storage.List ( StoredList, emptySList, fromSList, storedFromSList, - slistAdd, slistAddS, slistInsert, slistInsertS, slistRemove, slistReplace, slistReplaceS, - mapFromSList, updateOld, + slistAdd, slistAddS, + -- TODO slistInsert, slistInsertS, + slistRemove, slistReplace, slistReplaceS, + -- TODO mapFromSList, updateOld, - StoreUpdate(..), - withStoredListItem, withStoredListItemS, + -- TODO StoreUpdate(..), + -- TODO withStoredListItem, withStoredListItemS, ) where -import Control.Monad import Control.Monad.Reader import Data.List -import Data.Map (Map) -import qualified Data.Map as M import Data.Maybe +import qualified Data.Set as S import Storage import Storage.Internal +import Storage.Merge data List a = ListNil - | ListItem (Maybe Ref) (Maybe Ref) (Maybe (Stored a)) (StoredList a) - deriving (Show) + | ListItem { listPrev :: [StoredList a] + , listItem :: Maybe (Stored a) + , listRemove :: Maybe (Stored (List a)) + } type StoredList a = Stored (List a) instance Storable a => Storable (List a) where store' ListNil = storeZero - store' (ListItem remove after item next) = storeRec $ do - storeMbRawRef "r" remove - storeMbRawRef "a" after - storeMbRef "i" item - storeRef "n" next + store' x@ListItem {} = storeRec $ do + mapM_ (storeRef "PREV") $ listPrev x + mapM_ (storeRef "item") $ listItem x + mapM_ (storeRef "remove") $ listRemove x load' = asks snd >>= \case - ZeroObject -> return ListNil - _ -> - loadRec $ ListItem - <$> loadMbRawRef "r" - <*> loadMbRawRef "a" - <*> loadMbRef "i" - <*> loadRef "n" + ZeroObject -> return ListNil + _ -> loadRec $ ListItem <$> loadRefs "PREV" + <*> loadMbRef "item" + <*> loadMbRef "remove" instance Storable a => ZeroStorable (List a) where fromZero _ = ListNil +instance Storable a => Mergeable (List a) where + mergeSorted xs = ListItem xs Nothing Nothing + emptySList :: Storable a => Storage -> IO (StoredList a) emptySList st = wrappedStore st ListNil -fromSList :: StoredList a -> [a] -fromSList = map fromStored . storedFromSList - -storedFromSList :: StoredList a -> [Stored a] -storedFromSList = fromSList' [] - where fromSList' :: [(Ref, Bool, [Stored a])] -> StoredList a -> [Stored a] - fromSList' _ (Stored _ ListNil) = [] - fromSList' repl (Stored cref (ListItem rref aref x rest)) = - case (rref, aref) of - (Nothing, Nothing) -> let (rx, repl') = findRepl cref x repl - in rx ++ fromSList' repl' rest - (Just r , Nothing) -> fromSList' (addReplace cref r x repl) rest - (Nothing, Just a ) -> fromSList' (addInsert cref a x repl) rest - (Just r , Just a ) -> fromSList' (addReplace cref r x $ addInsert cref a x repl) rest - - addReplace = findAddRepl False - addInsert = findAddRepl True - - findAddRepl :: Bool -> Ref -> Ref -> Maybe (Stored a) -> [(Ref, Bool, [Stored a])] -> [(Ref, Bool, [Stored a])] - findAddRepl keep c t x rs = let (x', rs') = findRepl c x rs - in addRepl keep c t x' rs' - - addRepl :: Bool -> Ref -> Ref -> [Stored a] -> [(Ref, Bool, [Stored a])] -> [(Ref, Bool, [Stored a])] - addRepl keep _ t x [] = [(t, keep, x)] - addRepl keep c t x ((pr, pk, px) : rs) - | pr == c = (t , keep, x ++ px) : rs - | pr == t = (t , pk, px ++ x) : rs - | otherwise = (pr, pk, px) : addRepl keep c t x rs - - findRepl :: Ref -> Maybe (Stored a) -> [(Ref, Bool, [Stored a])] -> ([Stored a], [(Ref, Bool, [Stored a])]) - findRepl _ x [] = (maybeToList x, []) - findRepl c x ((pr, pk, px) : rs) - | pr == c = (if pk then maybe id (:) x px else px, rs) - | otherwise = ((pr, pk, px):) <$> findRepl c x rs +groupsFromSLists :: forall a. Storable a => StoredList a -> [[Stored a]] +groupsFromSLists = helperSelect S.empty . (:[]) + where + helperSelect :: S.Set (StoredList a) -> [StoredList a] -> [[Stored a]] + helperSelect rs xxs | x:xs <- sort $ filterRemoved rs xxs = helper rs x xs + | otherwise = [] + + helper :: S.Set (StoredList a) -> StoredList a -> [StoredList a] -> [[Stored a]] + helper rs x xs + | ListNil <- fromStored x + = [] + + | Just rm <- listRemove (fromStored x) + , ans <- ancestors [x] + , (other, collision) <- partition (S.null . S.intersection ans . ancestors . (:[])) xs + , cont <- helperSelect (rs `S.union` ancestors [rm]) $ concatMap (listPrev . fromStored) (x : collision) ++ other + = case catMaybes $ map (listItem . fromStored) (x : collision) of + [] -> cont + xis -> xis : cont + + | otherwise = case listItem (fromStored x) of + Nothing -> helperSelect rs $ listPrev (fromStored x) ++ xs + Just xi -> [xi] : (helperSelect rs $ listPrev (fromStored x) ++ xs) + + filterRemoved :: S.Set (StoredList a) -> [StoredList a] -> [StoredList a] + filterRemoved rs = filter (S.null . S.intersection rs . ancestors . (:[])) + +fromSList :: Mergeable a => StoredList a -> [a] +fromSList = map merge . groupsFromSLists + +storedFromSList :: Mergeable a => StoredList a -> IO [Stored a] +storedFromSList = mapM storeMerge . groupsFromSLists slistAdd :: Storable a => a -> StoredList a -> IO (StoredList a) -slistAdd x next@(Stored (Ref st _) _) = do +slistAdd x prev@(Stored (Ref st _) _) = do sx <- wrappedStore st x - slistAddS sx next + slistAddS sx prev slistAddS :: Storable a => Stored a -> StoredList a -> IO (StoredList a) -slistAddS sx next@(Stored (Ref st _) _) = wrappedStore st (ListItem Nothing Nothing (Just sx) next) +slistAddS sx prev@(Stored (Ref st _) _) = wrappedStore st (ListItem [prev] (Just sx) Nothing) +{- TODO slistInsert :: Storable a => Stored a -> a -> StoredList a -> IO (StoredList a) -slistInsert after x next@(Stored (Ref st _) _) = do +slistInsert after x prev@(Stored (Ref st _) _) = do sx <- wrappedStore st x - slistInsertS after sx next + slistInsertS after sx prev slistInsertS :: Storable a => Stored a -> Stored a -> StoredList a -> IO (StoredList a) -slistInsertS after sx next@(Stored (Ref st _) _) = wrappedStore st $ ListItem Nothing (findSListRef after next) (Just sx) next +slistInsertS after sx prev@(Stored (Ref st _) _) = wrappedStore st $ ListItem Nothing (findSListRef after prev) (Just sx) prev +-} slistRemove :: Storable a => Stored a -> StoredList a -> IO (StoredList a) -slistRemove rm next@(Stored (Ref st _) _) = wrappedStore st $ ListItem (findSListRef rm next) Nothing Nothing next +slistRemove rm prev@(Stored (Ref st _) _) = wrappedStore st $ ListItem [prev] Nothing (findSListRef rm prev) slistReplace :: Storable a => Stored a -> a -> StoredList a -> IO (StoredList a) -slistReplace rm x next@(Stored (Ref st _) _) = do +slistReplace rm x prev@(Stored (Ref st _) _) = do sx <- wrappedStore st x - slistReplaceS rm sx next + slistReplaceS rm sx prev slistReplaceS :: Storable a => Stored a -> Stored a -> StoredList a -> IO (StoredList a) -slistReplaceS rm sx next@(Stored (Ref st _) _) = wrappedStore st $ ListItem (findSListRef rm next) Nothing (Just sx) next +slistReplaceS rm sx prev@(Stored (Ref st _) _) = wrappedStore st $ ListItem [prev] (Just sx) (findSListRef rm prev) -findSListRef :: Stored a -> StoredList a -> Maybe Ref +findSListRef :: Stored a -> StoredList a -> Maybe (StoredList a) findSListRef _ (Stored _ ListNil) = Nothing -findSListRef x (Stored ref (ListItem _ _ y next)) | y == Just x = Just ref - | otherwise = findSListRef x next +findSListRef x cur | listItem (fromStored cur) == Just x = Just cur + | otherwise = listToMaybe $ catMaybes $ map (findSListRef x) $ listPrev $ fromStored cur +{- TODO mapFromSList :: Storable a => StoredList a -> Map RefDigest (Stored a) mapFromSList list = helper list M.empty where helper :: Storable a => StoredList a -> Map RefDigest (Stored a) -> Map RefDigest (Stored a) @@ -153,3 +156,4 @@ withStoredListItemS p list f = do StoreReplace nx -> slistReplaceS sx nx list StoreRemove -> slistRemove sx list Nothing -> return list +-} diff --git a/src/Storage/Merge.hs b/src/Storage/Merge.hs index ac80c96..74b88d7 100644 --- a/src/Storage/Merge.hs +++ b/src/Storage/Merge.hs @@ -1,7 +1,12 @@ module Storage.Merge ( + Mergeable(..), + merge, storeMerge, + uniq, + generations, ancestors, precedes, + filterAncestors, ) where import qualified Data.ByteString.Char8 as BC @@ -13,6 +18,24 @@ import qualified Data.Set as S import Storage import Storage.Internal +class Storable a => Mergeable a where + mergeSorted :: [Stored a] -> a + +merge :: Mergeable a => [Stored a] -> a +merge [] = error "merge: empty list" +merge [x] = fromStored x +merge xs = mergeSorted $ filterAncestors xs + +storeMerge :: Mergeable a => [Stored a] -> IO (Stored a) +storeMerge [] = error "merge: empty list" +storeMerge [x] = return x +storeMerge xs@(Stored ref _ : _) = wrappedStore (refStorage ref) $ mergeSorted $ filterAncestors xs + +uniq :: Eq a => [a] -> [a] +uniq (x:x':xs) | x == x' = uniq (x:xs) + | otherwise = x : uniq (x':xs) +uniq xs = xs + previous :: Storable a => Stored a -> [Stored a] previous (Stored ref _) = case load ref of Rec items | Just (RecRef dref) <- lookup (BC.pack "SDATA") items @@ -38,3 +61,6 @@ ancestors = last . (S.empty:) . generations precedes :: Storable a => Stored a -> Stored a -> Bool precedes x y = x `S.member` ancestors [y] + +filterAncestors :: Storable a => [Stored a] -> [Stored a] +filterAncestors xs = uniq $ sort $ filter (`S.notMember` ancestors xs) xs -- cgit v1.2.3