diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,11 @@ +language: haskell + +addons: + apt: + packages: + - libleveldb-dev + - liblmdb-dev + +ghc: + - 8.2 + - 8.4 diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +0.5.0 Enzo Haussecker Fri Oct 19 2018 + + * Implement Merkle proofs. + 0.4.0 Enzo Haussecker Tue Sep 25 2018 * Change hash function from SHA-256 to BLAKE-256. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -27,7 +27,7 @@ import Control.Monad.IO.Class (MonadIO) import Database.LevelDB (DB, defaultReadOptions, defaultWriteOptions, get, put) -import Network.DFINITY.RadixTree +import DFINITY.RadixTree instance MonadIO m => RadixDatabase m DB where load database = get database defaultReadOptions @@ -42,7 +42,7 @@ import Control.Monad.Trans.Resource (MonadResource) import Database.LevelDB (DB, Options(..), defaultOptions, open) -import Network.DFINITY.RadixTree +import DFINITY.RadixTree type RadixTree' = RadixTree DB @@ -73,7 +73,7 @@ import Data.ByteString.Char8 (unpack) import Data.ByteString.Short (fromShort) -import Network.DFINITY.RadixTree +import DFINITY.RadixTree main :: IO () main = runResourceT $ do @@ -134,11 +134,11 @@ [hackage-lmdb-simple]: https://hackage.haskell.org/package/lmdb-simple [`RadixDatabase`]: - https://hackage.haskell.org/package/dfinity-radix-tree/docs/Network-DFINITY-RadixTree.html#t:RadixDatabase + https://hackage.haskell.org/package/dfinity-radix-tree/docs/DFINITY-RadixTree.html#t:RadixDatabase [`RadixTree`]: - https://hackage.haskell.org/package/dfinity-radix-tree/docs/Network-DFINITY-RadixTree.html#t:RadixTree + https://hackage.haskell.org/package/dfinity-radix-tree/docs/DFINITY-RadixTree.html#t:RadixTree [`RadixRoot`]: - https://hackage.haskell.org/package/dfinity-radix-tree/docs/Network-DFINITY-RadixTree.html#t:RadixRoot + https://hackage.haskell.org/package/dfinity-radix-tree/docs/DFINITY-RadixTree.html#t:RadixRoot [issue-tracker]: https://github.com/dfinity-lab/hs-radix-tree/issues diff --git a/benchmark/Main.hs b/benchmark/Main.hs --- a/benchmark/Main.hs +++ b/benchmark/Main.hs @@ -28,7 +28,7 @@ import qualified Database.LevelDB as LevelDB import qualified Database.LMDB.Simple as LMDB -import Network.DFINITY.RadixTree +import DFINITY.RadixTree -------------------------------------------------------------------------------- diff --git a/benchmark/dfinity-radix-tree-benchmarks-leveldb.svg b/benchmark/dfinity-radix-tree-benchmarks-leveldb.svg --- a/benchmark/dfinity-radix-tree-benchmarks-leveldb.svg +++ b/benchmark/dfinity-radix-tree-benchmarks-leveldb.svg @@ -116,7 +116,7 @@ -dfinity-radix-tree-0.3.1-Ch2JdNQi35N1NDZGT2tyvZ:Network.DFINITY.RadixTree.Types.RadixNode +dfinity-radix-tree-0.3.1-Ch2JdNQi35N1NDZGT2tyvZ:DFINITY.RadixTree.Types.RadixNode @@ -160,7 +160,7 @@ -dfinity-radix-tree-0.3.1-Ch2JdNQi35N1NDZGT2tyvZ:Network.DFINITY.RadixTree.Types.RadixPrefix +dfinity-radix-tree-0.3.1-Ch2JdNQi35N1NDZGT2tyvZ:DFINITY.RadixTree.Types.RadixPrefix diff --git a/benchmark/dfinity-radix-tree-benchmarks-lmdb.svg b/benchmark/dfinity-radix-tree-benchmarks-lmdb.svg --- a/benchmark/dfinity-radix-tree-benchmarks-lmdb.svg +++ b/benchmark/dfinity-radix-tree-benchmarks-lmdb.svg @@ -110,7 +110,7 @@ -dfinity-radix-tree-0.3.1-Ch2JdNQi35N1NDZGT2tyvZ:Network.DFINITY.RadixTree.Types.RadixNode +dfinity-radix-tree-0.3.1-Ch2JdNQi35N1NDZGT2tyvZ:DFINITY.RadixTree.Types.RadixNode @@ -154,7 +154,7 @@ -dfinity-radix-tree-0.3.1-Ch2JdNQi35N1NDZGT2tyvZ:Network.DFINITY.RadixTree.Types.RadixPrefix +dfinity-radix-tree-0.3.1-Ch2JdNQi35N1NDZGT2tyvZ:DFINITY.RadixTree.Types.RadixPrefix diff --git a/dfinity-radix-tree.cabal b/dfinity-radix-tree.cabal --- a/dfinity-radix-tree.cabal +++ b/dfinity-radix-tree.cabal @@ -1,5 +1,5 @@ Name: dfinity-radix-tree -Version: 0.4.0 +Version: 0.5.0 Synopsis: A generic data integrity layer. Description: This library allows you to construct a Merkle tree on top of any underlying @@ -11,14 +11,14 @@ License-File: LICENSE Category: Blockchain, DFINITY, Database Copyright: 2018 DFINITY Stiftung -Author: Enzo Haussecker -Maintainer: DFINITY USA Research -Homepage: https://github.com/dfinity-lab/hs-dfinity-radix-tree -Bug-Reports: https://github.com/dfinity-lab/hs-dfinity-radix-tree/issues +Author: Enzo Haussecker , Remy Goldschmidt , Armando Ramirez +Maintainer: Enzo Haussecker , Remy Goldschmidt , Armando Ramirez +Homepage: https://github.com/dfinity-lab/dev +Bug-Reports: https://github.com/dfinity-lab/dev/issues Tested-With: GHC==8.4.3, GHC==8.2.2 Build-Type: Simple Cabal-Version: >= 1.10 -Extra-Source-Files: CHANGELOG.md README.md +Extra-Source-Files: CHANGELOG.md, README.md Library Build-Depends: @@ -33,20 +33,27 @@ containers, data-default-class, deepseq, + directory, + dlist, ghc-prim, + hashtables, lens-simple, leveldb-haskell, lmdb-simple, lrucaching, mtl, + reducers, resourcet, semigroups, - serialise + serialise, + stm, + temporary, + transformers Default-Language: Haskell2010 Exposed-Modules: - Network.DFINITY.RadixTree - Network.DFINITY.RadixTree.Conduit + DFINITY.RadixTree + DFINITY.RadixTree.Conduit GHC-Options: -O2 -Wall @@ -54,14 +61,14 @@ HS-Source-Dirs: src Other-Modules: - Network.DFINITY.RadixTree.Bits - Network.DFINITY.RadixTree.Bloom - Network.DFINITY.RadixTree.Lenses - Network.DFINITY.RadixTree.Lock - Network.DFINITY.RadixTree.Memory - Network.DFINITY.RadixTree.Serialise - Network.DFINITY.RadixTree.Types - Network.DFINITY.RadixTree.Utilities + DFINITY.RadixTree.Bits + DFINITY.RadixTree.Bloom + DFINITY.RadixTree.Lenses + DFINITY.RadixTree.Lock + DFINITY.RadixTree.Memory + DFINITY.RadixTree.Serialise + DFINITY.RadixTree.Types + DFINITY.RadixTree.Utilities Executable dfinity-radix-tree-benchmarks Build-Depends: @@ -74,8 +81,8 @@ dfinity-radix-tree, leveldb-haskell, lmdb-simple, - temporary, - resourcet + resourcet, + temporary Default-Language: Haskell2010 GHC-Options: @@ -89,21 +96,29 @@ Main.hs test-suite tests - type: exitcode-stdio-1.0 Build-Depends: - base >=4.10 && <5, - dfinity-radix-tree, - bytestring, + BoundedChan, QuickCheck, - mtl, - containers, aeson, + base >=4.10 && <5, base16-bytestring, - text, - unordered-containers, + blake2, + bytestring, + concurrent-extra, + conduit, + containers, + dfinity-radix-tree, + filepath, + leveldb-haskell, + mtl, + resourcet, tasty, tasty-hunit, - tasty-quickcheck + tasty-quickcheck, + text, + temporary, + transformers, + unordered-containers Default-Language: Haskell2010 GHC-Options: @@ -111,8 +126,12 @@ -Wall HS-Source-Dirs: test - Other-Modules: - UnitTests, - Properties Main-Is: - tests.hs + Tests.hs + Other-Modules: + Integrations, + Properties, + Types, + Units + Type: + exitcode-stdio-1.0 diff --git a/src/DFINITY/RadixTree.hs b/src/DFINITY/RadixTree.hs new file mode 100644 --- /dev/null +++ b/src/DFINITY/RadixTree.hs @@ -0,0 +1,902 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS -Wall #-} +{-# OPTIONS -Werror #-} +{-# OPTIONS -fno-warn-unused-top-binds #-} + +-- | +-- Module : DFINITY.RadixTree +-- Copyright : 2018 DFINITY Stiftung +-- License : GPL-3 +-- Maintainer : Enzo Haussecker +-- Stability : Stable +-- +-- A generic data integrity layer. +module DFINITY.RadixTree ( + + -- ** Class + RadixDatabase(..) + + -- ** Types + , RadixError(..) + , RadixProof(_radixValue) + , RadixRoot + , RadixTree + + -- ** Create + , createRadixTree + + -- ** Insert + , insertRadixTree + + -- ** Delete + , deleteRadixTree + + -- ** Merkleize + , merkleizeRadixTree + + -- ** Query + , lookupRadixTree + + -- ** Prove + , createRadixProof + , verifyRadixProof + + -- ** Test + , isEmptyRadixTree + , isValidRadixRoot + + -- ** Debug + , contentsRadixTree + , contentsMerkleizedRadixTree + , contentsNonMerkleizedRadixTree + + -- ** Print + , printRadixTree + , printMerkleizedRadixTree + , printNonMerkleizedRadixTree + + ) where + +import Control.Applicative ((<|>)) +import Control.Exception (throw) +import Control.Monad (foldM, forM_, mfilter) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Trans.Resource (ResourceT) +import Data.Bool (bool) +import Data.ByteString (ByteString) +import Data.ByteString.Short (fromShort) +import Data.Default.Class (def) +import Data.Functor(($>)) +import Data.Functor.Reverse (Reverse(..)) +import Data.Semigroup.Applicative (Ap(..)) +import Data.List.NonEmpty (NonEmpty(..), fromList) +import Data.Maybe (fromJust, isJust, isNothing, listToMaybe) +import Data.Tuple (swap) + +import qualified Data.BloomFilter as Bloom +import qualified Data.DList as DList +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.LruCache as LRU +import qualified Data.Map.Strict as Map +import qualified Database.LevelDB as LevelDB + +import DFINITY.RadixTree.Bits +import DFINITY.RadixTree.Bloom +import DFINITY.RadixTree.Lenses +import DFINITY.RadixTree.Memory +import DFINITY.RadixTree.Types +import DFINITY.RadixTree.Utilities + +-------------------------------------------------------------------------------- + +-- | +-- Create a radix tree. +createRadixTree + :: RadixDatabase m database + => Int -- ^ Bloom filter size in bits. + -> Int -- ^ LRU cache size in items. + -> Maybe RadixRoot -- ^ Previous state root. + -> database -- ^ Database. + -> m (RadixTree database) +createRadixTree bloomSize cacheSize checkpoint database + | bloomSize <= 0 = throw $ InvalidArgument "invalid Bloom filter size" + | cacheSize <= 0 = throw $ InvalidArgument "invalid LRU cache size" + | otherwise = do + (root, cache') <- + case checkpoint of + Nothing -> storeCold def cache database + Just root -> do + result <- loadCold root cache database + case snd <$> result of + Nothing -> throw $ StateRootDoesNotExist root + Just cache' -> pure (root, cache') + pure $ RadixTree bloom bloomSize Map.empty cache' cacheSize root database 0 root + where + bloom = emptyRadixBloom bloomSize + cache = LRU.empty cacheSize + +{-# SPECIALISE createRadixTree + :: Int + -> Int + -> Maybe RadixRoot + -> LevelDB.DB + -> ResourceT IO (RadixTree LevelDB.DB) #-} + +-------------------------------------------------------------------------------- + +-- | +-- Check if a radix tree is empty. +isEmptyRadixTree + :: RadixTree database -- ^ Radix tree. + -> Bool +isEmptyRadixTree tree = _radixRoot tree == defaultRoot + +{-# INLINABLE isEmptyRadixTree #-} + +-------------------------------------------------------------------------------- + +-- | +-- Check if a state root is valid. +isValidRadixRoot + :: RadixDatabase m database + => RadixRoot -- ^ State root. + -> RadixTree database -- ^ Radix tree. + -> m Bool +isValidRadixRoot root RadixTree {..} = + isJust <$> load _radixDatabase key + where + key = fromShort root + +{-# SPECIALISE isValidRadixRoot + :: RadixRoot + -> RadixTree LevelDB.DB + -> ResourceT IO Bool #-} + +-------------------------------------------------------------------------------- + +-- | +-- Search for a value in a radix tree. +searchRadixTree + :: RadixDatabase m database + => Bool -- ^ Overwrite state root? + -> (RadixTree database -> m (Maybe (RadixNode, RadixCache))) -- ^ Loading strategy. + -> ByteString -- ^ Key. + -> RadixTree database -- ^ Radix tree. + -> m (Either RadixError RadixSearchResult) +searchRadixTree flag strategy = \ key tree@RadixTree {..} -> do + let key' = toBits key + let tree' = tree `bool` setRoot _radixCheckpoint tree $ flag + loop Nothing [] [] [] key' tree' where + loop implicit roots nodes prefixes key tree@RadixTree {..} = do + -- Load the root node. + result <- strategy tree + case result of + Nothing -> pure $ Left $ StateRootDoesNotExist _radixRoot + Just (node@RadixNode {..}, cache') -> do + -- Calculate the prefix and overflow. + let bits = maybe id (:) implicit $ maybe [] toBits _radixPrefix + let prefix = matchBits bits key + let n = length prefix + let overflow = drop n bits + -- Update the accumulators. + let roots' = _radixRoot:roots + let nodes' = node:nodes + let prefixes' = prefix:prefixes + let key' = drop n key + -- Check the termination criteria. + let residue = not $ null overflow + let bit = head key' + let child = bool _radixLeft _radixRight bit + if null key' || residue || isNothing child + then pure $ Right (fromList roots', fromList nodes', fromList prefixes', overflow, key', cache') + else do + -- Recurse. + let root' = fromJust child + let tree' = setCache cache' $ setRoot root' tree + let implicit' = Just bit + loop implicit' roots' nodes' prefixes' key' tree' + +{-# SPECIALISE searchRadixTree + :: Bool + -> (RadixTree LevelDB.DB + -> ResourceT IO (Maybe (RadixNode, RadixCache))) + -> ByteString + -> RadixTree LevelDB.DB + -> ResourceT IO (Either RadixError RadixSearchResult) #-} + +-------------------------------------------------------------------------------- + +-- | +-- Search for a value in a Merkleized radix tree. +searchMerkleizedRadixTree + :: RadixDatabase m database + => ByteString -- ^ Key. + -> RadixTree database -- ^ Radix tree. + -> m (Either RadixError RadixSearchResult) +searchMerkleizedRadixTree = + searchRadixTree True $ \ RadixTree {..} -> + loadCold _radixRoot _radixCache _radixDatabase + +{-# SPECIALISE searchMerkleizedRadixTree + :: ByteString + -> RadixTree LevelDB.DB + -> ResourceT IO (Either RadixError RadixSearchResult) #-} + +-------------------------------------------------------------------------------- + +-- | +-- Search for a value in a non-Merkleized radix tree. +searchNonMerkleizedRadixTree + :: RadixDatabase m database + => ByteString -- ^ Key. + -> RadixTree database -- ^ Radix tree. + -> m (Either RadixError RadixSearchResult) +searchNonMerkleizedRadixTree = + searchRadixTree False $ \ RadixTree {..} -> + loadHot _radixRoot _radixBuffer _radixCache _radixDatabase + +{-# SPECIALISE searchNonMerkleizedRadixTree + :: ByteString + -> RadixTree LevelDB.DB + -> ResourceT IO (Either RadixError RadixSearchResult) #-} + +-------------------------------------------------------------------------------- + +-- | +-- Insert a value into a radix tree. +insertRadixTree + :: RadixDatabase m database + => ByteString -- ^ Key. + -> ByteString -- ^ Value. + -> RadixTree database -- ^ Radix tree. + -> m (RadixTree database) +insertRadixTree key value tree = + if isEmptyRadixTree tree + then pure $ initializeRadixTree key value tree + else searchNonMerkleizedRadixTree key tree >>= \ case + Left err -> throw err + Right result@(_, _, _, [], [], _) -> + pure $ insertRadixTreeAt result value tree + Right result@(_, _, _, [], _, _) -> + pure $ insertRadixTreeAfter result value tree + Right result@(_, _, _, _, [], _) -> + pure $ insertRadixTreeBefore result value tree + Right result -> + pure $ insertRadixTreeBetween result value tree + +{-# SPECIALISE insertRadixTree + :: ByteString + -> ByteString + -> RadixTree LevelDB.DB + -> ResourceT IO (RadixTree LevelDB.DB) #-} + +-------------------------------------------------------------------------------- + +-- TODO (enzo): Documentation. +initializeRadixTree + :: ByteString -- ^ Key. + -> ByteString -- ^ Value. + -> RadixTree database -- ^ Radix tree. + -> RadixTree database +initializeRadixTree key value tree@RadixTree {..} = + seq bloom $ setBloom bloom $ setBuffer buffer $ setNonce nonce $ setRoot root tree + where + prefix = createPrefix $ toBits key + node = setPrefix prefix $ Just value `setLeaf` def + root = createRootFromNonce _radixNonce + bloom = Bloom.insert root _radixBloom + nonce = _radixNonce + 1 + buffer = storeHot root node _radixBuffer + +{-# INLINABLE initializeRadixTree #-} + +-------------------------------------------------------------------------------- + +-- TODO (enzo): Documentation. +insertRadixTreeAt + :: RadixSearchResult -- ^ Search result. + -> ByteString -- ^ Value. + -> RadixTree database -- ^ Radix tree. + -> RadixTree database +insertRadixTreeAt (_:|roots, node:|nodes, prefix:|_, _, _, cache) value tree@RadixTree {..} = + seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setNonce nonce $ setRoot state tree + where + node' = Just value `setLeaf` node + root' = createRootFromNonce _radixNonce + parent = listToMaybe $ zip3 roots nodes prefix + bloom = flip Bloom.insertList _radixBloom $ root':roots + buffer = merkleSpoof root' parent $ storeHot root' node' _radixBuffer + nonce = _radixNonce + 1 + state = bool _radixRoot root' $ isNothing parent + +{-# INLINABLE insertRadixTreeAt #-} + +-------------------------------------------------------------------------------- + +-- TODO (enzo): Documentation. +insertRadixTreeAfter + :: RadixSearchResult -- ^ Search result. + -> ByteString -- ^ Value. + -> RadixTree database -- ^ Radix tree. + -> RadixTree database +insertRadixTreeAfter (_:|roots, node:|nodes, prefix:|_, _, keyOverflow, cache) value tree@RadixTree {..} = + seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setNonce nonce $ setRoot state tree + where + prefix' = createPrefix $ drop 1 keyOverflow + node' = setPrefix prefix' $ Just value `setLeaf` def + root' = createRootFromNonce _radixNonce + node'' = test `setChild` Just root' $ node + root'' = createRootFromNonce $ _radixNonce + 1 + test = head keyOverflow + parent = listToMaybe $ zip3 roots nodes prefix + bloom = flip Bloom.insertList _radixBloom $ root'':root':roots + buffer = merkleSpoof root'' parent $ storeHot root'' node'' $ storeHot root' node' _radixBuffer + nonce = _radixNonce + 2 + state = bool _radixRoot root'' $ isNothing parent + +{-# INLINABLE insertRadixTreeAfter #-} + +-------------------------------------------------------------------------------- + +-- TODO (enzo): Documentation. +insertRadixTreeBefore + :: RadixSearchResult -- ^ Search result. + -> ByteString -- ^ Value. + -> RadixTree database -- ^ Radix tree. + -> RadixTree database +insertRadixTreeBefore (_:|roots, node:|nodes, prefix:|_, prefixOverflow, _, cache) value tree@RadixTree {..} = + seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setNonce nonce $ setRoot state tree + where + prefix' = createPrefix $ drop 1 prefixOverflow + node' = setPrefix prefix' node + root' = createRootFromNonce _radixNonce + prefix'' = createPrefix $ drop 1 prefix `bool` prefix $ isNothing parent + node'' = setPrefix prefix'' $ test `setChild` Just root' $ Just value `setLeaf` def + root'' = createRootFromNonce $ _radixNonce + 1 + test = head prefixOverflow + parent = listToMaybe $ zip3 roots nodes prefix + bloom = flip Bloom.insertList _radixBloom $ root'':root':roots + buffer = merkleSpoof root'' parent $ storeHot root'' node'' $ storeHot root' node' _radixBuffer + nonce = _radixNonce + 2 + state = bool _radixRoot root'' $ isNothing parent + +{-# INLINABLE insertRadixTreeBefore #-} + +-------------------------------------------------------------------------------- + +-- TODO (enzo): Documentation. +insertRadixTreeBetween + :: RadixSearchResult -- ^ Search result. + -> ByteString -- ^ Value. + -> RadixTree database -- ^ Radix tree. + -> RadixTree database +insertRadixTreeBetween (_:|roots, node:|nodes, prefix:|_, prefixOverflow, keyOverflow, cache) value tree@RadixTree {..} = + seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setNonce nonce $ setRoot state tree + where + prefix' = createPrefix $ drop 1 keyOverflow + node' = setPrefix prefix' $ Just value `setLeaf` def + root' = createRootFromNonce _radixNonce + prefix'' = createPrefix $ drop 1 prefixOverflow + node'' = setPrefix prefix'' node + root'' = createRootFromNonce $ _radixNonce + 1 + prefix''' = createPrefix $ drop 1 prefix `bool` prefix $ isNothing parent + node''' = setPrefix prefix''' $ setChildren children def + root''' = createRootFromNonce $ _radixNonce + 2 + test = head keyOverflow + children = bool id swap test (Just root', Just root'') + parent = listToMaybe $ zip3 roots nodes prefix + bloom = flip Bloom.insertList _radixBloom $ root''':root'':root':roots + buffer = merkleSpoof root''' parent $ storeHot root''' node''' $ storeHot root'' node'' $ storeHot root' node' _radixBuffer + nonce = _radixNonce + 3 + state = bool _radixRoot root''' $ isNothing parent + +{-# INLINABLE insertRadixTreeBetween #-} + +-------------------------------------------------------------------------------- + +-- | +-- Delete a value from a radix tree. +deleteRadixTree + :: RadixDatabase m database + => ByteString -- ^ Key. + -> RadixTree database -- ^ Radix tree. + -> m (RadixTree database) +deleteRadixTree key tree@RadixTree {..} = + if isEmptyRadixTree tree + then pure tree + else searchNonMerkleizedRadixTree key tree >>= \ case + Left err -> throw err + Right result@(_, nodes, prefix:|_, [], [], cache) -> + case nodes of + -- No children and no parent. + RadixNode _ Nothing Nothing _:|[] -> + pure $ deleteRadixTreeNoChildrenNoParent result tree + -- No children and parent with leaf. + RadixNode _ Nothing Nothing _:|parent:_ | isJust $ getLeaf parent -> + pure $ deleteRadixTreeNoChildrenParentWithLeaf result tree + -- No children and parent without leaf. + RadixNode _ Nothing Nothing _:|parent:_ -> do + let test = not $ head prefix + let root = fromJust $ getChild test parent + loadHot root _radixBuffer cache _radixDatabase >>= \ case + Nothing -> throw $ StateRootDoesNotExist root + Just (node, cache') -> + pure $ deleteRadixTreeNoChildrenParentWithoutLeaf result node cache' test tree + -- One left child. + RadixNode _ child Nothing _:|_ | isJust child -> do + let test = False + let root = fromJust child + loadHot root _radixBuffer cache _radixDatabase >>= \ case + Nothing -> throw $ StateRootDoesNotExist root + Just (node, cache') -> + pure $ deleteRadixTreeOneChild result node cache' test tree + -- One right child. + RadixNode _ Nothing child _:|_ | isJust child -> do + let test = True + let root = fromJust child + loadHot root _radixBuffer cache _radixDatabase >>= \ case + Nothing -> throw $ StateRootDoesNotExist root + Just (node, cache') -> + pure $ deleteRadixTreeOneChild result node cache' test tree + -- Two children. + _ -> pure $ deleteRadixTreeTwoChildren result tree + Right _ -> pure tree + +{-# SPECIALISE deleteRadixTree + :: ByteString + -> RadixTree LevelDB.DB + -> ResourceT IO (RadixTree LevelDB.DB) #-} + +-------------------------------------------------------------------------------- + +-- TODO (enzo): Documentation. +deleteRadixTreeNoChildrenNoParent + :: RadixSearchResult -- ^ Search result. + -> RadixTree database -- ^ Radix tree. + -> RadixTree database +deleteRadixTreeNoChildrenNoParent (_, _, _, _, _, cache) tree@RadixTree {..} = + seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setRoot state tree + where + bloom = Bloom.insert defaultRoot _radixBloom + buffer = storeHot defaultRoot def _radixBuffer + state = defaultRoot + +{-# INLINABLE deleteRadixTreeNoChildrenNoParent #-} + +-------------------------------------------------------------------------------- + +-- TODO (enzo): Documentation. +deleteRadixTreeNoChildrenParentWithLeaf + :: RadixSearchResult -- ^ Search result. + -> RadixTree database -- ^ Radix tree. + -> RadixTree database +deleteRadixTreeNoChildrenParentWithLeaf (_:|_:roots, _:|node:nodes, prefix:|prefixes, _, _, cache) tree@RadixTree {..} = + seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setNonce nonce $ setRoot state tree + where + node' = setChild test Nothing node + root' = createRootFromNonce _radixNonce + test = head prefix + parent = listToMaybe $ zip3 roots nodes $ map head prefixes + bloom = flip Bloom.insertList _radixBloom $ root':roots + buffer = merkleSpoof root' parent $ storeHot root' node' _radixBuffer + nonce = _radixNonce + 1 + state = bool _radixRoot root' $ isNothing parent +deleteRadixTreeNoChildrenParentWithLeaf _ _ = + throw $ InvalidArgument "unknown parent" + +{-# INLINABLE deleteRadixTreeNoChildrenParentWithLeaf #-} + +-------------------------------------------------------------------------------- + +-- TODO (enzo): Documentation. +deleteRadixTreeNoChildrenParentWithoutLeaf + :: RadixSearchResult -- ^ Search result. + -> RadixNode -- ^ Radix node. + -> RadixCache -- ^ Radix cache. + -> Bool -- ^ Lineage. + -> RadixTree database -- ^ Radix tree. + -> RadixTree database +deleteRadixTreeNoChildrenParentWithoutLeaf (_:|_:roots, _:|_:nodes, _:|prefixes, _, _, _) node@RadixNode {..} cache test tree@RadixTree {..} = + seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setNonce nonce $ setRoot state tree + where + prefix' = createPrefix $ drop 1 bits `bool` bits $ isNothing parent + node' = setPrefix prefix' node + root' = createRootFromNonce _radixNonce + bits = head prefixes ++ test:maybe [] toBits _radixPrefix + parent = listToMaybe $ zip3 roots nodes $ map head prefixes + bloom = flip Bloom.insertList _radixBloom $ root':roots + buffer = merkleSpoof root' parent $ storeHot root' node' _radixBuffer + nonce = _radixNonce + 1 + state = bool _radixRoot root' $ isNothing parent +deleteRadixTreeNoChildrenParentWithoutLeaf _ _ _ _ _ = + throw $ InvalidArgument "unknown parent" + +{-# INLINABLE deleteRadixTreeNoChildrenParentWithoutLeaf #-} + +-------------------------------------------------------------------------------- + +-- TODO (enzo): Documentation. +deleteRadixTreeOneChild + :: RadixSearchResult -- ^ Search result. + -> RadixNode -- ^ Radix node. + -> RadixCache -- ^ Radix cache. + -> Bool -- ^ Lineage. + -> RadixTree database -- ^ Radix tree. + -> RadixTree database +deleteRadixTreeOneChild (_:|roots, _:|nodes, prefix:|_, _, _, _) node@RadixNode {..} cache test tree@RadixTree {..} = + seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setNonce nonce $ setRoot state tree + where + prefix' = createPrefix $ drop 1 bits `bool` bits $ isNothing parent + node' = setPrefix prefix' node + root' = createRootFromNonce _radixNonce + bits = prefix ++ test:maybe [] toBits _radixPrefix + parent = listToMaybe $ zip3 roots nodes prefix + bloom = flip Bloom.insertList _radixBloom $ root':roots + buffer = merkleSpoof root' parent $ storeHot root' node' _radixBuffer + nonce = _radixNonce + 1 + state = bool _radixRoot root' $ isNothing parent + +{-# INLINABLE deleteRadixTreeOneChild #-} + +-------------------------------------------------------------------------------- + +-- TODO (enzo): Documentation. +deleteRadixTreeTwoChildren + :: RadixSearchResult -- ^ Search result. + -> RadixTree database -- ^ Radix tree. + -> RadixTree database +deleteRadixTreeTwoChildren (_:|roots, node:|nodes, prefix:|_, _, _, cache) tree@RadixTree {..} = + seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setNonce nonce $ setRoot state tree + where + node' = setLeaf Nothing node + root' = createRootFromNonce _radixNonce + parent = listToMaybe $ zip3 roots nodes prefix + bloom = flip Bloom.insertList _radixBloom $ root':roots + buffer = merkleSpoof root' parent $ storeHot root' node' _radixBuffer + nonce = _radixNonce + 1 + state = bool _radixRoot root' $ isNothing parent + +{-# INLINABLE deleteRadixTreeTwoChildren #-} + +-------------------------------------------------------------------------------- + +-- | +-- Lookup a value in a radix tree. +lookupRadixTree + :: RadixDatabase m database + => ByteString -- ^ Key. + -> RadixTree database -- ^ Radix tree. + -> m (Maybe (ByteString, RadixTree database)) +lookupRadixTree key tree = do + found <- searchNonMerkleizedRadixTree key tree + case found of + Left err -> throw err + Right (_, RadixNode {..}:|_, _, prefixOverflow, keyOverflow, cache') -> + if not $ null prefixOverflow && null keyOverflow + then pure Nothing + else pure $ do + value <- _radixLeaf + let tree' = setCache cache' tree + pure (value, tree') + +{-# SPECIALISE lookupRadixTree + :: ByteString + -> RadixTree LevelDB.DB + -> ResourceT IO (Maybe (ByteString, RadixTree LevelDB.DB)) #-} + +-------------------------------------------------------------------------------- + +-- | +-- Prove that a value exists in a radix tree. +createRadixProof + :: RadixDatabase m database + => ByteString -- ^ Key. + -> RadixTree database -- ^ Radix tree. + -> m (Maybe (RadixProof, RadixTree database)) +createRadixProof key tree = do + found <- searchNonMerkleizedRadixTree key tree + case found of + Left err -> throw err + Right (_, path, _, prefixOverflow, keyOverflow, cache') -> + if not $ null prefixOverflow && null keyOverflow + then pure Nothing + else pure $ do + value <- _radixLeaf $ NonEmpty.head path + let tree' = setCache cache' tree + let leaf' = setLeaf Nothing $ NonEmpty.head path + let path' = leaf' :| NonEmpty.tail path + let proof = RadixProof path' value + pure (proof, tree') + +{-# SPECIALISE createRadixProof + :: ByteString + -> RadixTree LevelDB.DB + -> ResourceT IO (Maybe (RadixProof, RadixTree LevelDB.DB)) #-} + +-------------------------------------------------------------------------------- + +-- | +-- Verify that a value exists in a radix tree. +verifyRadixProof + :: ByteString -- ^ Key. + -> RadixRoot -- ^ State root. + -> RadixProof -- ^ Radix proof. + -> Bool +verifyRadixProof key rootHash (includeValue -> RadixProof{..}) = + validateKey && validateHashes + where + -- Validate the proof is for the value at the given key & + -- validate that the hashes are correct (both state root matches + -- and that child hashes are found in their parents) + (validateKey, validateHashes) = maybe (False, False) id $ do + keyBits <- recoverKey + let root = NonEmpty.last _radixPath + pure $ (keyBits == toBits key, hashNode root == rootHash) + + recoverKey = do + let childParents = + zip (NonEmpty.toList _radixPath) (NonEmpty.tail _radixPath) + leaflessBits <- getAp $ foldMap (Ap . recoverBits) (Reverse childParents) + let keyBits = leaflessBits <> DList.fromList (getPrefixBits proofLeaf) + pure $ DList.toList keyBits + + getPrefixBits = maybe [] toBits . _radixPrefix + + proofLeaf = NonEmpty.head _radixPath + + -- Recovering the prefix necessitates us validating the child/parent + -- hashes. This is because we must find use the child's hash to + -- decide if the implicit bit is 0 or 1 + recoverBits (child, parent) = do + let prefixBits = maybe [] toBits (_radixPrefix parent) + childHash = hashNode child + implicit0 = mfilter (== childHash) (_radixLeft parent) $> False + implicit1 = mfilter (== childHash) (_radixRight parent) $> True + + -- This returning Nothing means we could not validate child/parent + implicit <- implicit0 <|> implicit1 + + pure $ DList.fromList prefixBits <> DList.singleton implicit + +-- Add the missing leaf value to _radixPath +includeValue :: RadixProof -> RadixProof +includeValue RadixProof{..} = RadixProof + { _radixPath = + setLeaf (Just _radixValue) (NonEmpty.head _radixPath) + :| NonEmpty.tail _radixPath + , _radixValue = _radixValue + } + +-------------------------------------------------------------------------------- + +-- | +-- Mask a node in a Merkleized radix tree. +merkleSpoof + :: RadixRoot -- ^ State root. + -> Maybe (RadixRoot, RadixNode, Bool) -- ^ Parent. + -> RadixBuffer -- ^ Buffer. + -> RadixBuffer +merkleSpoof mask = \ case + Nothing -> id + Just (root, node, test) -> + storeHot root $ test `setChild` Just mask $ node + +{-# INLINABLE merkleSpoof #-} + +-------------------------------------------------------------------------------- + +-- | +-- Merkleize a radix tree. This will flush the buffer to the database. +merkleizeRadixTree + :: RadixDatabase m database + => RadixTree database-- ^ Radix tree. + -> m (RadixRoot, RadixTree database) +merkleizeRadixTree RadixTree {..} = do + (root, cache) <- loop _radixRoot _radixCache + let tree = RadixTree bloom _radixBloomSize Map.empty cache _radixCacheSize root _radixDatabase 0 root + pure (root, tree) + where + bloom = emptyRadixBloom _radixBloomSize + loop root cache = + if not $ Bloom.elem root _radixBloom + then pure (root, cache) + else do + -- Load the root node. + result <- loadHot root _radixBuffer cache _radixDatabase + case result of + Nothing -> throw $ StateRootDoesNotExist root + Just (node@RadixNode {..}, cache') -> + case (_radixLeft, _radixRight) of + -- No children. + (Nothing, Nothing) -> + storeCold node cache' _radixDatabase + -- One left child. + (Just child, Nothing) -> do + (root', cache'') <- loop child cache' + let node' = False `setChild` Just root' $ node + storeCold node' cache'' _radixDatabase + -- One right child. + (Nothing, Just child) -> do + (root', cache'') <- loop child cache' + let node' = True `setChild` Just root' $ node + storeCold node' cache'' _radixDatabase + -- Two children. + (Just left, Just right) -> do + (root', cache'') <- loop left cache' + (root'', cache''') <- loop right cache'' + let node' = setChildren (Just root', Just root'') node + storeCold node' cache''' _radixDatabase + +{-# SPECIALISE merkleizeRadixTree + :: RadixTree LevelDB.DB + -> ResourceT IO (RadixRoot, RadixTree LevelDB.DB) #-} + +-------------------------------------------------------------------------------- + +-- | +-- Get the contents of a radix tree. +contentsRadixTree' + :: RadixDatabase m database + => Bool -- ^ Overwrite state root? + -> (RadixTree database -> m (Maybe (RadixNode, RadixCache))) -- ^ Loading strategy. + -> RadixTree database -- ^ Radix tree. + -> m [(ByteString, ByteString)] +contentsRadixTree' flag strategy = \ tree@RadixTree {..} -> do + let tree' = tree `bool` setRoot _radixCheckpoint tree $ flag + loop tree' [] [] where + loop tree@RadixTree {..} prefix accum = do + result <- strategy tree + case fst <$> result of + Nothing -> throw $ StateRootDoesNotExist _radixRoot + Just RadixNode {..} -> do + let prefix' = prefix ++ maybe [] toBits _radixPrefix + let key = fromBits prefix' + let accum' = maybe accum (\ value -> (key, value):accum) _radixLeaf + let children = [(,False) <$> _radixLeft, (,True) <$> _radixRight] + flip foldM accum' `flip` children $ \ accum'' -> \ case + Nothing -> pure accum'' + Just (root, test) -> do + let tree' = setRoot root tree + let prefix'' = prefix' ++ [test] + loop tree' prefix'' accum'' + +{-# SPECIALISE contentsRadixTree' + :: Bool + -> (RadixTree LevelDB.DB + -> ResourceT IO (Maybe (RadixNode, RadixCache))) + -> RadixTree LevelDB.DB + -> ResourceT IO [(ByteString, ByteString)] #-} + +-------------------------------------------------------------------------------- + +-- | +-- A convenient alias for `contentsNonMerkleizedRadixTree`. +contentsRadixTree + :: RadixDatabase m database + => RadixTree database -- ^ Radix tree. + -> m [(ByteString, ByteString)] +contentsRadixTree = contentsNonMerkleizedRadixTree + +{-# SPECIALISE contentsRadixTree + :: RadixTree LevelDB.DB + -> ResourceT IO [(ByteString, ByteString)] #-} + +-------------------------------------------------------------------------------- + +-- | +-- Get the contents of a Merkleized radix tree. +contentsMerkleizedRadixTree + :: RadixDatabase m database + => RadixTree database -- ^ Radix tree. + -> m [(ByteString, ByteString)] +contentsMerkleizedRadixTree = + contentsRadixTree' True $ \ RadixTree {..} -> + loadCold _radixRoot _radixCache _radixDatabase + +{-# SPECIALISE contentsMerkleizedRadixTree + :: RadixTree LevelDB.DB + -> ResourceT IO [(ByteString, ByteString)] #-} + +-------------------------------------------------------------------------------- + +-- | +-- Get the contents of a non-Merkleized radix tree. +contentsNonMerkleizedRadixTree + :: RadixDatabase m database + => RadixTree database -- ^ Radix tree. + -> m [(ByteString, ByteString)] +contentsNonMerkleizedRadixTree = + contentsRadixTree' False $ \ RadixTree {..} -> + loadHot _radixRoot _radixBuffer _radixCache _radixDatabase + +{-# SPECIALISE contentsNonMerkleizedRadixTree + :: RadixTree LevelDB.DB + -> ResourceT IO [(ByteString, ByteString)] #-} + +-------------------------------------------------------------------------------- + +-- | +-- Print a radix tree. +printRadixTree' + :: MonadIO m + => RadixDatabase m database + => Bool -- ^ Overwrite state root? + -> (RadixTree database -> m (Maybe (RadixNode, RadixCache))) -- ^ Loading strategy. + -> RadixTree database -- ^ Radix tree. + -> m () +printRadixTree' flag strategy = \ tree@RadixTree {..} -> do + let tree' = tree `bool` setRoot _radixCheckpoint tree $ flag + loop tree' 0 where + loop tree@RadixTree {..} i = do + result <- strategy tree + case fst <$> result of + Nothing -> throw $ StateRootDoesNotExist _radixRoot + Just node@RadixNode {..} -> do + let indent = (++) $ concat $ replicate i "｜" + liftIO $ putStrLn $ indent $ show node + let j = i + 1 + forM_ [_radixLeft, _radixRight] $ \ case + Nothing -> pure () + Just root -> setRoot root tree `loop` j + +{-# SPECIALISE printRadixTree' + :: Bool + -> (RadixTree LevelDB.DB + -> ResourceT IO (Maybe (RadixNode, RadixCache))) + -> RadixTree LevelDB.DB + -> ResourceT IO () #-} + +-------------------------------------------------------------------------------- + +-- | +-- A convenient alias for `printNonMerkleizedRadixTree`. +printRadixTree + :: MonadIO m + => RadixDatabase m database + => RadixTree database -- ^ Radix tree. + -> m () +printRadixTree = printNonMerkleizedRadixTree + +{-# SPECIALISE printRadixTree + :: RadixTree LevelDB.DB + -> ResourceT IO () #-} + +-------------------------------------------------------------------------------- + +-- | +-- Print a Merkleized radix tree. +printMerkleizedRadixTree + :: MonadIO m + => RadixDatabase m database + => RadixTree database -- ^ Radix tree. + -> m () +printMerkleizedRadixTree = + printRadixTree' True $ \ RadixTree {..} -> + loadCold _radixRoot _radixCache _radixDatabase + +{-# SPECIALISE printMerkleizedRadixTree + :: RadixTree LevelDB.DB + -> ResourceT IO () #-} + +-------------------------------------------------------------------------------- + +-- | +-- Print a non-Merkleized radix tree. +printNonMerkleizedRadixTree + :: MonadIO m + => RadixDatabase m database + => RadixTree database -- ^ Radix tree. + -> m () +printNonMerkleizedRadixTree = + printRadixTree' False $ \ RadixTree {..} -> + loadHot _radixRoot _radixBuffer _radixCache _radixDatabase + +{-# SPECIALISE printNonMerkleizedRadixTree + :: RadixTree LevelDB.DB + -> ResourceT IO () #-} + +-------------------------------------------------------------------------------- diff --git a/src/DFINITY/RadixTree/Bits.hs b/src/DFINITY/RadixTree/Bits.hs new file mode 100644 --- /dev/null +++ b/src/DFINITY/RadixTree/Bits.hs @@ -0,0 +1,37 @@ +{-# OPTIONS -Wall #-} +{-# OPTIONS -Werror #-} + +module DFINITY.RadixTree.Bits + ( Bitable(..) + , matchBits + ) where + +import Data.Bits ((.|.), setBit, testBit) +import Data.Bool (bool) +import Data.ByteString (ByteString, pack, unpack) +import Data.Word (Word8) + +class Bitable a where + fromBits :: [Bool] -> a + toBits :: a -> [Bool] + +instance Bitable ByteString where + fromBits = pack . go where + go [] = [] + go xs = let (a, b) = splitAt 8 xs in toByte a : go b + toBits = concatMap fromByte . unpack + +matchBits :: [Bool] -> [Bool] -> [Bool] +matchBits x = map fst . zipWhile (==) x + +zipWhile :: (a -> b -> Bool) -> [a] -> [b] -> [(a,b)] +zipWhile f x = takeWhile (uncurry f) . zip x + +fromByte :: Word8 -> [Bool] +fromByte = flip map order . testBit + +toByte :: [Bool] -> Word8 +toByte = foldl (.|.) 0 . zipWith (bool 0 . setBit 0) order + +order :: Enum a => Num a => [a] +order = [7, 6.. 0] diff --git a/src/DFINITY/RadixTree/Bloom.hs b/src/DFINITY/RadixTree/Bloom.hs new file mode 100644 --- /dev/null +++ b/src/DFINITY/RadixTree/Bloom.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} + +{-# OPTIONS -Wall #-} +{-# OPTIONS -Werror #-} + +module DFINITY.RadixTree.Bloom + ( emptyRadixBloom + ) where + +import Data.BloomFilter (empty) +import Data.ByteString.Short.Internal (ShortByteString(..)) +import Data.Word (Word32) +import GHC.Prim (ByteArray#, Int#, (-#), indexWord32Array#, quotInt#, sizeofByteArray#) +import GHC.Word (Word32(..)) + +import DFINITY.RadixTree.Types + +emptyRadixBloom :: Int -> RadixBloom +emptyRadixBloom = empty hash + +hash :: RadixRoot -> [Word32] +hash = \ case + SBS bytes# -> + let n# = sizeofByteArray# bytes# + m# = quotInt# n# 4# + in hash# bytes# m# + +hash# :: ByteArray# -> Int# -> [Word32] +hash# bytes# = \ case + 0# -> [] + i# -> + let j# = i# -# 1# + w# = indexWord32Array# bytes# j# + in W32# w# : hash# bytes# j# diff --git a/src/DFINITY/RadixTree/Conduit.hs b/src/DFINITY/RadixTree/Conduit.hs new file mode 100644 --- /dev/null +++ b/src/DFINITY/RadixTree/Conduit.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS -Wall #-} +{-# OPTIONS -Werror #-} +{-# OPTIONS -fno-warn-partial-type-signatures #-} + +-- | +-- Module : DFINITY.RadixTree.Conduit +-- Copyright : 2018 DFINITY Stiftung +-- License : GPL-3 +-- Maintainer : Enzo Haussecker +-- Stability : Stable +-- +-- A parallel download protocol. +module DFINITY.RadixTree.Conduit ( + + -- ** Combinators + sourceRadixTree + , sinkRadixTree + + ) where + +import Codec.Serialise (deserialise, deserialiseOrFail, serialise) +import Control.Concurrent (forkIO, killThread) +import Control.Concurrent.BoundedChan (BoundedChan, readChan, tryWriteChan) +import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar) +import Control.Concurrent.ReadWriteLock (RWLock) +import Control.Exception (throw) +import Control.Monad (filterM, foldM, forM_, forever, void, when) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (MonadResource, ResourceT, allocate, release) +import Crypto.Hash.BLAKE2.BLAKE2s (hash) +import Data.ByteString (ByteString) +import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.ByteString.Short (fromShort, toShort) +import Data.Conduit (ConduitT, await, yield) +import Data.HashTable.IO as Cuckoo (CuckooHashTable, delete, fromList, insert, lookup) +import Data.List as List (delete) +import Data.LruCache as LRU (LruCache, empty, insert, lookup) +import Data.Maybe (isJust, isNothing) +import Data.Void (Void) +import Database.LevelDB as LevelDB (DB, Options(..), defaultOptions, defaultWriteOptions, delete) +import Database.LevelDB.Base (open) +import Database.LevelDB.Internal (unsafeClose) +import System.Directory (canonicalizePath, getTemporaryDirectory, removeDirectoryRecursive) +import System.IO.Temp (createTempDirectory) + +import DFINITY.RadixTree.Bits +import DFINITY.RadixTree.Lenses +import DFINITY.RadixTree.Lock +import DFINITY.RadixTree.Types +import DFINITY.RadixTree.Utilities + +-------------------------------------------------------------------------------- + +-- | +-- Create a conduit from a radix tree. +sourceRadixTree + :: forall m database. MonadResource m + => RadixDatabase (ConduitT () ByteString m) database + => [Bool] -- ^ Bit mask. + -> Int -- ^ LRU cache size in items. + -> BoundedChan RadixRoot -- ^ Terminal state root producer. + -> RadixTree database -- ^ Radix tree. + -> RWLock -- ^ Radix database lock. + -> ConduitT () ByteString m () +sourceRadixTree mask cacheSize chan tree radixLock + | cacheSize <= 0 = throw $ InvalidArgument "invalid LRU cache size" + | otherwise = do + cache <- liftIO $ newMVar $ empty cacheSize + action <- fmap fst $ flip allocate killThread $ forkIO $ forever $ do + root <- readChan chan + modifyMVar_ cache $ pure . LRU.insert root () + loop cache tree [] + release action + where + + loop + :: MVar (LruCache RadixRoot ()) + -> RadixTree database + -> [RadixRoot] + -> ConduitT () ByteString m () + loop cache subtree@RadixTree {..} accum = do + let accum' = _radixCheckpoint:accum + seen <- liftIO $ readMVar cache + if flip any accum' $ isJust . flip LRU.lookup seen + then pure () + else do + let key = fromShort _radixCheckpoint + result <- withReadLock radixLock $ load _radixDatabase key + case result of + Nothing -> pure () + Just bytes -> do + let RadixNode {..} = deserialise $ fromStrict bytes + let success = all id $ zipWith (==) mask $ toBits $ fromShort _radixCheckpoint + when success $ yield bytes + forM_ [_radixLeft, _radixRight] $ \ case + Nothing -> pure () + Just root -> loop cache `flip` accum' $ setCheckpoint root subtree + +{-# SPECIALISE sourceRadixTree + :: [Bool] + -> Int + -> BoundedChan RadixRoot + -> RadixTree DB + -> RWLock + -> ConduitT () ByteString (ResourceT IO) () #-} + +-------------------------------------------------------------------------------- + +-- | +-- Create a radix tree from a conduit. +sinkRadixTree + :: forall m database. MonadResource m + => RadixDatabase (ConduitT ByteString Void m) database + => RadixRoot -- ^ Target state root. + -> BoundedChan RadixRoot -- ^ Terminal state root consumer. + -> RadixTree database -- ^ Radix tree. + -> RWLock -- ^ Radix database lock. + -> ConduitT ByteString Void m (Either String (RadixTree database)) +sinkRadixTree checkpoint chan tree@RadixTree {..} radixLock = do + -- Create a temporary directory. + relative <- liftIO getTemporaryDirectory + absolute <- liftIO $ canonicalizePath relative + let createTempDir = createTempDirectory absolute "dfinity" + let destroyTempDir = ignoreIOErrors . removeDirectoryRecursive + (tempDirKey, tempDir) <- allocate createTempDir destroyTempDir + -- Create a temporary database. + let createTempDatabase = open tempDir defaultOptions {createIfMissing = True} + (tempDatabaseKey, tempDatabase) <- allocate createTempDatabase unsafeClose + -- Create a hash table. + table <- liftIO $ fromList [(checkpoint, Nothing)] + -- Consume the radix nodes. + result <- loop1 tempDatabase table + -- Remove the temporary database. + release tempDatabaseKey + release tempDirKey + -- Return the result. + pure result + where + + -- Loop 1: The collection loop. + loop1 + :: DB + -> CuckooHashTable RadixRoot (Maybe RadixRoot) + -> ConduitT ByteString Void m (Either String (RadixTree database)) + loop1 tempDatabase table = do + -- Have we collected all the radix nodes? + done <- liftIO $ isNothing <$> Cuckoo.lookup table checkpoint + if done + then pure $ Right $ setCheckpoint checkpoint $ setRoot checkpoint tree + else do + -- Wait for a radix node. + mval <- await + case mval of + Nothing -> pure $ Left "EOF" + Just node -> + case deserialiseOrFail $ fromStrict node of + Left _ -> loop1 tempDatabase table + Right RadixNode {..} -> do + -- Does the radix node already exist in the radix database? + let key = hash 20 mempty node + let root = toShort key + want <- liftIO $ isJust <$> Cuckoo.lookup table root + exists <- if want + then pure False + else withReadLock radixLock $ isJust <$> load _radixDatabase key + if exists + then do + -- Announce a terminal state root. + liftIO $ void $ tryWriteChan chan root + -- Discard the radix node. + liftIO $ Cuckoo.delete table root + loop1 tempDatabase table + else do + -- Identify any children not present in the radix database. + let absent = fmap isNothing . withReadLock radixLock . load _radixDatabase . fromShort + let children = maybe id (:) _radixLeft $ maybe id (:) _radixRight [] + targets <- filterM absent children + -- Write the radix node and its targets to the temporary database. + let value = toStrict $ serialise (node, targets) + store tempDatabase key value + -- Does the radix node have any gaps in its lineage? + if not want + then loop1 tempDatabase table + else do + -- Write all eligible radix nodes to the radix database. + eligible <- loop2 tempDatabase table root [] + loop3 tempDatabase table eligible + loop1 tempDatabase table + + -- Loop 2: The aggregation loop. + loop2 + :: DB + -> CuckooHashTable RadixRoot (Maybe RadixRoot) + -> RadixRoot + -> [(RadixRoot, ByteString)] + -> ConduitT ByteString Void m [(RadixRoot, ByteString)] + loop2 tempDatabase table root eligible = do + -- Read the radix node and its targets from the temporary database. + result <- load tempDatabase $ fromShort root + case deserialise . fromStrict <$> result of + Nothing -> pure eligible + Just (bytes, targets :: [] _) -> + -- Is the radix node eligible to be written to disk? + if null targets + then pure $ (root, bytes):eligible + else do + -- Write the child-parent pairs to the hash table. + liftIO $ forM_ targets $ \ child -> + Cuckoo.insert table child $ Just root + -- Recurse. + foldM step eligible targets + where step = flip $ loop2 tempDatabase table + + -- Loop 3: The write loop. + loop3 + :: DB + -> CuckooHashTable RadixRoot (Maybe RadixRoot) + -> [(RadixRoot, ByteString)] + -> ConduitT ByteString Void m () + loop3 tempDatabase table = \ case + [] -> pure () + (root, bytes):eligible -> do + -- Write the radix node to the radix database. + let key = fromShort root + withWriteLock radixLock $ store _radixDatabase key bytes + -- Delete the radix node from the temporary database. + LevelDB.delete tempDatabase defaultWriteOptions $ fromShort root + Just parent <- liftIO $ Cuckoo.lookup table root + liftIO $ Cuckoo.delete table root + case parent of + Nothing -> pure () + Just root' -> do + let key' = fromShort root' + Just value <- load tempDatabase key' + let (bytes', targets') = deserialise $ fromStrict value + let targets'' = List.delete root targets' + -- Have both siblings been written to the radix database? + if null targets'' + then do + let eligible' = (root', bytes'):eligible + loop3 tempDatabase table eligible' + else do + -- Update the parent node. + let value' = toStrict $ serialise (bytes', targets'') + store tempDatabase key' value' + loop3 tempDatabase table eligible + +{-# SPECIALISE sinkRadixTree + :: RadixRoot + -> BoundedChan RadixRoot + -> RadixTree DB + -> RWLock + -> ConduitT ByteString + Void + (ResourceT IO) + (Either String (RadixTree DB)) #-} + +-------------------------------------------------------------------------------- diff --git a/src/DFINITY/RadixTree/Lenses.hs b/src/DFINITY/RadixTree/Lenses.hs new file mode 100644 --- /dev/null +++ b/src/DFINITY/RadixTree/Lenses.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS -Wall #-} +{-# OPTIONS -Werror #-} +{-# OPTIONS -fno-warn-missing-signatures #-} +{-# OPTIONS -fno-warn-unused-top-binds #-} + +module DFINITY.RadixTree.Lenses + ( getPrefix + , getLeft + , getRight + , getChild + , getChildren + , getLeaf + , getBloom + , getBuffer + , getCache + , getCheckpoint + , getNonce + , getRoot + , setPrefix + , setLeft + , setRight + , setChild + , setChildren + , setLeaf + , setBloom + , setBuffer + , setCache + , setCheckpoint + , setNonce + , setRoot + ) where + +import Data.Bool (bool) +import Data.ByteString (ByteString) +import Lens.Simple (makeLenses, set, view) + +import DFINITY.RadixTree.Types + +makeLenses ''RadixNode +makeLenses ''RadixTree + +getPrefix :: RadixNode -> Maybe RadixPrefix +getPrefix = view radixPrefix + +getLeft :: RadixNode -> Maybe RadixRoot +getLeft = view radixLeft + +getRight :: RadixNode -> Maybe RadixRoot +getRight = view radixRight + +getChild :: Bool -> RadixNode -> Maybe RadixRoot +getChild = bool getLeft getRight + +getChildren :: RadixNode -> (Maybe RadixRoot, Maybe RadixRoot) +getChildren node = (getLeft node, getRight node) + +getLeaf :: RadixNode -> Maybe ByteString +getLeaf = view radixLeaf + +getBloom :: RadixTree database -> RadixBloom +getBloom = view radixBloom + +getBuffer :: RadixTree database -> RadixBuffer +getBuffer = view radixBuffer + +getCache :: RadixTree database -> RadixCache +getCache = view radixCache + +getCheckpoint :: RadixTree database -> RadixRoot +getCheckpoint = view radixCheckpoint + +getNonce :: RadixTree database -> Word +getNonce = view radixNonce + +getRoot :: RadixTree database -> RadixRoot +getRoot = view radixRoot + +setPrefix :: Maybe RadixPrefix -> RadixNode -> RadixNode +setPrefix = set radixPrefix + +setLeft :: Maybe RadixRoot -> RadixNode -> RadixNode +setLeft = set radixLeft + +setRight :: Maybe RadixRoot -> RadixNode -> RadixNode +setRight = set radixRight + +setChild :: Bool -> Maybe RadixRoot -> RadixNode -> RadixNode +setChild = bool setLeft setRight + +setChildren :: (Maybe RadixRoot, Maybe RadixRoot) -> RadixNode -> RadixNode +setChildren (left, right) = setLeft left . setRight right + +setLeaf :: Maybe ByteString -> RadixNode -> RadixNode +setLeaf = set radixLeaf + +setBloom :: RadixBloom -> RadixTree database -> RadixTree database +setBloom = set radixBloom + +setBuffer :: RadixBuffer -> RadixTree database -> RadixTree database +setBuffer = set radixBuffer + +setCache :: RadixCache -> RadixTree database -> RadixTree database +setCache = set radixCache + +setCheckpoint :: RadixRoot -> RadixTree database -> RadixTree database +setCheckpoint = set radixCheckpoint + +setNonce :: Word -> RadixTree database -> RadixTree database +setNonce = set radixNonce + +setRoot :: RadixRoot -> RadixTree database -> RadixTree database +setRoot = set radixRoot diff --git a/src/DFINITY/RadixTree/Lock.hs b/src/DFINITY/RadixTree/Lock.hs new file mode 100644 --- /dev/null +++ b/src/DFINITY/RadixTree/Lock.hs @@ -0,0 +1,30 @@ +{-# OPTIONS -Wall #-} +{-# OPTIONS -Werror #-} + +module DFINITY.RadixTree.Lock + ( withReadLock + , withWriteLock + ) where + +import Control.Concurrent.ReadWriteLock (RWLock, acquireRead, acquireWrite, releaseRead, releaseWrite) +import Control.Monad.Trans.Resource (MonadResource, allocate, release) + +withReadLock :: MonadResource m => RWLock -> m a -> m a +withReadLock lock action = do + key <- fst <$> allocate acquireLock releaseLock + result <- action + release key + pure result + where + acquireLock = acquireRead lock + releaseLock = const $ releaseRead lock + +withWriteLock :: MonadResource m => RWLock -> m a -> m a +withWriteLock lock action = do + key <- fst <$> allocate acquireLock releaseLock + result <- action + release key + pure result + where + acquireLock = acquireWrite lock + releaseLock = const $ releaseWrite lock diff --git a/src/DFINITY/RadixTree/Memory.hs b/src/DFINITY/RadixTree/Memory.hs new file mode 100644 --- /dev/null +++ b/src/DFINITY/RadixTree/Memory.hs @@ -0,0 +1,103 @@ +{-# OPTIONS -Wall #-} +{-# OPTIONS -Werror #-} + +module DFINITY.RadixTree.Memory + ( loadHot + , loadCold + , storeHot + , storeCold + ) where + +import Codec.Serialise (deserialise, serialise) +import Control.Monad.Trans.Resource (ResourceT) +import Crypto.Hash.BLAKE2.BLAKE2s (hash) +import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.ByteString.Short (fromShort, toShort) +import Data.LruCache as LRU (insert, lookup) +import Data.Map.Strict as Map (insert, lookup) +import Database.LevelDB (DB) + +import DFINITY.RadixTree.Types + +-------------------------------------------------------------------------------- + +loadHot + :: RadixDatabase m database + => RadixRoot + -> RadixBuffer + -> RadixCache + -> database + -> m (Maybe (RadixNode, RadixCache)) +loadHot root buffer cache database = + case Map.lookup root buffer of + Just node -> pure $ Just (node, cache) + Nothing -> loadCold root cache database + +{-# SPECIALISE loadHot + :: RadixRoot + -> RadixBuffer + -> RadixCache + -> DB + -> ResourceT IO (Maybe (RadixNode, RadixCache)) #-} + +-------------------------------------------------------------------------------- + +loadCold + :: RadixDatabase m database + => RadixRoot + -> RadixCache + -> database + -> m (Maybe (RadixNode, RadixCache)) +loadCold root cache database = + case LRU.lookup root cache of + Just (node, cache') -> + seq cache' $ seq node $ pure $ Just (node, cache') + Nothing -> do + let key = fromShort root + result <- load database key + case result of + Just bytes -> do + let node = deserialise $ fromStrict bytes + let cache' = LRU.insert root node cache + seq cache' $ seq node $ pure $ Just (node, cache') + Nothing -> pure $ Nothing + +{-# SPECIALISE loadCold + :: RadixRoot + -> RadixCache + -> DB + -> ResourceT IO (Maybe (RadixNode, RadixCache)) #-} + +-------------------------------------------------------------------------------- + +storeHot + :: RadixRoot + -> RadixNode + -> RadixBuffer + -> RadixBuffer +storeHot = Map.insert + +-------------------------------------------------------------------------------- + +storeCold + :: RadixDatabase m database + => RadixNode + -> RadixCache + -> database + -> m (RadixRoot, RadixCache) +storeCold node cache database = do + store database key bytes + seq cache' $ pure (root, cache') + where + bytes = toStrict $ serialise node + key = hash 20 mempty bytes + root = toShort key + cache' = LRU.insert root node cache + +{-# SPECIALISE storeCold + :: RadixNode + -> RadixCache + -> DB + -> ResourceT IO (RadixRoot, RadixCache) #-} + +-------------------------------------------------------------------------------- diff --git a/src/DFINITY/RadixTree/Serialise.hs b/src/DFINITY/RadixTree/Serialise.hs new file mode 100644 --- /dev/null +++ b/src/DFINITY/RadixTree/Serialise.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS -Wall #-} +{-# OPTIONS -Werror #-} + +module DFINITY.RadixTree.Serialise + ( decodeLeaf + , decodeMaybe + , decodeSide + , encodeMaybe + , encodeSide + ) where + +import Codec.Serialise (Serialise) +import Codec.Serialise.Decoding (Decoder, TokenType(..), decodeBytes, decodeNull, decodeTag, peekTokenType) +import Codec.Serialise.Encoding (Encoding, encodeBytes, encodeNull, encodeTag) +import Control.Monad (void) +import Data.ByteString.Char8 (ByteString) +import Data.Monoid ((<>)) + +decodeLeaf :: Int -> Decoder s (Maybe ByteString) +decodeLeaf = \ case + 3 -> pure Nothing + 4 -> pure <$> decodeBytes + _ -> fail "decodeLeaf: invalid argument" + +decodeMaybe :: Serialise a => Decoder s a -> Decoder s (Maybe a) +decodeMaybe value = peekTokenType >>= \ case + TypeNull -> decodeNull >> pure Nothing + _ -> pure <$> value + +decodeSide :: Decoder s ByteString +decodeSide = void decodeTag >> decodeBytes + +encodeMaybe :: Serialise a => (a -> Encoding) -> Maybe a -> Encoding +encodeMaybe = maybe encodeNull + +encodeSide :: ByteString -> Encoding +encodeSide side = encodeTag 42 <> encodeBytes side diff --git a/src/DFINITY/RadixTree/Types.hs b/src/DFINITY/RadixTree/Types.hs new file mode 100644 --- /dev/null +++ b/src/DFINITY/RadixTree/Types.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS -Wall #-} +{-# OPTIONS -Werror #-} + +module DFINITY.RadixTree.Types + ( RadixBloom + , RadixBuffer + , RadixCache + , RadixDatabase(..) + , RadixError(..) + , RadixNode(..) + , RadixPrefix(..) + , RadixProof(..) + , RadixRoot + , RadixSearchResult + , RadixTree(..) + ) where + +import Codec.Serialise as CBOR (Serialise(..), serialise) +import Codec.Serialise.Decoding (decodeBytes, decodeInt, decodeListLen) +import Codec.Serialise.Encoding (encodeBytes, encodeInt, encodeListLen) +import Control.DeepSeq (NFData(..)) +import Control.Exception (Exception) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.ST (ST) +import Control.Monad.State.Strict as StateT (StateT, get, modify) +import Crypto.Hash.BLAKE2.BLAKE2s (hash) +import Data.BloomFilter (Bloom) +import Data.Bool (bool) +import Data.ByteString.Base16 as Base16 (encode) +import Data.ByteString.Char8 (ByteString, unpack) +import Data.ByteString.Lazy (toStrict) +import Data.ByteString.Short (ShortByteString, fromShort, toShort) +import Data.Data (Data) +import Data.Default.Class (Default(..)) +import Data.IORef (IORef, readIORef, modifyIORef') +import Data.List.NonEmpty (NonEmpty(..)) +import Data.LruCache (LruCache) +import Data.Map.Strict as Map (Map, insert, lookup) +import Data.Maybe (isJust) +import Data.Monoid ((<>)) +import Data.STRef (STRef, readSTRef, modifySTRef') +import Text.Printf (printf) + +import qualified Database.LevelDB as LevelDB +import qualified Database.LMDB.Simple as LMDB + +import DFINITY.RadixTree.Bits +import DFINITY.RadixTree.Serialise + +type RadixBloom = Bloom RadixRoot + +type RadixBuffer = Map RadixRoot RadixNode + +type RadixCache = LruCache RadixRoot RadixNode + +class Monad m => RadixDatabase m database where + load :: database -> ByteString -> m (Maybe ByteString) + store :: database -> ByteString -> ByteString -> m () + +instance Monad m => RadixDatabase (StateT (Map ByteString ByteString) m) () where + load () key = Map.lookup key <$> StateT.get + store () key = StateT.modify . Map.insert key + +instance RadixDatabase (ST s) (STRef s (Map ByteString ByteString)) where + load db key = Map.lookup key <$> readSTRef db + store db key val = modifySTRef' db $ Map.insert key val + +instance MonadIO m => RadixDatabase m (IORef (Map ByteString ByteString)) where + load db key = liftIO $ Map.lookup key <$> readIORef db + store db key val = liftIO $ modifyIORef' db $ Map.insert key val + +instance MonadIO m => RadixDatabase m LevelDB.DB where + load db = LevelDB.get db LevelDB.defaultReadOptions + store db = LevelDB.put db LevelDB.defaultWriteOptions + +instance RadixDatabase (LMDB.Transaction LMDB.ReadWrite) (LMDB.Database ByteString ByteString) where + load db key = LMDB.get db key + store db key val = LMDB.put db key $ Just val + +data RadixError + = InvalidArgument String + | StateRootDoesNotExist RadixRoot + deriving (Data, Eq, Show) + +instance Exception RadixError + +data RadixNode + = RadixNode + { _radixPrefix :: Maybe RadixPrefix + , _radixLeft :: Maybe RadixRoot + , _radixRight :: Maybe RadixRoot + , _radixLeaf :: Maybe ByteString + } deriving (Data, Eq) + +instance NFData RadixNode where + rnf RadixNode {..} = + rnf _radixPrefix `seq` + rnf _radixLeft `seq` + rnf _radixRight `seq` + rnf _radixLeaf `seq` + () + +instance Default RadixNode where + def = RadixNode Nothing Nothing Nothing Nothing + +instance Serialise RadixNode where + encode RadixNode {..} = + encodeListLen len <> + encodeMaybe CBOR.encode _radixPrefix <> + encodeMaybe encodeSide left <> + encodeMaybe encodeSide right <> + maybe mempty encodeBytes _radixLeaf + where + len = bool 3 4 $ isJust _radixLeaf + left = fromShort <$> _radixLeft + right = fromShort <$> _radixRight + decode = do + len <- decodeListLen + prefix <- decodeMaybe decode + left <- decodeMaybe $ toShort <$> decodeSide + right <- decodeMaybe $ toShort <$> decodeSide + leaf <- decodeLeaf len + pure $ RadixNode prefix left right leaf + +instance Show RadixNode where + show node@RadixNode {..} = + case unpack <$> _radixLeaf of + Nothing -> printf "\ESC[96m%s\ESC[0m@[\ESC[97m%s\ESC[0m,\ESC[96m%s\ESC[0m,\ESC[96m%s\ESC[0m]" root prefix left right + Just leaf -> printf "\ESC[96m%s\ESC[0m@[\ESC[97m%s\ESC[0m,\ESC[96m%s\ESC[0m,\ESC[96m%s\ESC[0m,\ESC[97m%s\ESC[0m]" root prefix left right leaf + where + root = format $ hash 20 mempty $ toStrict $ serialise node + prefix = guard show _radixPrefix + left = guard format $ fromShort <$> _radixLeft + right = guard format $ fromShort <$> _radixRight + guard = maybe "null" + format = take 8 . unpack . Base16.encode + +data RadixPrefix + = RadixPrefix + { _radixBitLen :: Int + , _radixName :: ByteString + } deriving (Data, Eq) + +instance Bitable RadixPrefix where + toBits RadixPrefix {..} = take _radixBitLen $ toBits _radixName + fromBits bits = RadixPrefix bitLen name + where + bitLen = length bits + name = fromBits bits + +instance NFData RadixPrefix where + rnf RadixPrefix {..} = + rnf _radixBitLen `seq` + rnf _radixName `seq` + () + +instance Serialise RadixPrefix where + encode RadixPrefix {..} = + encodeListLen 2 <> + encodeInt _radixBitLen <> + encodeBytes _radixName + decode = do + void decodeListLen + bitLen <- decodeInt + name <- decodeBytes + pure $ RadixPrefix bitLen name + +instance Show RadixPrefix where + show = map compress . toBits + where compress = bool '0' '1' + +data RadixProof + = RadixProof + { _radixPath :: NonEmpty RadixNode + , _radixValue :: ByteString + } deriving (Data, Eq, Show) + +instance NFData RadixProof where + rnf RadixProof {..} = + rnf _radixPath `seq` + rnf _radixValue `seq` + () + +instance Serialise RadixProof where + encode RadixProof {..} = + CBOR.encode path + where + RadixNode {..} :| nodes = _radixPath + node = RadixNode _radixPrefix _radixLeft _radixRight $ Just _radixValue + path = node :| nodes + decode = do + RadixNode {..} :| nodes <- CBOR.decode + case _radixLeaf of + Nothing -> fail "no proof value" + Just value -> do + let node = RadixNode _radixPrefix _radixLeft _radixRight Nothing + let path = node :| nodes + pure $ RadixProof path value + +type RadixRoot = ShortByteString + +type RadixSearchResult = (NonEmpty RadixRoot, NonEmpty RadixNode, NonEmpty [Bool], [Bool], [Bool], RadixCache) + +data RadixTree database + = RadixTree + { _radixBloom :: RadixBloom + , _radixBloomSize :: Int + , _radixBuffer :: RadixBuffer + , _radixCache :: RadixCache + , _radixCacheSize :: Int + , _radixCheckpoint :: RadixRoot + , _radixDatabase :: database + , _radixNonce :: Word + , _radixRoot :: RadixRoot + } diff --git a/src/DFINITY/RadixTree/Utilities.hs b/src/DFINITY/RadixTree/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/DFINITY/RadixTree/Utilities.hs @@ -0,0 +1,50 @@ +{-# OPTIONS -Wall #-} +{-# OPTIONS -Werror #-} + +module DFINITY.RadixTree.Utilities + ( createPrefix + , createRoot + , createRootFromNonce + , defaultRoot + , ignoreIOErrors + , hashNode + ) where + +import Codec.Serialise (serialise) +import Control.Exception (handle) +import Crypto.Hash.BLAKE2.BLAKE2s (finalize, hash, initialize, update) +import Data.ByteString as Strict (ByteString) +import Data.ByteString.Builder (toLazyByteString, wordDec) +import Data.ByteString.Lazy as Lazy (ByteString, foldlChunks, toStrict) +import Data.ByteString.Short (toShort) +import Data.Default.Class (def) +import System.IO.Error (IOError) + +import DFINITY.RadixTree.Bits +import DFINITY.RadixTree.Types + +createPrefix :: [Bool] -> Maybe RadixPrefix +createPrefix bits = + if null bits + then Nothing + else Just $ fromBits bits + +createRoot :: RadixNode -> RadixRoot +createRoot = toShort . hashLazy 20 . serialise + +createRootFromNonce :: Word -> RadixRoot +createRootFromNonce = toShort . hash 20 mempty . toStrict . toLazyByteString . wordDec + +defaultRoot :: RadixRoot +defaultRoot = createRoot def + +hashLazy :: Int -> Lazy.ByteString -> Strict.ByteString +hashLazy size = finalize size . fold + where fold = foldlChunks step $ initialize size + step = flip update + +ignoreIOErrors :: IO () -> IO () +ignoreIOErrors = handle $ (const $ pure () :: IOError -> IO ()) + +hashNode :: RadixNode -> RadixRoot +hashNode = toShort . hash 20 mempty . toStrict . serialise diff --git a/src/Network/DFINITY/RadixTree.hs b/src/Network/DFINITY/RadixTree.hs deleted file mode 100644 --- a/src/Network/DFINITY/RadixTree.hs +++ /dev/null @@ -1,806 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} - -{-# OPTIONS -Wall #-} -{-# OPTIONS -Werror #-} -{-# OPTIONS -fno-warn-unused-top-binds #-} - --- | --- Module : Network.DFINITY.RadixTree --- Copyright : 2018 DFINITY Stiftung --- License : GPL-3 --- Maintainer : Enzo Haussecker --- Stability : Stable --- --- A generic data integrity layer. -module Network.DFINITY.RadixTree ( - - -- ** Class - RadixDatabase(..) - - -- ** Types - , RadixError(..) - , RadixRoot - , RadixTree - - -- ** Create - , createRadixTree - - -- ** Insert - , insertRadixTree - - -- ** Delete - , deleteRadixTree - - -- ** Merkleize - , merkleizeRadixTree - - -- ** Query - , lookupRadixTree - - -- ** Test - , isEmptyRadixTree - , isValidRadixRoot - - -- ** Debug - , contentsRadixTree - , contentsMerkleizedRadixTree - , contentsNonMerkleizedRadixTree - - , printRadixTree - , printMerkleizedRadixTree - , printNonMerkleizedRadixTree - - ) where - -import Control.Exception (throw) -import Control.Monad (foldM, forM_) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Trans.Resource (ResourceT) -import Data.Bool (bool) -import Data.ByteString (ByteString) -import Data.ByteString.Short (fromShort) -import Data.Default.Class (def) -import Data.List.NonEmpty (NonEmpty(..), fromList) -import Data.Maybe (fromJust, isJust, isNothing, listToMaybe) -import Data.Tuple (swap) - -import qualified Data.BloomFilter as Bloom -import qualified Data.LruCache as LRU -import qualified Data.Map.Strict as Map -import qualified Database.LevelDB as LevelDB - -import Network.DFINITY.RadixTree.Bits -import Network.DFINITY.RadixTree.Bloom -import Network.DFINITY.RadixTree.Lenses -import Network.DFINITY.RadixTree.Memory -import Network.DFINITY.RadixTree.Types -import Network.DFINITY.RadixTree.Utilities - --------------------------------------------------------------------------------- - --- | --- Create a radix tree. -createRadixTree - :: RadixDatabase m database - => Int -- ^ Bloom filter size in bits. - -> Int -- ^ LRU cache size in items. - -> Maybe RadixRoot -- ^ Previous state root. - -> database -- ^ Database. - -> m (RadixTree database) -createRadixTree bloomSize cacheSize checkpoint database - | bloomSize <= 0 = throw $ InvalidArgument "invalid Bloom filter size" - | cacheSize <= 0 = throw $ InvalidArgument "invalid LRU cache size" - | otherwise = do - (root, cache') <- - case checkpoint of - Nothing -> storeCold def cache database - Just root -> do - result <- loadCold root cache database - case snd <$> result of - Nothing -> throw $ StateRootDoesNotExist root - Just cache' -> pure (root, cache') - pure $ RadixTree bloom bloomSize Map.empty cache' cacheSize root database 0 root - where - bloom = emptyRadixBloom bloomSize - cache = LRU.empty cacheSize - -{-# SPECIALISE createRadixTree - :: Int - -> Int - -> Maybe RadixRoot - -> LevelDB.DB - -> ResourceT IO (RadixTree LevelDB.DB) #-} - --------------------------------------------------------------------------------- - --- | --- Check if a radix tree is empty. -isEmptyRadixTree - :: RadixTree database -- ^ Radix tree. - -> Bool -isEmptyRadixTree tree = _radixRoot tree == defaultRoot - -{-# INLINABLE isEmptyRadixTree #-} - --------------------------------------------------------------------------------- - --- | --- Check if a state root is valid. -isValidRadixRoot - :: RadixDatabase m database - => RadixRoot -- ^ State root. - -> RadixTree database -- ^ Radix tree. - -> m Bool -isValidRadixRoot root RadixTree {..} = - isJust <$> load _radixDatabase key - where - key = fromShort root - -{-# SPECIALISE isValidRadixRoot - :: RadixRoot - -> RadixTree LevelDB.DB - -> ResourceT IO Bool #-} - --------------------------------------------------------------------------------- - --- | --- Search for a value in a radix tree. -searchRadixTree - :: RadixDatabase m database - => Bool -- ^ Overwrite state root? - -> (RadixTree database -> m (Maybe (RadixNode, RadixCache))) -- ^ Loading strategy. - -> ByteString -- ^ Key. - -> RadixTree database -- ^ Radix tree. - -> m (Either RadixError RadixSearchResult) -searchRadixTree flag strategy = \ key tree@RadixTree {..} -> do - let key' = toBits key - let tree' = tree `bool` setRoot _radixCheckpoint tree $ flag - loop Nothing [] [] [] key' tree' where - loop implicit roots nodes prefixes key tree@RadixTree {..} = do - -- Load the root node. - result <- strategy tree - case result of - Nothing -> pure $ Left $ StateRootDoesNotExist _radixRoot - Just (node@RadixNode {..}, cache') -> do - -- Calculate the prefix and overflow. - let bits = maybe id (:) implicit $ maybe [] toBits _radixPrefix - let prefix = matchBits bits key - let n = length prefix - let overflow = drop n bits - -- Update the accumulators. - let roots' = _radixRoot:roots - let nodes' = node:nodes - let prefixes' = prefix:prefixes - let key' = drop n key - -- Check the termination criteria. - let residue = not $ null overflow - let bit = head key' - let child = bool _radixLeft _radixRight bit - if null key' || residue || isNothing child - then pure $ Right (fromList roots', fromList nodes', fromList prefixes', overflow, key', cache') - else do - -- Recurse. - let root' = fromJust child - let tree' = setCache cache' $ setRoot root' tree - let implicit' = Just bit - loop implicit' roots' nodes' prefixes' key' tree' - -{-# SPECIALISE searchRadixTree - :: Bool - -> (RadixTree LevelDB.DB - -> ResourceT IO (Maybe (RadixNode, RadixCache))) - -> ByteString - -> RadixTree LevelDB.DB - -> ResourceT IO (Either RadixError RadixSearchResult) #-} - --------------------------------------------------------------------------------- - --- | --- Search for a value in a Merkleized radix tree. -searchMerkleizedRadixTree - :: RadixDatabase m database - => ByteString -- ^ Key. - -> RadixTree database -- ^ Radix tree. - -> m (Either RadixError RadixSearchResult) -searchMerkleizedRadixTree = - searchRadixTree True $ \ RadixTree {..} -> - loadCold _radixRoot _radixCache _radixDatabase - -{-# SPECIALISE searchMerkleizedRadixTree - :: ByteString - -> RadixTree LevelDB.DB - -> ResourceT IO (Either RadixError RadixSearchResult) #-} - --------------------------------------------------------------------------------- - --- | --- Search for a value in a non-Merkleized radix tree. -searchNonMerkleizedRadixTree - :: RadixDatabase m database - => ByteString -- ^ Key. - -> RadixTree database -- ^ Radix tree. - -> m (Either RadixError RadixSearchResult) -searchNonMerkleizedRadixTree = - searchRadixTree False $ \ RadixTree {..} -> - loadHot _radixRoot _radixBuffer _radixCache _radixDatabase - -{-# SPECIALISE searchNonMerkleizedRadixTree - :: ByteString - -> RadixTree LevelDB.DB - -> ResourceT IO (Either RadixError RadixSearchResult) #-} - --------------------------------------------------------------------------------- - --- | --- Insert a value into a radix tree. -insertRadixTree - :: RadixDatabase m database - => ByteString -- ^ Key. - -> ByteString -- ^ Value. - -> RadixTree database -- ^ Radix tree. - -> m (RadixTree database) -insertRadixTree key value tree = - if isEmptyRadixTree tree - then pure $ initializeRadixTree key value tree - else searchNonMerkleizedRadixTree key tree >>= \ case - Left err -> throw err - Right result@(_, _, _, [], [], _) -> - pure $ insertRadixTreeAt result value tree - Right result@(_, _, _, [], _, _) -> - pure $ insertRadixTreeAfter result value tree - Right result@(_, _, _, _, [], _) -> - pure $ insertRadixTreeBefore result value tree - Right result -> - pure $ insertRadixTreeBetween result value tree - -{-# SPECIALISE insertRadixTree - :: ByteString - -> ByteString - -> RadixTree LevelDB.DB - -> ResourceT IO (RadixTree LevelDB.DB) #-} - --------------------------------------------------------------------------------- - --- TODO (enzo): Documentation. -initializeRadixTree - :: ByteString -- ^ Key. - -> ByteString -- ^ Value. - -> RadixTree database -- ^ Radix tree. - -> RadixTree database -initializeRadixTree key value tree@RadixTree {..} = - seq bloom $ setBloom bloom $ setBuffer buffer $ setNonce nonce $ setRoot root tree - where - prefix = createPrefix $ toBits key - node = setPrefix prefix $ Just value `setLeaf` def - root = createRootFromNonce _radixNonce - bloom = Bloom.insert root _radixBloom - nonce = _radixNonce + 1 - buffer = storeHot root node _radixBuffer - -{-# INLINABLE initializeRadixTree #-} - --------------------------------------------------------------------------------- - --- TODO (enzo): Documentation. -insertRadixTreeAt - :: RadixSearchResult -- ^ Search result. - -> ByteString -- ^ Value. - -> RadixTree database -- ^ Radix tree. - -> RadixTree database -insertRadixTreeAt (_:|roots, node:|nodes, prefix:|_, _, _, cache) value tree@RadixTree {..} = - seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setNonce nonce $ setRoot state tree - where - node' = Just value `setLeaf` node - root' = createRootFromNonce _radixNonce - parent = listToMaybe $ zip3 roots nodes prefix - bloom = flip Bloom.insertList _radixBloom $ root':roots - buffer = merkleSpoof root' parent $ storeHot root' node' _radixBuffer - nonce = _radixNonce + 1 - state = bool _radixRoot root' $ isNothing parent - -{-# INLINABLE insertRadixTreeAt #-} - --------------------------------------------------------------------------------- - --- TODO (enzo): Documentation. -insertRadixTreeAfter - :: RadixSearchResult -- ^ Search result. - -> ByteString -- ^ Value. - -> RadixTree database -- ^ Radix tree. - -> RadixTree database -insertRadixTreeAfter (_:|roots, node:|nodes, prefix:|_, _, keyOverflow, cache) value tree@RadixTree {..} = - seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setNonce nonce $ setRoot state tree - where - prefix' = createPrefix $ drop 1 keyOverflow - node' = setPrefix prefix' $ Just value `setLeaf` def - root' = createRootFromNonce _radixNonce - node'' = test `setChild` Just root' $ node - root'' = createRootFromNonce $ _radixNonce + 1 - test = head keyOverflow - parent = listToMaybe $ zip3 roots nodes prefix - bloom = flip Bloom.insertList _radixBloom $ root'':root':roots - buffer = merkleSpoof root'' parent $ storeHot root'' node'' $ storeHot root' node' _radixBuffer - nonce = _radixNonce + 2 - state = bool _radixRoot root'' $ isNothing parent - -{-# INLINABLE insertRadixTreeAfter #-} - --------------------------------------------------------------------------------- - --- TODO (enzo): Documentation. -insertRadixTreeBefore - :: RadixSearchResult -- ^ Search result. - -> ByteString -- ^ Value. - -> RadixTree database -- ^ Radix tree. - -> RadixTree database -insertRadixTreeBefore (_:|roots, node:|nodes, prefix:|_, prefixOverflow, _, cache) value tree@RadixTree {..} = - seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setNonce nonce $ setRoot state tree - where - prefix' = createPrefix $ drop 1 prefixOverflow - node' = setPrefix prefix' node - root' = createRootFromNonce _radixNonce - prefix'' = createPrefix $ drop 1 prefix `bool` prefix $ isNothing parent - node'' = setPrefix prefix'' $ test `setChild` Just root' $ Just value `setLeaf` def - root'' = createRootFromNonce $ _radixNonce + 1 - test = head prefixOverflow - parent = listToMaybe $ zip3 roots nodes prefix - bloom = flip Bloom.insertList _radixBloom $ root'':root':roots - buffer = merkleSpoof root'' parent $ storeHot root'' node'' $ storeHot root' node' _radixBuffer - nonce = _radixNonce + 2 - state = bool _radixRoot root'' $ isNothing parent - -{-# INLINABLE insertRadixTreeBefore #-} - --------------------------------------------------------------------------------- - --- TODO (enzo): Documentation. -insertRadixTreeBetween - :: RadixSearchResult -- ^ Search result. - -> ByteString -- ^ Value. - -> RadixTree database -- ^ Radix tree. - -> RadixTree database -insertRadixTreeBetween (_:|roots, node:|nodes, prefix:|_, prefixOverflow, keyOverflow, cache) value tree@RadixTree {..} = - seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setNonce nonce $ setRoot state tree - where - prefix' = createPrefix $ drop 1 keyOverflow - node' = setPrefix prefix' $ Just value `setLeaf` def - root' = createRootFromNonce _radixNonce - prefix'' = createPrefix $ drop 1 prefixOverflow - node'' = setPrefix prefix'' node - root'' = createRootFromNonce $ _radixNonce + 1 - prefix''' = createPrefix $ drop 1 prefix `bool` prefix $ isNothing parent - node''' = setPrefix prefix''' $ setChildren children def - root''' = createRootFromNonce $ _radixNonce + 2 - test = head keyOverflow - children = bool id swap test (Just root', Just root'') - parent = listToMaybe $ zip3 roots nodes prefix - bloom = flip Bloom.insertList _radixBloom $ root''':root'':root':roots - buffer = merkleSpoof root''' parent $ storeHot root''' node''' $ storeHot root'' node'' $ storeHot root' node' _radixBuffer - nonce = _radixNonce + 3 - state = bool _radixRoot root''' $ isNothing parent - -{-# INLINABLE insertRadixTreeBetween #-} - --------------------------------------------------------------------------------- - --- | --- Delete a value from a radix tree. -deleteRadixTree - :: RadixDatabase m database - => ByteString -- ^ Key. - -> RadixTree database -- ^ Radix tree. - -> m (RadixTree database) -deleteRadixTree key tree@RadixTree {..} = - if isEmptyRadixTree tree - then pure tree - else searchNonMerkleizedRadixTree key tree >>= \ case - Left err -> throw err - Right result@(_, nodes, prefix:|_, [], [], cache) -> - case nodes of - -- No children and no parent. - RadixNode _ Nothing Nothing _:|[] -> - pure $ deleteRadixTreeNoChildrenNoParent result tree - -- No children and parent with leaf. - RadixNode _ Nothing Nothing _:|parent:_ | isJust $ getLeaf parent -> - pure $ deleteRadixTreeNoChildrenParentWithLeaf result tree - -- No children and parent without leaf. - RadixNode _ Nothing Nothing _:|parent:_ -> do - let test = not $ head prefix - let root = fromJust $ getChild test parent - loadHot root _radixBuffer cache _radixDatabase >>= \ case - Nothing -> throw $ StateRootDoesNotExist root - Just (node, cache') -> - pure $ deleteRadixTreeNoChildrenParentWithoutLeaf result node cache' test tree - -- One left child. - RadixNode _ child Nothing _:|_ | isJust child -> do - let test = False - let root = fromJust child - loadHot root _radixBuffer cache _radixDatabase >>= \ case - Nothing -> throw $ StateRootDoesNotExist root - Just (node, cache') -> - pure $ deleteRadixTreeOneChild result node cache' test tree - -- One right child. - RadixNode _ Nothing child _:|_ | isJust child -> do - let test = True - let root = fromJust child - loadHot root _radixBuffer cache _radixDatabase >>= \ case - Nothing -> throw $ StateRootDoesNotExist root - Just (node, cache') -> - pure $ deleteRadixTreeOneChild result node cache' test tree - -- Two children. - _ -> pure $ deleteRadixTreeTwoChildren result tree - Right _ -> pure tree - -{-# SPECIALISE deleteRadixTree - :: ByteString - -> RadixTree LevelDB.DB - -> ResourceT IO (RadixTree LevelDB.DB) #-} - --------------------------------------------------------------------------------- - --- TODO (enzo): Documentation. -deleteRadixTreeNoChildrenNoParent - :: RadixSearchResult -- ^ Search result. - -> RadixTree database -- ^ Radix tree. - -> RadixTree database -deleteRadixTreeNoChildrenNoParent (_, _, _, _, _, cache) tree@RadixTree {..} = - seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setRoot state tree - where - bloom = Bloom.insert defaultRoot _radixBloom - buffer = storeHot defaultRoot def _radixBuffer - state = defaultRoot - -{-# INLINABLE deleteRadixTreeNoChildrenNoParent #-} - --------------------------------------------------------------------------------- - --- TODO (enzo): Documentation. -deleteRadixTreeNoChildrenParentWithLeaf - :: RadixSearchResult -- ^ Search result. - -> RadixTree database -- ^ Radix tree. - -> RadixTree database -deleteRadixTreeNoChildrenParentWithLeaf (_:|_:roots, _:|node:nodes, prefix:|prefixes, _, _, cache) tree@RadixTree {..} = - seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setNonce nonce $ setRoot state tree - where - node' = setChild test Nothing node - root' = createRootFromNonce _radixNonce - test = head prefix - parent = listToMaybe $ zip3 roots nodes $ map head prefixes - bloom = flip Bloom.insertList _radixBloom $ root':roots - buffer = merkleSpoof root' parent $ storeHot root' node' _radixBuffer - nonce = _radixNonce + 1 - state = bool _radixRoot root' $ isNothing parent -deleteRadixTreeNoChildrenParentWithLeaf _ _ = - throw $ InvalidArgument "unknown parent" - -{-# INLINABLE deleteRadixTreeNoChildrenParentWithLeaf #-} - --------------------------------------------------------------------------------- - --- TODO (enzo): Documentation. -deleteRadixTreeNoChildrenParentWithoutLeaf - :: RadixSearchResult -- ^ Search result. - -> RadixNode -- ^ Radix node. - -> RadixCache -- ^ Radix cache. - -> Bool -- ^ Lineage. - -> RadixTree database -- ^ Radix tree. - -> RadixTree database -deleteRadixTreeNoChildrenParentWithoutLeaf (_:|_:roots, _:|_:nodes, _:|prefixes, _, _, _) node@RadixNode {..} cache test tree@RadixTree {..} = - seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setNonce nonce $ setRoot state tree - where - prefix' = createPrefix $ drop 1 bits `bool` bits $ isNothing parent - node' = setPrefix prefix' node - root' = createRootFromNonce _radixNonce - bits = head prefixes ++ test:maybe [] toBits _radixPrefix - parent = listToMaybe $ zip3 roots nodes $ map head prefixes - bloom = flip Bloom.insertList _radixBloom $ root':roots - buffer = merkleSpoof root' parent $ storeHot root' node' _radixBuffer - nonce = _radixNonce + 1 - state = bool _radixRoot root' $ isNothing parent -deleteRadixTreeNoChildrenParentWithoutLeaf _ _ _ _ _ = - throw $ InvalidArgument "unknown parent" - -{-# INLINABLE deleteRadixTreeNoChildrenParentWithoutLeaf #-} - --------------------------------------------------------------------------------- - --- TODO (enzo): Documentation. -deleteRadixTreeOneChild - :: RadixSearchResult -- ^ Search result. - -> RadixNode -- ^ Radix node. - -> RadixCache -- ^ Radix cache. - -> Bool -- ^ Lineage. - -> RadixTree database -- ^ Radix tree. - -> RadixTree database -deleteRadixTreeOneChild (_:|roots, _:|nodes, prefix:|_, _, _, _) node@RadixNode {..} cache test tree@RadixTree {..} = - seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setNonce nonce $ setRoot state tree - where - prefix' = createPrefix $ drop 1 bits `bool` bits $ isNothing parent - node' = setPrefix prefix' node - root' = createRootFromNonce _radixNonce - bits = prefix ++ test:maybe [] toBits _radixPrefix - parent = listToMaybe $ zip3 roots nodes prefix - bloom = flip Bloom.insertList _radixBloom $ root':roots - buffer = merkleSpoof root' parent $ storeHot root' node' _radixBuffer - nonce = _radixNonce + 1 - state = bool _radixRoot root' $ isNothing parent - -{-# INLINABLE deleteRadixTreeOneChild #-} - --------------------------------------------------------------------------------- - --- TODO (enzo): Documentation. -deleteRadixTreeTwoChildren - :: RadixSearchResult -- ^ Search result. - -> RadixTree database -- ^ Radix tree. - -> RadixTree database -deleteRadixTreeTwoChildren (_:|roots, node:|nodes, prefix:|_, _, _, cache) tree@RadixTree {..} = - seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setNonce nonce $ setRoot state tree - where - node' = setLeaf Nothing node - root' = createRootFromNonce _radixNonce - parent = listToMaybe $ zip3 roots nodes prefix - bloom = flip Bloom.insertList _radixBloom $ root':roots - buffer = merkleSpoof root' parent $ storeHot root' node' _radixBuffer - nonce = _radixNonce + 1 - state = bool _radixRoot root' $ isNothing parent - -{-# INLINABLE deleteRadixTreeTwoChildren #-} - --------------------------------------------------------------------------------- - --- | --- Lookup a value in a radix tree. -lookupRadixTree - :: RadixDatabase m database - => ByteString -- ^ Key. - -> RadixTree database -- ^ Radix tree. - -> m (Maybe (ByteString, RadixTree database)) -lookupRadixTree key tree = do - found <- searchNonMerkleizedRadixTree key tree - case found of - Left err -> throw err - Right (_, RadixNode {..}:|_, _, prefixOverflow, keyOverflow, cache') -> - if not $ null prefixOverflow && null keyOverflow - then pure Nothing - else pure $ do - value <- _radixLeaf - let tree' = setCache cache' tree - pure (value, tree') - -{-# SPECIALISE lookupRadixTree - :: ByteString - -> RadixTree LevelDB.DB - -> ResourceT IO (Maybe (ByteString, RadixTree LevelDB.DB)) #-} - --------------------------------------------------------------------------------- - --- | --- Mask a node in a Merkleized radix tree. -merkleSpoof - :: RadixRoot -- ^ State root. - -> Maybe (RadixRoot, RadixNode, Bool) -- ^ Parent. - -> RadixBuffer -- ^ Buffer. - -> RadixBuffer -merkleSpoof mask = \ case - Nothing -> id - Just (root, node, test) -> - storeHot root $ test `setChild` Just mask $ node - -{-# INLINABLE merkleSpoof #-} - --------------------------------------------------------------------------------- - --- | --- Merkleize a radix tree. This will flush the buffer to the database. -merkleizeRadixTree - :: RadixDatabase m database - => RadixTree database-- ^ Radix tree. - -> m (RadixRoot, RadixTree database) -merkleizeRadixTree RadixTree {..} = do - (root, cache) <- loop _radixRoot _radixCache - let tree = RadixTree bloom _radixBloomSize Map.empty cache _radixCacheSize root _radixDatabase 0 root - pure (root, tree) - where - bloom = emptyRadixBloom _radixBloomSize - loop root cache = - if not $ Bloom.elem root _radixBloom - then pure (root, cache) - else do - -- Load the root node. - result <- loadHot root _radixBuffer cache _radixDatabase - case result of - Nothing -> throw $ StateRootDoesNotExist root - Just (node@RadixNode {..}, cache') -> - case (_radixLeft, _radixRight) of - -- No children. - (Nothing, Nothing) -> - storeCold node cache' _radixDatabase - -- One left child. - (Just child, Nothing) -> do - (root', cache'') <- loop child cache' - let node' = False `setChild` Just root' $ node - storeCold node' cache'' _radixDatabase - -- One right child. - (Nothing, Just child) -> do - (root', cache'') <- loop child cache' - let node' = True `setChild` Just root' $ node - storeCold node' cache'' _radixDatabase - -- Two children. - (Just left, Just right) -> do - (root', cache'') <- loop left cache' - (root'', cache''') <- loop right cache'' - let node' = setChildren (Just root', Just root'') node - storeCold node' cache''' _radixDatabase - -{-# SPECIALISE merkleizeRadixTree - :: RadixTree LevelDB.DB - -> ResourceT IO (RadixRoot, RadixTree LevelDB.DB) #-} - --------------------------------------------------------------------------------- - --- | --- Get the contents of a radix tree. -contentsRadixTree' - :: RadixDatabase m database - => Bool -- ^ Overwrite state root? - -> (RadixTree database -> m (Maybe (RadixNode, RadixCache))) -- ^ Loading strategy. - -> RadixTree database -- ^ Radix tree. - -> m [(ByteString, ByteString)] -contentsRadixTree' flag strategy = \ tree@RadixTree {..} -> do - let tree' = tree `bool` setRoot _radixCheckpoint tree $ flag - loop tree' [] [] where - loop tree@RadixTree {..} prefix accum = do - result <- strategy tree - case fst <$> result of - Nothing -> throw $ StateRootDoesNotExist _radixRoot - Just RadixNode {..} -> do - let prefix' = prefix ++ maybe [] toBits _radixPrefix - let key = fromBits prefix' - let accum' = maybe accum (\ value -> (key, value):accum) _radixLeaf - let children = [(,False) <$> _radixLeft, (,True) <$> _radixRight] - flip foldM accum' `flip` children $ \ accum'' -> \ case - Nothing -> pure accum'' - Just (root, test) -> do - let tree' = setRoot root tree - let prefix'' = prefix' ++ [test] - loop tree' prefix'' accum'' - -{-# SPECIALISE contentsRadixTree' - :: Bool - -> (RadixTree LevelDB.DB - -> ResourceT IO (Maybe (RadixNode, RadixCache))) - -> RadixTree LevelDB.DB - -> ResourceT IO [(ByteString, ByteString)] #-} - --------------------------------------------------------------------------------- - --- | --- A convenient alias for `contentsNonMerkleizedRadixTree`. -contentsRadixTree - :: RadixDatabase m database - => RadixTree database -- ^ Radix tree. - -> m [(ByteString, ByteString)] -contentsRadixTree = contentsNonMerkleizedRadixTree - -{-# SPECIALISE contentsRadixTree - :: RadixTree LevelDB.DB - -> ResourceT IO [(ByteString, ByteString)] #-} - --------------------------------------------------------------------------------- - --- | --- Get the contents of a Merkleized radix tree. -contentsMerkleizedRadixTree - :: RadixDatabase m database - => RadixTree database -- ^ Radix tree. - -> m [(ByteString, ByteString)] -contentsMerkleizedRadixTree = - contentsRadixTree' True $ \ RadixTree {..} -> - loadCold _radixRoot _radixCache _radixDatabase - -{-# SPECIALISE contentsMerkleizedRadixTree - :: RadixTree LevelDB.DB - -> ResourceT IO [(ByteString, ByteString)] #-} - --------------------------------------------------------------------------------- - --- | --- Get the contents of a non-Merkleized radix tree. -contentsNonMerkleizedRadixTree - :: RadixDatabase m database - => RadixTree database -- ^ Radix tree. - -> m [(ByteString, ByteString)] -contentsNonMerkleizedRadixTree = - contentsRadixTree' False $ \ RadixTree {..} -> - loadHot _radixRoot _radixBuffer _radixCache _radixDatabase - -{-# SPECIALISE contentsNonMerkleizedRadixTree - :: RadixTree LevelDB.DB - -> ResourceT IO [(ByteString, ByteString)] #-} - --------------------------------------------------------------------------------- - --- | --- Print a radix tree. -printRadixTree' - :: MonadIO m - => RadixDatabase m database - => Bool -- ^ Overwrite state root? - -> (RadixTree database -> m (Maybe (RadixNode, RadixCache))) -- ^ Loading strategy. - -> RadixTree database -- ^ Radix tree. - -> m () -printRadixTree' flag strategy = \ tree@RadixTree {..} -> do - let tree' = tree `bool` setRoot _radixCheckpoint tree $ flag - loop tree' 0 where - loop tree@RadixTree {..} i = do - result <- strategy tree - case fst <$> result of - Nothing -> throw $ StateRootDoesNotExist _radixRoot - Just node@RadixNode {..} -> do - let indent = (++) $ concat $ replicate i "｜" - liftIO $ putStrLn $ indent $ show node - let j = i + 1 - forM_ [_radixLeft, _radixRight] $ \ case - Nothing -> pure () - Just root -> setRoot root tree `loop` j - -{-# SPECIALISE printRadixTree' - :: Bool - -> (RadixTree LevelDB.DB - -> ResourceT IO (Maybe (RadixNode, RadixCache))) - -> RadixTree LevelDB.DB - -> ResourceT IO () #-} - --------------------------------------------------------------------------------- - --- | --- A convenient alias for `printNonMerkleizedRadixTree`. -printRadixTree - :: MonadIO m - => RadixDatabase m database - => RadixTree database -- ^ Radix tree. - -> m () -printRadixTree = printNonMerkleizedRadixTree - -{-# SPECIALISE printRadixTree - :: RadixTree LevelDB.DB - -> ResourceT IO () #-} - --------------------------------------------------------------------------------- - --- | --- Print a Merkleized radix tree. -printMerkleizedRadixTree - :: MonadIO m - => RadixDatabase m database - => RadixTree database -- ^ Radix tree. - -> m () -printMerkleizedRadixTree = - printRadixTree' True $ \ RadixTree {..} -> - loadCold _radixRoot _radixCache _radixDatabase - -{-# SPECIALISE printMerkleizedRadixTree - :: RadixTree LevelDB.DB - -> ResourceT IO () #-} - --------------------------------------------------------------------------------- - --- | --- Print a non-Merkleized radix tree. -printNonMerkleizedRadixTree - :: MonadIO m - => RadixDatabase m database - => RadixTree database -- ^ Radix tree. - -> m () -printNonMerkleizedRadixTree = - printRadixTree' False $ \ RadixTree {..} -> - loadHot _radixRoot _radixBuffer _radixCache _radixDatabase - -{-# SPECIALISE printNonMerkleizedRadixTree - :: RadixTree LevelDB.DB - -> ResourceT IO () #-} - --------------------------------------------------------------------------------- diff --git a/src/Network/DFINITY/RadixTree/Bits.hs b/src/Network/DFINITY/RadixTree/Bits.hs deleted file mode 100644 --- a/src/Network/DFINITY/RadixTree/Bits.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# OPTIONS -Wall #-} -{-# OPTIONS -Werror #-} - -module Network.DFINITY.RadixTree.Bits - ( Bitable(..) - , matchBits - ) where - -import Data.Bits ((.|.), setBit, testBit) -import Data.Bool (bool) -import Data.ByteString (ByteString, pack, unpack) -import Data.Word (Word8) - -class Bitable a where - fromBits :: [Bool] -> a - toBits :: a -> [Bool] - -instance Bitable ByteString where - fromBits = pack . go where - go [] = [] - go xs = let (a, b) = splitAt 8 xs in toByte a : go b - toBits = concatMap fromByte . unpack - -matchBits :: [Bool] -> [Bool] -> [Bool] -matchBits x = map fst . zipWhile (==) x - -zipWhile :: (a -> b -> Bool) -> [a] -> [b] -> [(a,b)] -zipWhile f x = takeWhile (uncurry f) . zip x - -fromByte :: Word8 -> [Bool] -fromByte = flip map order . testBit - -toByte :: [Bool] -> Word8 -toByte = foldl (.|.) 0 . zipWith (bool 0 . setBit 0) order - -order :: Enum a => Num a => [a] -order = [7, 6.. 0] diff --git a/src/Network/DFINITY/RadixTree/Bloom.hs b/src/Network/DFINITY/RadixTree/Bloom.hs deleted file mode 100644 --- a/src/Network/DFINITY/RadixTree/Bloom.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} - -{-# OPTIONS -Wall #-} -{-# OPTIONS -Werror #-} - -module Network.DFINITY.RadixTree.Bloom - ( emptyRadixBloom - ) where - -import Data.BloomFilter (empty) -import Data.ByteString.Short.Internal (ShortByteString(..)) -import Data.Word (Word32) -import GHC.Prim (ByteArray#, Int#, (-#), indexWord32Array#, quotInt#, sizeofByteArray#) -import GHC.Word (Word32(..)) - -import Network.DFINITY.RadixTree.Types - -emptyRadixBloom :: Int -> RadixBloom -emptyRadixBloom = empty hash - -hash :: RadixRoot -> [Word32] -hash = \ case - SBS bytes# -> - let n# = sizeofByteArray# bytes# - m# = quotInt# n# 4# - in hash# bytes# m# - -hash# :: ByteArray# -> Int# -> [Word32] -hash# bytes# = \ case - 0# -> [] - i# -> - let j# = i# -# 1# - w# = indexWord32Array# bytes# j# - in W32# w# : hash# bytes# j# diff --git a/src/Network/DFINITY/RadixTree/Conduit.hs b/src/Network/DFINITY/RadixTree/Conduit.hs deleted file mode 100644 --- a/src/Network/DFINITY/RadixTree/Conduit.hs +++ /dev/null @@ -1,230 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# OPTIONS -Wall #-} -{-# OPTIONS -Werror #-} - --- | --- Module : Network.DFINITY.RadixTree.Conduit --- Copyright : 2018 DFINITY Stiftung --- License : GPL-3 --- Maintainer : Enzo Haussecker --- Stability : Stable --- --- A parallel download protocol. -module Network.DFINITY.RadixTree.Conduit ( - - -- ** Combinators - sourceRadixTree - , sinkRadixTree - - ) where - -import Codec.Serialise (deserialise, deserialiseOrFail) -import Control.Concurrent (forkIO, killThread) -import Control.Concurrent.BoundedChan (BoundedChan, readChan, tryWriteChan) -import Control.Concurrent.MVar (modifyMVar_, newMVar, readMVar) -import Control.Concurrent.ReadWriteLock (RWLock) -import Control.Exception (throw) -import Control.Monad (foldM, forM_, forever, void, when) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Resource (MonadResource, ResourceT, allocate, release) -import Crypto.Hash.BLAKE2.BLAKE2s (hash) -import Data.ByteString (ByteString) -import Data.ByteString.Lazy (fromStrict) -import Data.ByteString.Short (ShortByteString, fromShort, toShort) -import Data.Conduit (ConduitT, await, yield) -import Data.List as List (delete, null) -import Data.LruCache as LRU (empty, insert, lookup) -import Data.Map as Map (Map, (!), delete, empty, insert, keys, lookup, member, null, singleton) -import Data.Maybe (isJust) -import Data.Void (Void) -import Database.LevelDB (DB) - -import Network.DFINITY.RadixTree.Bits -import Network.DFINITY.RadixTree.Lenses -import Network.DFINITY.RadixTree.Lock -import Network.DFINITY.RadixTree.Types - --------------------------------------------------------------------------------- - --- | --- Create a conduit from a radix tree. -sourceRadixTree - :: forall m database. MonadResource m - => RadixDatabase (ConduitT () ByteString m) database - => [Bool] -- ^ Bit mask. - -> Int -- ^ LRU cache size in items. - -> BoundedChan RadixRoot -- ^ Terminal state root producer. - -> RadixTree database -- ^ Radix tree. - -> RWLock -- ^ Database lock. - -> ConduitT () ByteString m () -sourceRadixTree mask cacheSize chan tree lock - | cacheSize <= 0 = throw $ InvalidArgument "invalid LRU cache size" - | otherwise = do - cache <- liftIO $ newMVar $ LRU.empty cacheSize - action <- fmap fst $ flip allocate killThread $ forkIO $ forever $ do - root <- readChan chan - modifyMVar_ cache $ pure . LRU.insert root () - loop cache tree [] - release action - where - loop cache subtree@RadixTree {..} accum = do - let accum' = _radixCheckpoint:accum - seen <- liftIO $ readMVar cache - if flip any accum' $ isJust . flip LRU.lookup seen - then pure () - else do - let key = fromShort _radixCheckpoint - result <- withReadLock lock $ load _radixDatabase key - case result of - Nothing -> pure () - Just bytes -> do - let RadixNode {..} = deserialise $ fromStrict bytes - let success = all id $ zipWith (==) mask $ toBits $ fromShort _radixCheckpoint - when success $ yield bytes - forM_ [_radixLeft, _radixRight] $ \ case - Nothing -> pure () - Just root -> loop cache `flip` accum' $ setCheckpoint root subtree - -{-# SPECIALISE sourceRadixTree - :: [Bool] - -> Int - -> BoundedChan RadixRoot - -> RadixTree DB - -> RWLock - -> ConduitT () ByteString (ResourceT IO) () #-} - --------------------------------------------------------------------------------- - --- | --- Create a radix tree from a conduit. -sinkRadixTree - :: forall m database. MonadResource m - => RadixDatabase (ConduitT ByteString Void m) database - => RadixRoot -- ^ Target state root. - -> BoundedChan RadixRoot -- ^ Terminal state root consumer. - -> RadixTree database -- ^ Radix tree. - -> RWLock -- ^ Database lock. - -> ConduitT ByteString Void m (Either [RadixRoot] (RadixTree database)) -sinkRadixTree checkpoint chan tree@RadixTree {..} lock = - loop1 Map.empty $ Map.singleton checkpoint Nothing - where - - -- Loop 1: The accumulation loop. - loop1 - :: Map RadixRoot (ShortByteString, [RadixRoot]) - -> Map RadixRoot (Maybe RadixRoot) - -> ConduitT ByteString Void m (Either [RadixRoot] (RadixTree database)) - loop1 buffer targets = - -- Have we found all the subtrees? - if Map.null targets - then pure $ Right $ setCheckpoint checkpoint $ setRoot checkpoint tree - else do - -- Wait for a node. - mval <- await - case mval of - Nothing -> pure $ Left $ Map.keys targets - Just bytes -> - case deserialiseOrFail $ fromStrict bytes of - Left _ -> loop1 buffer targets - Right RadixNode {..} -> do - -- Does the node already exist in the database? - let key = hash 20 mempty bytes - let root = toShort key - let want = Map.member root targets - exists <- if want - then pure False - else do - result <- withReadLock lock $ load _radixDatabase key - pure $ isJust result - if exists - then do - -- Announce a terminal state root. - liftIO $ void $ tryWriteChan chan root - -- Update the targets to exclude the node. - let targets' = Map.delete root targets - loop1 buffer targets' - else do - -- Update the buffer to include the node. - children <- foldM step [] $ maybe id (:) _radixLeft $ maybe id (:) _radixRight [] - let buffer' = Map.insert root (toShort bytes, children) buffer - -- Can we trace the node back to the target state root? - if want - then loop3 buffer' `uncurry` loop2 buffer' root (targets, []) - else loop1 buffer' targets - where - step accum root = do - let key = fromShort root - result <- withReadLock lock $ load _radixDatabase key - if isJust result - then pure accum - else pure $ root:accum - - -- Loop 2: The aggregation loop. - loop2 - :: Map RadixRoot (ShortByteString, [RadixRoot]) - -> RadixRoot - -> (Map RadixRoot (Maybe RadixRoot), [(RadixRoot, ShortByteString)]) - -> (Map RadixRoot (Maybe RadixRoot), [(RadixRoot, ShortByteString)]) - loop2 buffer root accum@(targets, candidates) = - -- Get the node from the buffer and analyze. - case Map.lookup root buffer of - Nothing -> accum - Just (bytes, []) -> - -- The node is now a candidate. - let candidates' = (root, bytes):candidates - in (targets, candidates') - Just (_, children) -> - -- The children are now targets. - let targets' = foldr step1 targets children - in foldl step2 (targets', candidates) children - where - step1 = flip Map.insert $ Just root - step2 = flip $ loop2 buffer - - -- Loop 3: The write loop. - loop3 - :: Map RadixRoot (ShortByteString, [RadixRoot]) - -> Map RadixRoot (Maybe RadixRoot) - -> [(RadixRoot, ShortByteString)] - -> ConduitT ByteString Void m (Either [RadixRoot] (RadixTree database)) - loop3 buffer targets = \ case - [] -> loop1 buffer targets - (root, bytes):candidates' -> do - -- Write the node to the database. - let key = fromShort root - withWriteLock lock $ store _radixDatabase key $ fromShort bytes - -- Remove all references to the node. - let buffer' = Map.delete root buffer - let targets' = Map.delete root targets - -- Inspect the parent node. - case targets ! root of - Nothing -> loop3 buffer' targets' candidates' - Just root' -> do - let (bytes', siblings') = buffer ! root' - let children' = List.delete root siblings' - -- Has the sibling node been written to the database? - if List.null children' - then loop3 buffer' targets' $ (root', bytes'):candidates' - else do - -- Announce a terminal state root. - liftIO $ void $ tryWriteChan chan root - -- Update the parent node. - let buffer'' = Map.insert root' (bytes', children') buffer' - loop3 buffer'' targets' candidates' - -{-# SPECIALISE sinkRadixTree - :: RadixRoot - -> BoundedChan RadixRoot - -> RadixTree DB - -> RWLock - -> ConduitT ByteString - Void - (ResourceT IO) - (Either [RadixRoot] (RadixTree DB)) #-} - --------------------------------------------------------------------------------- diff --git a/src/Network/DFINITY/RadixTree/Lenses.hs b/src/Network/DFINITY/RadixTree/Lenses.hs deleted file mode 100644 --- a/src/Network/DFINITY/RadixTree/Lenses.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -{-# OPTIONS -Wall #-} -{-# OPTIONS -Werror #-} -{-# OPTIONS -fno-warn-missing-signatures #-} -{-# OPTIONS -fno-warn-unused-top-binds #-} - -module Network.DFINITY.RadixTree.Lenses - ( getPrefix - , getLeft - , getRight - , getChild - , getChildren - , getLeaf - , getBloom - , getBuffer - , getCache - , getCheckpoint - , getNonce - , getRoot - , setPrefix - , setLeft - , setRight - , setChild - , setChildren - , setLeaf - , setBloom - , setBuffer - , setCache - , setCheckpoint - , setNonce - , setRoot - ) where - -import Data.Bool (bool) -import Data.ByteString (ByteString) -import Lens.Simple (makeLenses, set, view) - -import Network.DFINITY.RadixTree.Types - -makeLenses ''RadixNode -makeLenses ''RadixTree - -getPrefix :: RadixNode -> Maybe RadixPrefix -getPrefix = view radixPrefix - -getLeft :: RadixNode -> Maybe RadixRoot -getLeft = view radixLeft - -getRight :: RadixNode -> Maybe RadixRoot -getRight = view radixRight - -getChild :: Bool -> RadixNode -> Maybe RadixRoot -getChild = bool getLeft getRight - -getChildren :: RadixNode -> (Maybe RadixRoot, Maybe RadixRoot) -getChildren node = (getLeft node, getRight node) - -getLeaf :: RadixNode -> Maybe ByteString -getLeaf = view radixLeaf - -getBloom :: RadixTree database -> RadixBloom -getBloom = view radixBloom - -getBuffer :: RadixTree database -> RadixBuffer -getBuffer = view radixBuffer - -getCache :: RadixTree database -> RadixCache -getCache = view radixCache - -getCheckpoint :: RadixTree database -> RadixRoot -getCheckpoint = view radixCheckpoint - -getNonce :: RadixTree database -> Word -getNonce = view radixNonce - -getRoot :: RadixTree database -> RadixRoot -getRoot = view radixRoot - -setPrefix :: Maybe RadixPrefix -> RadixNode -> RadixNode -setPrefix = set radixPrefix - -setLeft :: Maybe RadixRoot -> RadixNode -> RadixNode -setLeft = set radixLeft - -setRight :: Maybe RadixRoot -> RadixNode -> RadixNode -setRight = set radixRight - -setChild :: Bool -> Maybe RadixRoot -> RadixNode -> RadixNode -setChild = bool setLeft setRight - -setChildren :: (Maybe RadixRoot, Maybe RadixRoot) -> RadixNode -> RadixNode -setChildren (left, right) = setLeft left . setRight right - -setLeaf :: Maybe ByteString -> RadixNode -> RadixNode -setLeaf = set radixLeaf - -setBloom :: RadixBloom -> RadixTree database -> RadixTree database -setBloom = set radixBloom - -setBuffer :: RadixBuffer -> RadixTree database -> RadixTree database -setBuffer = set radixBuffer - -setCache :: RadixCache -> RadixTree database -> RadixTree database -setCache = set radixCache - -setCheckpoint :: RadixRoot -> RadixTree database -> RadixTree database -setCheckpoint = set radixCheckpoint - -setNonce :: Word -> RadixTree database -> RadixTree database -setNonce = set radixNonce - -setRoot :: RadixRoot -> RadixTree database -> RadixTree database -setRoot = set radixRoot diff --git a/src/Network/DFINITY/RadixTree/Lock.hs b/src/Network/DFINITY/RadixTree/Lock.hs deleted file mode 100644 --- a/src/Network/DFINITY/RadixTree/Lock.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# OPTIONS -Wall #-} -{-# OPTIONS -Werror #-} - -module Network.DFINITY.RadixTree.Lock - ( withReadLock - , withWriteLock - ) where - -import Control.Concurrent.ReadWriteLock (RWLock, acquireRead, acquireWrite, releaseRead, releaseWrite) -import Control.Monad.Trans.Resource (MonadResource, allocate, release) - -withReadLock :: MonadResource m => RWLock -> m a -> m a -withReadLock lock action = do - key <- fst <$> allocate acquireLock releaseLock - result <- action - release key - pure result - where - acquireLock = acquireRead lock - releaseLock = const $ releaseRead lock - -withWriteLock :: MonadResource m => RWLock -> m a -> m a -withWriteLock lock action = do - key <- fst <$> allocate acquireLock releaseLock - result <- action - release key - pure result - where - acquireLock = acquireWrite lock - releaseLock = const $ releaseWrite lock diff --git a/src/Network/DFINITY/RadixTree/Memory.hs b/src/Network/DFINITY/RadixTree/Memory.hs deleted file mode 100644 --- a/src/Network/DFINITY/RadixTree/Memory.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# OPTIONS -Wall #-} -{-# OPTIONS -Werror #-} - -module Network.DFINITY.RadixTree.Memory - ( loadHot - , loadCold - , storeHot - , storeCold - ) where - -import Codec.Serialise (deserialise, serialise) -import Control.Monad.Trans.Resource (ResourceT) -import Crypto.Hash.BLAKE2.BLAKE2s (hash) -import Data.ByteString.Lazy (fromStrict, toStrict) -import Data.ByteString.Short (fromShort, toShort) -import Data.LruCache as LRU (insert, lookup) -import Data.Map.Strict as Map (insert, lookup) -import Database.LevelDB (DB) - -import Network.DFINITY.RadixTree.Types - --------------------------------------------------------------------------------- - -loadHot - :: RadixDatabase m database - => RadixRoot - -> RadixBuffer - -> RadixCache - -> database - -> m (Maybe (RadixNode, RadixCache)) -loadHot root buffer cache database = - case Map.lookup root buffer of - Just node -> pure $ Just (node, cache) - Nothing -> loadCold root cache database - -{-# SPECIALISE loadHot - :: RadixRoot - -> RadixBuffer - -> RadixCache - -> DB - -> ResourceT IO (Maybe (RadixNode, RadixCache)) #-} - --------------------------------------------------------------------------------- - -loadCold - :: RadixDatabase m database - => RadixRoot - -> RadixCache - -> database - -> m (Maybe (RadixNode, RadixCache)) -loadCold root cache database = - case LRU.lookup root cache of - Just (node, cache') -> - seq cache' $ seq node $ pure $ Just (node, cache') - Nothing -> do - let key = fromShort root - result <- load database key - case result of - Just bytes -> do - let node = deserialise $ fromStrict bytes - let cache' = LRU.insert root node cache - seq cache' $ seq node $ pure $ Just (node, cache') - Nothing -> pure $ Nothing - -{-# SPECIALISE loadCold - :: RadixRoot - -> RadixCache - -> DB - -> ResourceT IO (Maybe (RadixNode, RadixCache)) #-} - --------------------------------------------------------------------------------- - -storeHot - :: RadixRoot - -> RadixNode - -> RadixBuffer - -> RadixBuffer -storeHot = Map.insert - --------------------------------------------------------------------------------- - -storeCold - :: RadixDatabase m database - => RadixNode - -> RadixCache - -> database - -> m (RadixRoot, RadixCache) -storeCold node cache database = do - store database key bytes - seq cache' $ pure (root, cache') - where - bytes = toStrict $ serialise node - key = hash 20 mempty bytes - root = toShort key - cache' = LRU.insert root node cache - -{-# SPECIALISE storeCold - :: RadixNode - -> RadixCache - -> DB - -> ResourceT IO (RadixRoot, RadixCache) #-} - --------------------------------------------------------------------------------- diff --git a/src/Network/DFINITY/RadixTree/Serialise.hs b/src/Network/DFINITY/RadixTree/Serialise.hs deleted file mode 100644 --- a/src/Network/DFINITY/RadixTree/Serialise.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -{-# OPTIONS -Wall #-} -{-# OPTIONS -Werror #-} - -module Network.DFINITY.RadixTree.Serialise - ( decodeLeaf - , decodeMaybe - , decodeSide - , encodeMaybe - , encodeSide - ) where - -import Codec.Serialise (Serialise) -import Codec.Serialise.Decoding (Decoder, TokenType(..), decodeBytes, decodeNull, decodeTag, peekTokenType) -import Codec.Serialise.Encoding (Encoding, encodeBytes, encodeNull, encodeTag) -import Control.Monad (void) -import Data.ByteString.Char8 (ByteString) -import Data.Monoid ((<>)) - -decodeLeaf :: Int -> Decoder s (Maybe ByteString) -decodeLeaf = \ case - 3 -> pure Nothing - 4 -> pure <$> decodeBytes - _ -> fail "decodeLeaf: invalid argument" - -decodeMaybe :: Serialise a => Decoder s a -> Decoder s (Maybe a) -decodeMaybe value = peekTokenType >>= \ case - TypeNull -> decodeNull >> pure Nothing - _ -> pure <$> value - -decodeSide :: Decoder s ByteString -decodeSide = void decodeTag >> decodeBytes - -encodeMaybe :: Serialise a => (a -> Encoding) -> Maybe a -> Encoding -encodeMaybe = maybe encodeNull - -encodeSide :: ByteString -> Encoding -encodeSide side = encodeTag 42 <> encodeBytes side diff --git a/src/Network/DFINITY/RadixTree/Types.hs b/src/Network/DFINITY/RadixTree/Types.hs deleted file mode 100644 --- a/src/Network/DFINITY/RadixTree/Types.hs +++ /dev/null @@ -1,192 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecordWildCards #-} - -{-# OPTIONS -Wall #-} -{-# OPTIONS -Werror #-} - -module Network.DFINITY.RadixTree.Types - ( RadixBloom - , RadixBuffer - , RadixCache - , RadixDatabase(..) - , RadixError(..) - , RadixNode(..) - , RadixPrefix(..) - , RadixRoot - , RadixSearchResult - , RadixTree(..) - ) where - -import Codec.Serialise as CBOR (Serialise(..), serialise) -import Codec.Serialise.Decoding (decodeBytes, decodeInt, decodeListLen) -import Codec.Serialise.Encoding (encodeBytes, encodeInt, encodeListLen) -import Control.DeepSeq (NFData(..)) -import Control.Exception (Exception) -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.ST (ST) -import Control.Monad.State.Strict as StateT (StateT, get, modify) -import Crypto.Hash.BLAKE2.BLAKE2s (hash) -import Data.BloomFilter (Bloom) -import Data.Bool (bool) -import Data.ByteString.Base16 as Base16 (encode) -import Data.ByteString.Char8 (ByteString, unpack) -import Data.ByteString.Lazy (toStrict) -import Data.ByteString.Short (ShortByteString, fromShort, toShort) -import Data.Data (Data) -import Data.Default.Class (Default(..)) -import Data.IORef (IORef, readIORef, modifyIORef') -import Data.List.NonEmpty (NonEmpty) -import Data.LruCache (LruCache) -import Data.Map.Strict as Map (Map, insert, lookup) -import Data.Maybe (isJust) -import Data.Monoid ((<>)) -import Data.STRef (STRef, readSTRef, modifySTRef') -import Text.Printf (printf) - -import qualified Database.LevelDB as LevelDB -import qualified Database.LMDB.Simple as LMDB - -import Network.DFINITY.RadixTree.Bits -import Network.DFINITY.RadixTree.Serialise - -type RadixBloom = Bloom RadixRoot - -type RadixBuffer = Map RadixRoot RadixNode - -type RadixCache = LruCache RadixRoot RadixNode - -class Monad m => RadixDatabase m database where - load :: database -> ByteString -> m (Maybe ByteString) - store :: database -> ByteString -> ByteString -> m () - -instance Monad m => RadixDatabase (StateT (Map ByteString ByteString) m) () where - load () key = Map.lookup key <$> StateT.get - store () key = StateT.modify . Map.insert key - -instance RadixDatabase (ST s) (STRef s (Map ByteString ByteString)) where - load db key = Map.lookup key <$> readSTRef db - store db key val = modifySTRef' db $ Map.insert key val - -instance MonadIO m => RadixDatabase m (IORef (Map ByteString ByteString)) where - load db key = liftIO $ Map.lookup key <$> readIORef db - store db key val = liftIO $ modifyIORef' db $ Map.insert key val - -instance MonadIO m => RadixDatabase m LevelDB.DB where - load db = LevelDB.get db LevelDB.defaultReadOptions - store db = LevelDB.put db LevelDB.defaultWriteOptions - -instance RadixDatabase (LMDB.Transaction LMDB.ReadWrite) (LMDB.Database ByteString ByteString) where - load db key = LMDB.get db key - store db key val = LMDB.put db key $ Just val - -data RadixError - = InvalidArgument String - | StateRootDoesNotExist RadixRoot - deriving (Data, Eq, Show) - -instance Exception RadixError - -data RadixNode - = RadixNode - { _radixPrefix :: Maybe RadixPrefix - , _radixLeft :: Maybe RadixRoot - , _radixRight :: Maybe RadixRoot - , _radixLeaf :: Maybe ByteString - } deriving (Data, Eq) - -instance NFData RadixNode where - rnf RadixNode {..} = - rnf _radixPrefix `seq` - rnf _radixLeft `seq` - rnf _radixRight `seq` - rnf _radixLeaf `seq` - () - -instance Default RadixNode where - def = RadixNode Nothing Nothing Nothing Nothing - -instance Serialise RadixNode where - encode RadixNode {..} = - encodeListLen len <> - encodeMaybe CBOR.encode _radixPrefix <> - encodeMaybe encodeSide left <> - encodeMaybe encodeSide right <> - maybe mempty encodeBytes _radixLeaf - where - len = bool 3 4 $ isJust _radixLeaf - left = fromShort <$> _radixLeft - right = fromShort <$> _radixRight - decode = do - len <- decodeListLen - prefix <- decodeMaybe decode - left <- decodeMaybe $ toShort <$> decodeSide - right <- decodeMaybe $ toShort <$> decodeSide - leaf <- decodeLeaf len - pure $ RadixNode prefix left right leaf - -instance Show RadixNode where - show node@RadixNode {..} = - case unpack <$> _radixLeaf of - Nothing -> printf "\ESC[96m%s\ESC[0m@[\ESC[97m%s\ESC[0m,\ESC[96m%s\ESC[0m,\ESC[96m%s\ESC[0m]" root prefix left right - Just leaf -> printf "\ESC[96m%s\ESC[0m@[\ESC[97m%s\ESC[0m,\ESC[96m%s\ESC[0m,\ESC[96m%s\ESC[0m,\ESC[97m%s\ESC[0m]" root prefix left right leaf - where - root = format $ hash 20 mempty $ toStrict $ serialise node - prefix = guard show _radixPrefix - left = guard format $ fromShort <$> _radixLeft - right = guard format $ fromShort <$> _radixRight - guard = maybe "null" - format = take 8 . unpack . Base16.encode - -data RadixPrefix - = RadixPrefix - { _radixBitLen :: Int - , _radixName :: ByteString - } deriving (Data, Eq) - -instance Bitable RadixPrefix where - toBits RadixPrefix {..} = take _radixBitLen $ toBits _radixName - fromBits bits = RadixPrefix bitLen name - where - bitLen = length bits - name = fromBits bits - -instance NFData RadixPrefix where - rnf RadixPrefix {..} = - rnf _radixBitLen `seq` - rnf _radixName `seq` - () - -instance Serialise RadixPrefix where - encode RadixPrefix {..} = - encodeListLen 2 <> - encodeInt _radixBitLen <> - encodeBytes _radixName - decode = do - void decodeListLen - bitLen <- decodeInt - name <- decodeBytes - pure $ RadixPrefix bitLen name - -instance Show RadixPrefix where - show = map compress . toBits - where compress = bool '0' '1' - -type RadixRoot = ShortByteString - -type RadixSearchResult = (NonEmpty RadixRoot, NonEmpty RadixNode, NonEmpty [Bool], [Bool], [Bool], RadixCache) - -data RadixTree database - = RadixTree - { _radixBloom :: RadixBloom - , _radixBloomSize :: Int - , _radixBuffer :: RadixBuffer - , _radixCache :: RadixCache - , _radixCacheSize :: Int - , _radixCheckpoint :: RadixRoot - , _radixDatabase :: database - , _radixNonce :: Word - , _radixRoot :: RadixRoot - } diff --git a/src/Network/DFINITY/RadixTree/Utilities.hs b/src/Network/DFINITY/RadixTree/Utilities.hs deleted file mode 100644 --- a/src/Network/DFINITY/RadixTree/Utilities.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{-# OPTIONS -Wall #-} - -module Network.DFINITY.RadixTree.Utilities - ( createPrefix - , createRoot - , createRootFromNonce - , defaultRoot - ) where - -import Codec.Serialise (serialise) -import Data.ByteString.Short (toShort) -import Data.Default.Class (def) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Builder as Builder - -import qualified Crypto.Hash.BLAKE2.BLAKE2s as Blake2s - -import Network.DFINITY.RadixTree.Bits -import Network.DFINITY.RadixTree.Types - -createPrefix :: [Bool] -> Maybe RadixPrefix -createPrefix bits = - if null bits - then Nothing - else Just $ fromBits bits - -createRoot :: RadixNode -> RadixRoot -createRoot = toShort . blake2s_hashlazy 20 . serialise - -createRootFromNonce :: Word -> RadixRoot -createRootFromNonce - = toShort - . Blake2s.hash 20 mempty - . LBS.toStrict - . Builder.toLazyByteString - . Builder.wordDec - -defaultRoot :: RadixRoot -defaultRoot = createRoot def - -blake2s_hashlazy :: Int -> LBS.ByteString -> BS.ByteString -blake2s_hashlazy size - = Blake2s.finalize size - . LBS.foldlChunks (flip Blake2s.update) (Blake2s.initialize size) diff --git a/test/Integrations.hs b/test/Integrations.hs new file mode 100644 --- /dev/null +++ b/test/Integrations.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS -Wall #-} +{-# OPTIONS -Werror #-} + +module Integrations + ( tests + , simple + ) where + +import Control.Arrow (arr) +import Control.Concurrent.BoundedChan (newBoundedChan, readChan, writeChan) +import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar) +import Control.Concurrent.ReadWriteLock (new) +import Control.Monad (foldM, forM_, forever, replicateM, void) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Resource (MonadResource, resourceForkIO, runResourceT) +import Crypto.Hash.BLAKE2.BLAKE2s (hash) +import Data.ByteString.Base16 (encode) +import Data.ByteString.Builder (toLazyByteString, word32BE) +import Data.ByteString.Char8 as Byte (ByteString, length, pack, unpack) +import Data.ByteString.Lazy (toStrict) +import Data.ByteString.Short (fromShort) +import Data.Conduit (ConduitT, (.|), awaitForever, runConduit, yield) +import Data.Conduit.Internal (Pipe(..), sourceToPipe) +import Data.Word (Word32, Word64) +import Database.LevelDB (DB, Options(..), defaultOptions, open) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (arbitrary, generate) +import Test.Tasty.HUnit (Assertion, assertEqual, testCase) +import Text.Printf (printf) + +import DFINITY.RadixTree +import DFINITY.RadixTree.Conduit + +tests :: TestTree +tests = testGroup "integrations" + [ testCase "simple-01-001000" $ simple 01 001000 + , testCase "simple-02-005000" $ simple 02 005000 + , testCase "simple-04-010000" $ simple 04 010000 + , testCase "simple-08-025000" $ simple 08 025000 + , testCase "simple-16-050000" $ simple 16 050000 + , testCase "simple-32-100000" $ simple 32 100000 + ] + +simple :: Int -> Word32 -> Assertion +simple n size = withSystemTempDirectory "test" $ \ path -> do + -- Create concurrent data structures. + counter <- newMVar 0 + senders <- replicateM n $ newBoundedChan 64 + receiver <- newBoundedChan 64 + -- Create the source and target database locks. + sourceLock <- new + targetLock <- new + -- Run the deterministic resource allocator. + runResourceT $ do + -- Create the source and target trees. + sourceTree <- create path "source" + targetTree <- create path "target" + -- Saturate the source tree. + sourceTree' <- saturate 1 size sourceTree + -- Calculate the source tree state root. + sourceRoot' <- fst <$> merkleizeRadixTree sourceTree' + liftIO $ printf "source: %s\n" $ pretty sourceRoot' + -- Create thread to relay updates. + void $ resourceForkIO $ liftIO $ forever $ do + update <- readChan receiver + forM_ senders $ flip writeChan update + -- Define the state synchronization conduits. + let masks = genMasks n + let zipper mask sender = sourceRadixTree mask 2048 sender sourceTree' sourceLock + let source = merge $ zipWith zipper masks senders + let sink = sinkRadixTree sourceRoot' receiver targetTree targetLock + -- Run the state synchronization protocol. + result <- runConduit $ source .| bandwidth counter .| sink + -- Inspect the result. + case result of + Left _ -> fail "missing subtrees" + Right targetTree' -> do + -- Calculate the target tree state root. + targetRoot' <- fst <$> merkleizeRadixTree targetTree' + liftIO $ printf "target: %s\n" $ pretty targetRoot' + -- Display bandwidth utilization. + total <- liftIO $ readMVar counter + liftIO $ printf "bandwidth: %d bytes\n" total + -- Assert the source and target tree state roots as equal. + liftIO $ assertEqual "simple" sourceRoot' targetRoot' + +create + :: MonadResource m + => FilePath + -> String + -> m (RadixTree DB) +create path name = do + handle <- open database options + createRadixTree 262144 2028 Nothing handle + where + database = path name + options = defaultOptions {createIfMissing = True} + +saturate + :: MonadIO m + => RadixDatabase m database + => Word32 + -> Word32 + -> RadixTree database + -> m (RadixTree database) +saturate a b tree = + foldM step tree [a..b] + where + step accum x = do + let key = hashW32 x + value <- liftIO $ generate $ pack <$> arbitrary + accum' <- insertRadixTree key value accum + if mod x 1000 == 0 + then snd <$> merkleizeRadixTree accum' + else pure accum' + +merge + :: Monad m + => [ConduitT () o m ()] + -> ConduitT () o m () +merge = + loop . map sourceToPipe + where + loop pipes = do + pipes' <- foldM step [] pipes + if null pipes' + then pure () + else loop pipes' + step accum = \ case + Done () -> + pure accum + HaveOutput pipe value -> do + yield value + pure $ pipe:accum + PipeM action -> do + pipe <- lift action + step accum pipe + _ -> fail $ "merge: undefined" + +bandwidth + :: MonadIO m + => MVar Word64 + -> ConduitT ByteString ByteString m () +bandwidth counter = + awaitForever $ \ bytes -> do + let size = fromIntegral $ Byte.length bytes + liftIO $ modifyMVar_ counter $ \ accum -> + pure $! accum + size + yield bytes + +pretty :: RadixRoot -> String +pretty = unpack . encode . fromShort + +hashW32 :: Word32 -> ByteString +hashW32 = hash 32 mempty . toStrict . toLazyByteString . word32BE + +genMasks :: Int -> [[Bool]] +genMasks n = take n $ concat $ repeat xs + where + i = truncate $ logBase 2 $ (realToFrac n :: Double) + xs = [zipWith arr fs $ replicate i True | fs <- replicateM i [id, not]] diff --git a/test/Properties.hs b/test/Properties.hs --- a/test/Properties.hs +++ b/test/Properties.hs @@ -1,5 +1,8 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS -Wall #-} + {- | This module contains a (very simple) property based test for the RadixTree data structure. @@ -21,6 +24,7 @@ module Properties (tests) where import qualified Data.Map as M +import Data.Maybe (isJust) import Data.ByteString.Char8 (ByteString, pack) import Data.ByteString.Short (fromShort) import Test.QuickCheck @@ -30,7 +34,8 @@ import Data.Bifunctor import Control.Monad.State.Strict -import Network.DFINITY.RadixTree +import DFINITY.RadixTree +import Types {- In this module we test the RadixTree module against a pure implementation of @@ -38,12 +43,6 @@ calls, run them in both implementations, and compare the results. -} -data Op - = Insert ByteString ByteString - | Delete ByteString - | Lookup ByteString - deriving Show - generateOps :: Gen [Op] generateOps = do -- Create a small, non-zero number of keys to consider @@ -51,9 +50,9 @@ keys <- vectorOf len arbBS let pickKey = elements keys listOf $ frequency - [ (1, Insert <$> pickKey <*> arbBS ) + [ (1, Insert <$> pickKey <*> arbBS) , (1, Delete <$> pickKey) - , (2, Lookup <$> pickKey) + , (2, Lookup <$> pickKey <*> pure Nothing) ] arbBS :: Gen ByteString @@ -64,8 +63,8 @@ runPure ops = snd $ mapAccumL go M.empty ops where go m (Insert k v) = (M.insert k v m, Nothing) - go m (Delete k) = (M.delete k m, Nothing) - go m (Lookup k) = (m, M.lookup k m) + go m (Delete k ) = (M.delete k m, Nothing) + go m (Lookup k _) = (m, M.lookup k m) type M = State (M.Map ByteString ByteString) @@ -73,9 +72,6 @@ runRadix :: [Op] -> [Maybe ByteString] runRadix ops0 = evalState (initTree >>= go ops0) M.empty where - initTree :: M (RadixTree ()) - initTree = createRadixTree 262144 2028 Nothing () - go :: [Op] -> RadixTree () -> M [Maybe ByteString] go [] _ = return [] go (Insert k v : ops) t = do @@ -84,7 +80,7 @@ go (Delete k : ops) t = do t' <- deleteRadixTree k t (Nothing :) <$> go ops t' - go (Lookup k : ops) t = + go (Lookup k _ : ops) t = lookupRadixTree k t >>= \case Nothing -> (Nothing :) <$> go ops t Just (v,t') -> (Just v :) <$> go ops t' @@ -140,16 +136,59 @@ run :: [Op] -> ByteString run ops0 = evalState (initTree >>= go ops0) M.empty where - initTree :: M (RadixTree ()) - initTree = createRadixTree 262144 2028 Nothing () - go :: [Op] -> RadixTree () -> M ByteString go [] t = fromShort . fst <$> merkleizeRadixTree t go (Insert k v : ops) t = insertRadixTree k v t >>= go ops go (Delete k : ops) t = deleteRadixTree k t >>= go ops - go (Lookup _ : _ ) _ = error "no lookup in this test please" + go (Lookup _ _ : _ ) _ = error "no lookup in this test please" +-- | 'createRadixProof' should find the same value as 'lookupRadixTree' +prop_proofLookup :: Property +prop_proofLookup = forAll arbitrary $ \keyStr -> + let key = pack keyStr + proofRes = lookupProof key + radixRes = lookupRadix key + in isJust proofRes && isJust radixRes + && proofRes == radixRes + where + run = flip evalState M.empty + lookupProof k = run $ do + tree <- initTree + tree' <- insertRadixTree k (mappend k "suffix") tree + (_, mTree) <- merkleizeRadixTree tree' + fmap (_radixValue . fst) <$> createRadixProof k mTree + + lookupRadix k = run $ do + tree <- initTree + tree' <- insertRadixTree k (mappend k "suffix") tree + fmap fst <$> lookupRadixTree k tree' + +prop_proofValid :: Property +prop_proofValid = forAll arbitrary $ \keyPrefixStr -> + let keyPrefix = pack keyPrefixStr + (key, proof, root) = lookupProof keyPrefix + in case proof of + Nothing -> False + Just p -> verifyRadixProof key root p + where + run = flip evalState M.empty + lookupProof kp = run $ do + tree <- initTree + tree' <- insertRadixTree (mappend kp "1") "body1" tree + tree'' <- insertRadixTree (mappend kp "12") "body2" tree' + let key = mappend kp "123" + tree''' <- insertRadixTree key "body3" tree'' + (root, mTree) <- merkleizeRadixTree tree''' + proof <- fmap fst <$> createRadixProof key mTree + pure (key, proof, root) + tests :: TestTree tests = testGroup "Property tests" [ testProperty "lookup" prop_lookup + , testProperty "contents" prop_stateRoot + , testProperty "createRadixProof ~ lookupRadixTree" prop_proofLookup + , testProperty "createRadixProofs are always valid" prop_proofValid ] + +initTree :: M (RadixTree ()) +initTree = createRadixTree 262144 2028 Nothing () diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,14 @@ +import Test.Tasty + +import Integrations as Integration (tests) +import Properties as Property (tests) +import Units as Unit (tests) + +main :: IO () +main = do + units <- Unit.tests + defaultMain $ testGroup "tests" + [ Integration.tests + , Property.tests + , units + ] diff --git a/test/Types.hs b/test/Types.hs new file mode 100644 --- /dev/null +++ b/test/Types.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS -Wall #-} +{-# OPTIONS -Werror #-} + +module Types + ( Op(..) + ) where + +import Control.Monad (mzero) +import Data.Aeson (FromJSON(..), Object, Value(..)) +import Data.ByteString.Base16 (decode, encode) +import Data.ByteString.Char8 (ByteString, unpack) +import Data.HashMap.Strict as HashMap (lookup) +import Data.Text as Text (Text, drop) +import Data.Text.Encoding (encodeUtf8) + +data Op + = Insert ByteString ByteString + | Delete ByteString + | Lookup ByteString (Maybe ByteString) + | Merkleize ByteString + +instance FromJSON Op where + parseJSON = \ case + Object object -> maybe mzero pure $ parse object + _ -> mzero + +instance Show Op where + show = \ case + Insert key value -> + "Insert" ++ pretty key ++ pretty value + Delete key -> + "Delete" ++ pretty key + Lookup key value -> + "Lookup" ++ pretty key ++ maybe " null" pretty value + Merkleize value -> + "Merkleize" ++ pretty value + where pretty = mappend " 0x" . unpack . encode + +parse :: Object -> Maybe Op +parse object = do + op <- HashMap.lookup "op" object + case op of + "set" -> do + key <- get "key" object + value <- get "value" object + pure $ Insert key value + "delete" -> do + key <- get "key" object + pure $ Delete key + "get" -> do + key <- get "key" object + let value = get "value" object + pure $ Lookup key value + "stateRoot" -> do + value <- get "value" object + pure $ Merkleize value + _ -> Nothing + +get :: Text -> Object -> Maybe ByteString +get key object = do + value <- HashMap.lookup key object + case value of + String text -> Just $ fst $ decode $ encodeUtf8 $ Text.drop 2 text + _ -> Nothing diff --git a/test/UnitTests.hs b/test/UnitTests.hs deleted file mode 100644 --- a/test/UnitTests.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS -Wall #-} - -module UnitTests where - -import Control.Arrow (first) -import Control.Monad (foldM_, mzero, void) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.State.Strict (StateT, runStateT) -import Data.Aeson (FromJSON(..), Object, Value(..), eitherDecode) -import Data.ByteString.Base16 (decode, encode) -import Data.ByteString.Char8 (ByteString, unpack) -import Data.ByteString.Lazy.Char8 as Lazy (readFile) -import Data.ByteString.Short (fromShort) -import Data.HashMap.Strict as HashMap (lookup, toList) -import Data.Map.Strict (Map, empty) -import Data.Text as Text (Text, drop) -import Data.Text.Encoding (encodeUtf8) -import Test.Tasty -import Test.Tasty.HUnit - -import Network.DFINITY.RadixTree - - -data Op - = Insert ByteString ByteString - | Delete ByteString - | Lookup ByteString ByteString - | Merkleize ByteString - -instance FromJSON Op where - parseJSON = \ case - Object object -> maybe mzero pure $ parse object - _ -> mzero - -instance Show Op where - show = \ case - Insert key value -> "Insert" ++ pretty key ++ pretty value - Delete key -> "Delete" ++ pretty key - Lookup key value -> "Lookup" ++ pretty key ++ pretty value - Merkleize value -> "Merkleize" ++ pretty value - where pretty = mappend " 0x" . unpack . encode - -parse :: Object -> Maybe Op -parse object = do - op <- HashMap.lookup "op" object - case op of - "set" -> Insert <$> get "key" object <*> get "value" object - "delete" -> Delete <$> get "key" object - "get" -> Lookup <$> get "key" object <*> get "value" object - "stateRoot" -> Merkleize <$> get "value" object - _ -> Nothing - -get :: Text -> Object -> Maybe ByteString -get key object = do - value <- HashMap.lookup key object - case value of - String text -> Just $ fst $ decode $ encodeUtf8 $ Text.drop 2 text - _ -> Nothing - -step :: RadixTree () -> Op -> StateT (Map ByteString ByteString) IO (RadixTree ()) -step tree op = do - liftIO $ print op - case op of - Insert key value -> do - tree' <- insertRadixTree key value tree - printNonMerkleizedRadixTree tree' - pure tree' - Delete key -> do - tree' <- deleteRadixTree key tree - printNonMerkleizedRadixTree tree' - pure tree' - Lookup key value -> do - result <- lookupRadixTree key tree - case result of - Just (value', tree') | value == value' -> pure tree' - Just (value', _) -> throw - ["Expecting value ", ", but received value ", " for key "] - [value, value', key] - Nothing -> throw - ["Expecting value ", ", but received no value for key "] - [value, key] - Merkleize value -> do - (value', tree') <- first fromShort <$> merkleizeRadixTree tree - if value == value' - then pure tree' - else throw - ["Expecting state root ", ", but received state root "] - [value, value'] - where - throw err = fail . concat . zipWith mappend err . map show - -runTest :: [Op] -> IO () -runTest ops = void $ flip runStateT empty $ do - tree <- createRadixTree 262144 2048 Nothing () - foldM_ step tree ops - -tests :: IO TestTree -tests = do - contents <- Lazy.readFile "test/tests.json" - vctors <- either fail return $ eitherDecode contents - return $ testGroup "unitTests" - [ testCase name (runTest ops) - | (name, ops) <- HashMap.toList vctors - ] diff --git a/test/Units.hs b/test/Units.hs new file mode 100644 --- /dev/null +++ b/test/Units.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS -Wall #-} +{-# OPTIONS -Werror #-} + +module Units + ( tests + ) where + +import Control.Arrow (first) +import Control.Monad (foldM_, void) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.State.Strict (StateT, runStateT) +import Data.Aeson (eitherDecode) +import Data.ByteString.Char8 (ByteString) +import Data.ByteString.Lazy.Char8 as Lazy (readFile) +import Data.ByteString.Short (fromShort) +import Data.HashMap.Strict (toList) +import Data.Map.Strict (Map, empty) +import Data.Maybe (fromJust) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase) + +import DFINITY.RadixTree +import Types + +tests :: IO TestTree +tests = do + contents <- Lazy.readFile "test/tests.json" + vectors <- either fail return $ eitherDecode contents + pure $ testGroup "units" + [testCase name $ run ops | (name, ops) <- toList vectors] + +run :: [Op] -> IO () +run ops = void $ flip runStateT empty $ do + tree <- createRadixTree 262144 2048 Nothing () + foldM_ step tree ops + +step :: RadixTree () -> Op -> StateT (Map ByteString ByteString) IO (RadixTree ()) +step tree op = do + liftIO $ print op + case op of + Insert key value -> do + tree' <- insertRadixTree key value tree + printRadixTree tree' + pure tree' + Delete key -> do + tree' <- deleteRadixTree key tree + printRadixTree tree' + pure tree' + Lookup key value -> do + result <- lookupRadixTree key tree + case result of + Nothing | value == Nothing -> pure tree + Nothing -> throw + ["Expecting value ", ", but received no value for key "] + [fromJust value, key] + Just (value', tree') | value == Just value' -> pure tree' + Just (value', _) -> throw + ["Expecting value ", ", but received value ", " for key "] + [maybe "null" id value, value', key] + Merkleize value -> do + (value', tree') <- first fromShort <$> merkleizeRadixTree tree + if value == value' + then pure tree' + else throw + ["Expecting state root ", ", but received state root "] + [value, value'] + +throw :: MonadIO m => [String] -> [ByteString] -> m a +throw err = liftIO . assertFailure . concat . zipWith mappend err . map show diff --git a/test/tests.hs b/test/tests.hs deleted file mode 100644 --- a/test/tests.hs +++ /dev/null @@ -1,9 +0,0 @@ -import Test.Tasty - -import qualified UnitTests -import qualified Properties - -main :: IO () -main = do - unit_tests <- UnitTests.tests - defaultMain $ testGroup "tests" [unit_tests, Properties.tests]