dfinity-radix-tree 0.4.0 → 0.5.0

raw patch · 34 files changed

+2249/−1815 lines, 34 filesdep +directorydep +dlistdep +filepathPVP ok

version bump matches the API change (PVP)

Dependencies added: directory, dlist, filepath, hashtables, reducers, stm, transformers

API changes (from Hackage documentation)

Files

• .travis.yml +11/−0
• CHANGELOG.md +4/−0
• README.md +6/−6
• benchmark/Main.hs +1/−1
• benchmark/dfinity-radix-tree-benchmarks-leveldb.svg +2/−2
• benchmark/dfinity-radix-tree-benchmarks-lmdb.svg +2/−2
• dfinity-radix-tree.cabal +51/−32
• src/DFINITY/RadixTree.hs +902/−0
• src/DFINITY/RadixTree/Bits.hs +37/−0
• src/DFINITY/RadixTree/Bloom.hs +35/−0
• src/DFINITY/RadixTree/Conduit.hs +265/−0
• src/DFINITY/RadixTree/Lenses.hs +114/−0
• src/DFINITY/RadixTree/Lock.hs +30/−0
• src/DFINITY/RadixTree/Memory.hs +103/−0
• src/DFINITY/RadixTree/Serialise.hs +39/−0
• src/DFINITY/RadixTree/Types.hs +221/−0
• src/DFINITY/RadixTree/Utilities.hs +50/−0
• src/Network/DFINITY/RadixTree.hs +0/−806
• src/Network/DFINITY/RadixTree/Bits.hs +0/−37
• src/Network/DFINITY/RadixTree/Bloom.hs +0/−35
• src/Network/DFINITY/RadixTree/Conduit.hs +0/−230
• src/Network/DFINITY/RadixTree/Lenses.hs +0/−114
• src/Network/DFINITY/RadixTree/Lock.hs +0/−30
• src/Network/DFINITY/RadixTree/Memory.hs +0/−103
• src/Network/DFINITY/RadixTree/Serialise.hs +0/−39
• src/Network/DFINITY/RadixTree/Types.hs +0/−192
• src/Network/DFINITY/RadixTree/Utilities.hs +0/−48
• test/Integrations.hs +166/−0
• test/Properties.hs +58/−19
• test/Tests.hs +14/−0
• test/Types.hs +67/−0
• test/UnitTests.hs +0/−110
• test/Units.hs +71/−0
• test/tests.hs +0/−9

@@ -0,0 +1,11 @@+language: haskell++addons:+  apt:+    packages:+    - libleveldb-dev+    - liblmdb-dev++ghc:+  - 8.2+  - 8.4

@@ -1,3 +1,7 @@+0.5.0 Enzo Haussecker <enzo@dfinity.org> Fri Oct 19 2018++ * Implement Merkle proofs.+ 0.4.0 Enzo Haussecker <enzo@dfinity.org> Tue Sep 25 2018   * Change hash function from SHA-256 to BLAKE-256.

@@ -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 

@@ -28,7 +28,7 @@ import qualified Database.LevelDB as LevelDB import qualified Database.LMDB.Simple as LMDB -import Network.DFINITY.RadixTree+import DFINITY.RadixTree   --------------------------------------------------------------------------------

@@ -116,7 +116,7 @@ <g fill='#e6564e'> <rect x='990.0' y='160.875' width='27.0' height='27.0' /> </g>-<text stroke='none' x='1023.75' y='177.75' font-size='15.0' text-anchor='start'>dfinity-radix-tree-0.3.1-Ch2JdNQi35N1NDZGT2tyvZ:Network.DFINITY.RadixTree.Types.RadixNode</text>+<text stroke='none' x='1023.75' y='177.75' font-size='15.0' text-anchor='start'>dfinity-radix-tree-0.3.1-Ch2JdNQi35N1NDZGT2tyvZ:DFINITY.RadixTree.Types.RadixNode</text> <g fill='#fba63a'> <rect x='990.0' y='194.625' width='27.0' height='27.0' /> </g>@@ -160,7 +160,7 @@ <g fill='#39a6fa'> <rect x='990.0' y='532.125' width='27.0' height='27.0' /> </g>-<text stroke='none' x='1023.75' y='549.0' font-size='15.0' text-anchor='start'>dfinity-radix-tree-0.3.1-Ch2JdNQi35N1NDZGT2tyvZ:Network.DFINITY.RadixTree.Types.RadixPrefix</text>+<text stroke='none' x='1023.75' y='549.0' font-size='15.0' text-anchor='start'>dfinity-radix-tree-0.3.1-Ch2JdNQi35N1NDZGT2tyvZ:DFINITY.RadixTree.Types.RadixPrefix</text> <g fill='#549a4a'> <rect x='990.0' y='565.875' width='27.0' height='27.0' /> </g>

@@ -110,7 +110,7 @@ <g fill='#e6564e'> <rect x='990.0' y='160.875' width='27.0' height='27.0' /> </g>-<text stroke='none' x='1023.75' y='177.75' font-size='15.0' text-anchor='start'>dfinity-radix-tree-0.3.1-Ch2JdNQi35N1NDZGT2tyvZ:Network.DFINITY.RadixTree.Types.RadixNode</text>+<text stroke='none' x='1023.75' y='177.75' font-size='15.0' text-anchor='start'>dfinity-radix-tree-0.3.1-Ch2JdNQi35N1NDZGT2tyvZ:DFINITY.RadixTree.Types.RadixNode</text> <g fill='#fba63a'> <rect x='990.0' y='194.625' width='27.0' height='27.0' /> </g>@@ -154,7 +154,7 @@ <g fill='#39a6fa'> <rect x='990.0' y='532.125' width='27.0' height='27.0' /> </g>-<text stroke='none' x='1023.75' y='549.0' font-size='15.0' text-anchor='start'>dfinity-radix-tree-0.3.1-Ch2JdNQi35N1NDZGT2tyvZ:Network.DFINITY.RadixTree.Types.RadixPrefix</text>+<text stroke='none' x='1023.75' y='549.0' font-size='15.0' text-anchor='start'>dfinity-radix-tree-0.3.1-Ch2JdNQi35N1NDZGT2tyvZ:DFINITY.RadixTree.Types.RadixPrefix</text> <g fill='#549a4a'> <rect x='990.0' y='565.875' width='27.0' height='27.0' /> </g>

@@ -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 <enzo@dfinity.org>-Maintainer:         DFINITY USA Research <team@dfinity.org>-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 <enzo@dfinity.org>, Remy Goldschmidt <remy@dfinity.org>, Armando Ramirez <armando@dfinity.org>+Maintainer:         Enzo Haussecker <enzo@dfinity.org>, Remy Goldschmidt <remy@dfinity.org>, Armando Ramirez <armando@dfinity.org>+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

@@ -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 <enzo@dfinity.org>+-- 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 () #-}++--------------------------------------------------------------------------------

@@ -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]

@@ -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#

@@ -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 <enzo@dfinity.org>+-- 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)) #-}++--------------------------------------------------------------------------------

@@ -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

@@ -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

@@ -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) #-}++--------------------------------------------------------------------------------

@@ -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

@@ -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+   }

@@ -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

@@ -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 <enzo@dfinity.org>--- 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 () #-}----------------------------------------------------------------------------------

@@ -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]

@@ -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#

@@ -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 <enzo@dfinity.org>--- 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)) #-}----------------------------------------------------------------------------------

@@ -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

@@ -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

@@ -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) #-}----------------------------------------------------------------------------------

@@ -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

@@ -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-   }

@@ -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)

@@ -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]]

@@ -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 ()

@@ -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+      ]

@@ -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

@@ -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-      ]

@@ -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

@@ -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]