Set of mergeable items

5 files changed, 128 insertions, 0 deletions

diff --git a/erebos.cabal b/erebos.cabal
index 43aa81c..9489f20 100644
--- a/erebos.cabal
+++ b/erebos.cabal
@@ -29,6 +29,7 @@ executable erebos
                        Pairing
                        PubKey,
                        Service
+                       Set
                        State,
                        Storage,
                        Storage.Internal
diff --git a/src/Set.hs b/src/Set.hs
new file mode 100644
index 0000000..263103f
--- /dev/null
+++ b/src/Set.hs
@@ -0,0 +1,78 @@
+module Set (
+    Set,
+
+    emptySet,
+    loadSet,
+    storeSetAdd,
+
+    fromSetBy,
+) where
+
+import Control.Arrow
+import Control.Monad.IO.Class
+
+import Data.Function
+import Data.List
+import Data.Map (Map)
+import Data.Map qualified as M
+import Data.Maybe
+import Data.Ord
+
+import Storage
+import Storage.Merge
+import Util
+
+data Set a = Set [Stored (SetItem (Component a))]
+
+data SetItem a = SetItem
+    { siPrev :: [Stored (SetItem a)]
+    , siItem :: [Stored a]
+    }
+
+instance Storable a => Storable (SetItem a) where
+    store' x = storeRec $ do
+        mapM_ (storeRef "PREV") $ siPrev x
+        mapM_ (storeRef "item") $ siItem x
+
+    load' = loadRec $ SetItem
+        <$> loadRefs "PREV"
+        <*> loadRefs "item"
+
+instance Mergeable a => Mergeable (Set a) where
+    type Component (Set a) = SetItem (Component a)
+    mergeSorted = Set
+    toComponents (Set items) = items
+
+
+emptySet :: Set a
+emptySet = Set []
+
+loadSet :: Mergeable a => Ref -> Set a
+loadSet = mergeSorted . (:[]) . wrappedLoad
+
+storeSetAdd :: (Mergeable a, MonadIO m) => Storage -> a -> Set a -> m (Set a)
+storeSetAdd st x (Set prev) = Set . (:[]) <$> wrappedStore st SetItem
+    { siPrev = prev
+    , siItem = toComponents x
+    }
+
+
+fromSetBy :: forall a. Mergeable a => (a -> a -> Ordering) -> Set a -> [a]
+fromSetBy cmp (Set heads) = sortBy cmp $ map merge $ groupRelated items
+  where
+    -- gather all item components in the set history
+    items :: [Stored (Component a)]
+    items = walkAncestors (siItem . fromStored) heads
+
+    -- map individual roots to full root set as joined in history of individual items
+    rootToRootSet :: Map RefDigest [RefDigest]
+    rootToRootSet = foldl' (\m rs -> foldl' (\m' r -> M.insertWith (\a b -> uniq $ sort $ a++b) r rs m') m rs) M.empty $
+        map (map (refDigest . storedRef) . storedRoots) items
+
+    -- get full root set for given item component
+    storedRootSet :: Stored (Component a) -> [RefDigest]
+    storedRootSet = fromJust . flip M.lookup rootToRootSet . refDigest . storedRef . head . storedRoots
+
+    -- group components of single item, i.e. components sharing some root
+    groupRelated :: [Stored (Component a)] -> [[Stored (Component a)]]
+    groupRelated = map (map fst) . groupBy ((==) `on` snd) . sortBy (comparing snd) . map (id &&& storedRootSet)
diff --git a/src/Storage/Merge.hs b/src/Storage/Merge.hs
index cedf56a..82737ef 100644
--- a/src/Storage/Merge.hs
+++ b/src/Storage/Merge.hs
@@ -11,6 +11,7 @@ module Storage.Merge (
     precedes,
     filterAncestors,
     storedRoots,
+    walkAncestors,
 
     findProperty,
 ) where
@@ -36,6 +37,11 @@ class Storable (Component a) => Mergeable a where
     mergeSorted :: [Stored (Component a)] -> a
     toComponents :: a -> [Stored (Component a)]
 
+instance Mergeable [Stored Object] where
+    type Component [Stored Object] = Object
+    mergeSorted = id
+    toComponents = id
+
 merge :: Mergeable a => [Stored (Component a)] -> a
 merge [] = error "merge: empty list"
 merge xs = mergeSorted $ filterAncestors xs
@@ -122,6 +128,18 @@ storedRoots x = do
                     return roots
         map (wrappedLoad . Ref st) <$> doLookup x
 
+walkAncestors :: (Storable a, Monoid m) => (Stored a -> m) -> [Stored a] -> m
+walkAncestors f = helper . sortBy cmp
+  where
+    helper (x : y : xs) | x == y = helper (x : xs)
+    helper (x : xs) = f x <> helper (mergeBy cmp (sortBy cmp (previous x)) xs)
+    helper [] = mempty
+
+    cmp x y = case compareGeneration (storedGeneration x) (storedGeneration y) of
+                   Just LT -> GT
+                   Just GT -> LT
+                   _ -> compare x y
+
 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]
diff --git a/src/Test.hs b/src/Test.hs
index df36556..9c5319b 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -30,6 +30,7 @@ import Network
 import Pairing
 import PubKey
 import Service
+import Set
 import State
 import Storage
 import Storage.Internal (unsafeStoreRawBytes)
@@ -179,6 +180,8 @@ commands :: [(Text, Command)]
 commands = map (T.pack *** id)
     [ ("store", cmdStore)
     , ("stored-roots", cmdStoredRoots)
+    , ("stored-set-add", cmdStoredSetAdd)
+    , ("stored-set-list", cmdStoredSetList)
     , ("create-identity", cmdCreateIdentity)
     , ("start-server", cmdStartServer)
     , ("watch-local-identity", cmdWatchLocalIdentity)
@@ -207,6 +210,26 @@ cmdStoredRoots = do
     Just ref <- liftIO $ readRef st (encodeUtf8 tref)
     cmdOut $ "stored-roots" ++ concatMap ((' ':) . show . refDigest . storedRef) (storedRoots $ wrappedLoad @Object ref)
 
+cmdStoredSetAdd :: Command
+cmdStoredSetAdd = do
+    st <- asks tiStorage
+    (item, set) <- asks tiParams >>= liftIO . mapM (readRef st . encodeUtf8) >>= \case
+        [Just iref, Just sref] -> return (wrappedLoad iref, loadSet @[Stored Object] sref)
+        [Just iref] -> return (wrappedLoad iref, emptySet)
+        _ -> fail "unexpected parameters"
+    set' <- storeSetAdd st [item] set
+    cmdOut $ "stored-set-add" ++ concatMap ((' ':) . show . refDigest . storedRef) (toComponents set')
+
+cmdStoredSetList :: Command
+cmdStoredSetList = do
+    st <- asks tiStorage
+    [tref] <- asks tiParams
+    Just ref <- liftIO $ readRef st (encodeUtf8 tref)
+    let items = fromSetBy compare $ loadSet @[Stored Object] ref
+    forM_ items $ \item -> do
+        cmdOut $ "stored-set-item" ++ concatMap ((' ':) . show . refDigest . storedRef) item
+    cmdOut $ "stored-set-done"
+
 cmdCreateIdentity :: Command
 cmdCreateIdentity = do
     st <- asks tiStorage
diff --git a/src/Util.hs b/src/Util.hs
index 99d51f6..fe802e2 100644
--- a/src/Util.hs
+++ b/src/Util.hs
@@ -4,3 +4,11 @@ uniq :: Eq a => [a] -> [a]
 uniq (x:y:xs) | x == y    = uniq (x:xs)
               | otherwise = x : uniq (y:xs)
 uniq xs = xs
+
+mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
+mergeBy cmp (x : xs) (y : ys) = case cmp x y of
+                                     LT -> x : mergeBy cmp xs (y : ys)
+                                     EQ -> x : y : mergeBy cmp xs ys
+                                     GT -> y : mergeBy cmp (x : xs) ys
+mergeBy _ xs [] = xs
+mergeBy _ [] ys = ys