diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Set.hs | 78 | ||||
| -rw-r--r-- | src/Storage/Merge.hs | 18 | ||||
| -rw-r--r-- | src/Test.hs | 23 | ||||
| -rw-r--r-- | src/Util.hs | 8 |
4 files changed, 127 insertions, 0 deletions
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 |