summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Main.hs3
-rw-r--r--src/Message.hs12
-rw-r--r--src/Message/Service.hs3
-rw-r--r--src/Storage/List.hs140
-rw-r--r--src/Storage/Merge.hs26
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
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-31 02:09:08 +0000