packages feed

dfinity-radix-tree 0.0.0 → 0.1.0

raw patch · 10 files changed

+462/−233 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

+ Network.DFINITY.RadixTree: class Monad m => RadixDatabase config m database | database -> config
+ Network.DFINITY.RadixTree: create :: RadixDatabase config m database => config -> m database
+ Network.DFINITY.RadixTree: load :: RadixDatabase config m database => database -> ByteString -> m (Maybe ByteString)
+ Network.DFINITY.RadixTree: sinkMerkleizedRadixTree :: MonadResource m => RadixDatabase config (ConduitM ByteString () m) database => RadixRoot -> BoundedChan RadixRoot -> RadixTree database -> ConduitM ByteString () m (Either [RadixRoot] (RadixTree database))
+ Network.DFINITY.RadixTree: store :: RadixDatabase config m database => database -> ByteString -> ByteString -> m ()
- Network.DFINITY.RadixTree: createRadixTree :: MonadResource m => Int -> Int -> FilePath -> Maybe RadixRoot -> m RadixTree
+ Network.DFINITY.RadixTree: createRadixTree :: RadixDatabase config m database => Int -> Int -> Maybe RadixRoot -> config -> m (RadixTree database)
- Network.DFINITY.RadixTree: data RadixTree
+ Network.DFINITY.RadixTree: data RadixTree database
- Network.DFINITY.RadixTree: deleteRadixTree :: MonadIO m => ByteString -> RadixTree -> m RadixTree
+ Network.DFINITY.RadixTree: deleteRadixTree :: RadixDatabase config m database => ByteString -> RadixTree database -> m (RadixTree database)
- Network.DFINITY.RadixTree: insertRadixTree :: MonadIO m => ByteString -> ByteString -> RadixTree -> m RadixTree
+ Network.DFINITY.RadixTree: insertRadixTree :: RadixDatabase config m database => ByteString -> ByteString -> RadixTree database -> m (RadixTree database)
- Network.DFINITY.RadixTree: isEmptyRadixTree :: RadixTree -> Bool
+ Network.DFINITY.RadixTree: isEmptyRadixTree :: RadixTree database -> Bool
- Network.DFINITY.RadixTree: isValidRadixRoot :: MonadIO m => RadixRoot -> RadixTree -> m Bool
+ Network.DFINITY.RadixTree: isValidRadixRoot :: RadixDatabase config m database => RadixRoot -> RadixTree database -> m Bool
- Network.DFINITY.RadixTree: lookupMerkleizedRadixTree :: MonadIO m => ByteString -> RadixTree -> m (Maybe (ByteString, RadixTree))
+ Network.DFINITY.RadixTree: lookupMerkleizedRadixTree :: RadixDatabase config m database => ByteString -> RadixTree database -> m (Maybe (ByteString, RadixTree database))
- Network.DFINITY.RadixTree: lookupNonMerkleizedRadixTree :: MonadIO m => ByteString -> RadixTree -> m (Maybe (ByteString, RadixTree))
+ Network.DFINITY.RadixTree: lookupNonMerkleizedRadixTree :: RadixDatabase config m database => ByteString -> RadixTree database -> m (Maybe (ByteString, RadixTree database))
- Network.DFINITY.RadixTree: merkleizeRadixTree :: MonadIO m => RadixTree -> m (RadixRoot, RadixTree)
+ Network.DFINITY.RadixTree: merkleizeRadixTree :: RadixDatabase config m database => RadixTree database -> m (RadixRoot, RadixTree database)
- Network.DFINITY.RadixTree: printMerkleizedRadixTree :: MonadIO m => RadixTree -> m ()
+ Network.DFINITY.RadixTree: printMerkleizedRadixTree :: MonadIO m => RadixDatabase config m database => RadixTree database -> m ()
- Network.DFINITY.RadixTree: printNonMerkleizedRadixTree :: MonadIO m => RadixTree -> m ()
+ Network.DFINITY.RadixTree: printNonMerkleizedRadixTree :: MonadIO m => RadixDatabase config m database => RadixTree database -> m ()
- Network.DFINITY.RadixTree: sourceMerkleizedRadixTree :: MonadResource m => [Bool] -> Int -> BoundedChan RadixRoot -> RadixTree -> Source m ByteString
+ Network.DFINITY.RadixTree: sourceMerkleizedRadixTree :: MonadResource m => RadixDatabase config (ConduitM () ByteString m) database => [Bool] -> Int -> BoundedChan RadixRoot -> RadixTree database -> ConduitM () ByteString m ()
- Network.DFINITY.RadixTree: subtreeRadixTree :: MonadIO m => RadixRoot -> RadixTree -> m RadixTree
+ Network.DFINITY.RadixTree: subtreeRadixTree :: RadixDatabase config m database => RadixRoot -> RadixTree database -> m (RadixTree database)

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+0.1.0 Enzo Haussecker <enzo@dfinity.org> Tue Jul 03 2018++ * Abstract database to type class+ * Implement radix tree construction via conduit+ * Clean-up documentation
+ README.md view
@@ -0,0 +1,83 @@+# dfinity-radix-tree: A generic data integrity layer.+[![Build Status](https://travis-ci.org/dfinity-lab/hs-radix-tree.svg?branch=master)](https://travis-ci.org/dfinity-lab/hs-radix-tree)+[![Hackage](https://img.shields.io/hackage/v/dfinity-radix-tree.svg)](https://hackage.haskell.org/package/dfinity-radix-tree)+[![Dependencies](https://img.shields.io/hackage-deps/v/dfinity-radix-tree.svg)](http://packdeps.haskellers.com/feed?needle=dfinity-radix-tree)+[![License: GPLv3](https://img.shields.io/badge/License-GPLv3-blue.svg)](https://www.gnu.org/licenses/gpl-3.0)++## Overview+This library allows you to construct a [Merkle tree](https://en.wikipedia.org/wiki/Merkle_tree) on top of any underlying key–value database. It works by organizing your key–value pairs into a binary radix tree, which is well suited for storing large dictionaries of fairly random keys, and is optimized for storing keys of the same length.++## Usage+Define your database as an instance of the `RadixDatabase` type class. An instance for [LevelDB](http://hackage.haskell.org/package/leveldb-haskell) is already provided.+```haskell+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++import Control.Monad.Trans.Resource+import Database.LevelDB+import Network.DFINITY.RadixTree++instance MonadResource m => RadixDatabase (FilePath, Options) m DB where+   create = uncurry open+   load database = get database defaultReadOptions+   store database = put database defaultWriteOptions+```+Create a `RadixTree` that is parameterized by your database. If you want to make things more explicit, then define some simple type aliases and wrapper functions.+```haskell+import Control.Monad.Trans.Resource+import Data.ByteString+import Database.LevelDB+import Network.DFINITY.RadixTree++type MerkleTree = RadixTree DB+type MerkleRoot = RadixRoot++createMerkleTree+   :: MonadResource m+   => FilePath -- Database.+   -> Maybe MerkleRoot -- State root.+   -> m MerkleTree+createMerkleTree path root =+   createRadixTree bloomSize cacheSize root (path, options)+   where+   bloomSize = 262144+   cacheSize = 2048+   options = defaultOptions {createIfMissing = True}++insertMerkleTree+   :: MonadResource m+   => ByteString -- Key.+   -> ByteString -- Value.+   -> MerkleTree -- Tree.+   -> m MerkleTree+insertMerkleTree = insertRadixTree++deleteMerkleTree+   :: MonadResource m+   => ByteString -- Key.+   -> MerkleTree -- Tree.+   -> m MerkleTree+deleteMerkleTree = deleteRadixTree++merkleizeMerkleTree+   :: MonadResource m+   => MerkleTree -- Tree.+   -> m (MerkleRoot, MerkleTree)+merkleizeMerkleTree = merkleizeRadixTree++lookupMerkleTree+   :: MonadResource m+   => ByteString -- Key.+   -> MerkleTree -- Tree.+   -> m (Maybe (ByteString, MerkleTree))+lookupMerkleTree = lookupMerkleizedRadixTree+```+Using the API above, we can perform operations on the tree as a proxy for the database and see that its contents is uniquely defined by its `MerkleRoot`.++## Contribute++Feel free to join in. All are welcome. Open an [issue](https://github.com/dfinity-lab/hs-radix-tree/issues)!++## License++GPLv3
benchmark/Main.hs view
@@ -2,59 +2,64 @@ {-# LANGUAGE RecordWildCards #-}  {-# OPTIONS -Wall #-}+{-# OPTIONS -fno-cse #-}  module Main where  import Control.Monad (foldM) import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Trans.Resource (runResourceT)-import Crypto.Hash.SHA256 (hash)-import Data.ByteString.Char8 (ByteString, pack)+import Control.Monad.Trans.Resource (MonadResource, runResourceT)+import Crypto.Hash.SHA256 (hashlazy)+import Data.ByteString.Builder (word32BE, toLazyByteString)+import Data.ByteString.Char8 (ByteString) import Data.Default.Class (Default(..))+import Data.Word (Word32)+import Database.LevelDB (DB, Options(..)) import System.Console.CmdArgs (Data, cmdArgs)  import Network.DFINITY.RadixTree  data Args    = Args-   { database :: FilePath+   { path :: FilePath    } deriving Data  instance Default Args where    def = Args "benchmark/benchmarkdb"  step-   :: MonadIO m-   => (RadixTree -> ByteString -> m RadixTree)-   -> RadixTree-   -> Int-   -> m RadixTree-step action tree i =+   :: MonadResource m+   => (RadixTree DB -> ByteString -> m (RadixTree DB))+   -> RadixTree DB+   -> Word32+   -> m (RadixTree DB)+step action tree i = do+   tree' <- action tree key    if mod i 1000 == 0-   then merkleizeRadixTree tree >>= flip action key . snd-   else action tree key-   where key = hash $ pack $ show i+   then snd <$> merkleizeRadixTree tree'+   else pure tree'+   where key = hashlazy $ toLazyByteString $ word32BE i  foldInsert-   :: MonadIO m-   => RadixTree-   -> [Int]-   -> m RadixTree+   :: MonadResource m+   => RadixTree DB+   -> [Word32]+   -> m (RadixTree DB) foldInsert = foldM $ step $ flip $ \ key -> insertRadixTree key key  foldDelete-   :: MonadIO m-   => RadixTree-   -> [Int]-   -> m RadixTree+   :: MonadResource m+   => RadixTree DB+   -> [Word32]+   -> m (RadixTree DB) foldDelete = foldM $ step $ flip deleteRadixTree  main :: IO () main = do    Args {..} <- cmdArgs def    runResourceT $ do-      tree <- createRadixTree 1048576 6144 database Nothing-      tree' <- foldInsert tree keys-      tree'' <- foldDelete tree' keys+      let options = def {createIfMissing = True}+      tree <- createRadixTree 262144 2048 Nothing (path, options)+      tree' <- foldInsert tree [1..100000]+      tree'' <- foldDelete tree' [1..100000]       liftIO $ print $ isEmptyRadixTree tree''-      where keys = [1..1000000]
benchmark/dfinity-radix-tree-benchmarks.svg view

file too large to diff

dfinity-radix-tree.cabal view
@@ -1,19 +1,27 @@-name:          dfinity-radix-tree-version:       0.0.0-synopsis:      A Merkleized key–value data store.-description:   This library provides a simple data integrity layer for LevelDB.-homepage:      https://github.com/dfinity-lab/hs-radix-tree-license:       GPL-3-license-file:  LICENSE-author:        Enzo Haussecker <enzo@dfinity.org>-maintainer:    DFINITY USA Research <team@dfinity.org>-copyright:     2018 DFINITY Stiftung-category:      Blockchain, DFINITY, Database-build-type:    Simple-cabal-version: >=1.10+Name:               dfinity-radix-tree+Version:            0.1.0+Synopsis:           A generic data integrity layer.+Description:+   This library allows you to construct a Merkle tree on top of any underlying+   key–value database. It works by organizing your key–value pairs into a binary+   radix tree, which is well suited for storing large dictionaries of fairly+   random keys, and is optimized for storing keys of the same length. -library-   build-depends:+License:            GPL-3+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-radix-tree+Bug-Reports:        https://github.com/dfinity-lab/hs-radix-tree/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++Library+   Build-Depends:       BoundedChan,       base >=4.10 && <5,       base16-bytestring,@@ -31,17 +39,17 @@       resourcet,       semigroups,       serialise-   default-language:+   Default-Language:       Haskell2010-   exposed-modules:+   Exposed-Modules:       Network.DFINITY.RadixTree-   ghc-options:+   GHC-Options:       -O2       -Wall       -fno-warn-missing-signatures-   hs-source-dirs:+   HS-Source-Dirs:       src-   other-modules:+   Other-Modules:       Network.DFINITY.RadixTree.Bits       Network.DFINITY.RadixTree.Bloom       Network.DFINITY.RadixTree.Lenses@@ -50,8 +58,8 @@       Network.DFINITY.RadixTree.Types       Network.DFINITY.RadixTree.Utilities -executable dfinity-radix-tree-unit-tests-   build-depends:+Executable dfinity-radix-tree-unit-tests+   Build-Depends:       aeson,       base >=4.10 && <5,       base16-bytestring,@@ -59,35 +67,37 @@       cmdargs,       data-default-class,       dfinity-radix-tree,+      leveldb-haskell,       resourcet,       text,       unordered-containers-   default-language:+   Default-Language:       Haskell2010-   ghc-options:+   GHC-Options:       -O2       -Wall-   hs-source-dirs:+   HS-Source-Dirs:       test-   main-is:+   Main-Is:       Main.hs -executable dfinity-radix-tree-benchmarks-   build-depends:+Executable dfinity-radix-tree-benchmarks+   Build-Depends:       base >=4.10 && <5,       bytestring,       cmdargs,       cryptohash-sha256,       data-default-class,       dfinity-radix-tree,+      leveldb-haskell,       resourcet-   default-language:+   Default-Language:       Haskell2010-   ghc-options:+   GHC-Options:       -O2       -Wall       -rtsopts-   hs-source-dirs:+   HS-Source-Dirs:       benchmark-   main-is:+   Main-Is:       Main.hs
src/Network/DFINITY/RadixTree.hs view
@@ -1,8 +1,9 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-}  {-# OPTIONS -Wall #-}-{-# OPTIONS -fno-warn-incomplete-patterns #-}+{-# OPTIONS -Werror=incomplete-patterns #-}  -- | -- Module     : Network.DFINITY.RadixTree@@ -11,11 +12,14 @@ -- Maintainer : Enzo Haussecker <enzo@dfinity.org> -- Stability  : Stable ----- A Merkleized key–value data store.+-- A generic data integrity layer. module Network.DFINITY.RadixTree ( +   -- ** Class+     RadixDatabase(..)+    -- ** Types-     RadixRoot+   , RadixRoot    , RadixTree    , RadixError(..) @@ -42,6 +46,7 @@     -- ** Stream    , sourceMerkleizedRadixTree+   , sinkMerkleizedRadixTree     -- ** Debug    , printMerkleizedRadixTree@@ -49,27 +54,29 @@     ) where -import Codec.Serialise (deserialise)+import Codec.Serialise (deserialise, deserialiseOrFail) import Control.Concurrent (forkIO, killThread)-import Control.Concurrent.BoundedChan (BoundedChan, readChan)+import Control.Concurrent.BoundedChan (BoundedChan, readChan, tryWriteChan) import Control.Concurrent.MVar (modifyMVar_, newMVar, readMVar) import Control.Exception (throw)-import Control.Monad (forM_, forever, when)+import Control.Monad (foldM, forM_, forever, void, when) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Resource (MonadResource, ResourceT, allocate, release)+import Crypto.Hash.SHA256 (hash) import Data.BloomFilter as Bloom (elem, insert, insertList) import Data.Bool (bool)-import Data.ByteString.Char8 (ByteString)+import Data.ByteString.Char8 as Byte (ByteString, take) import Data.ByteString.Lazy (fromStrict)-import Data.ByteString.Short (fromShort)-import Data.Conduit (Source, yield)+import Data.ByteString.Short (fromShort, toShort)+import Data.Conduit (ConduitM, await, yield) import Data.Default.Class (def)+import Data.List as List (delete, foldl', null) import Data.List.NonEmpty (NonEmpty(..), fromList) import Data.LruCache as LRU (empty, insert, lookup)-import Data.Map.Strict as Map (empty)+import Data.Map.Strict as Map ((!), delete, empty, insert, keys, lookup, member, null, singleton) import Data.Maybe (fromJust, isJust, isNothing, listToMaybe) import Data.Tuple (swap)-import Database.LevelDB (Options(..), defaultReadOptions, get, open)+import Database.LevelDB (DB, Options)  import Network.DFINITY.RadixTree.Bits import Network.DFINITY.RadixTree.Bloom@@ -81,23 +88,23 @@ -- | -- Create a radix tree. createRadixTree-   :: MonadResource m+   :: RadixDatabase config m database    => Int -- ^ Bloom filter size in bits.    -> Int -- ^ LRU cache size in items.-   -> FilePath -- ^ LevelDB database.-   -> Maybe RadixRoot -- ^ Last valid state root.-   -> m RadixTree+   -> Maybe RadixRoot -- ^ Previous state root.+   -> config -- ^ Database configuration.+   -> m (RadixTree database) {-# SPECIALISE createRadixTree    :: Int    -> Int-   -> FilePath    -> Maybe RadixRoot-   -> ResourceT IO RadixTree #-}-createRadixTree bloomSize cacheSize file checkpoint+   -> (FilePath, Options)+   -> ResourceT IO (RadixTree DB) #-}+createRadixTree bloomSize cacheSize checkpoint config    | bloomSize <= 0 = throw $ InvalidArgument "invalid Bloom filter size"    | cacheSize <= 0 = throw $ InvalidArgument "invalid LRU cache size"    | otherwise = do-      database <- open file $ def {createIfMissing = True}+      database <- create config       (root, cache') <-          case checkpoint of             Nothing -> storeCold def cache database@@ -112,16 +119,16 @@       cache = LRU.empty cacheSize  -- |--- Create a radix subtree from a radix tree.+-- Create a radix tree from a radix tree. subtreeRadixTree-   :: MonadIO m+   :: RadixDatabase config m database    => RadixRoot -- ^ State root.-   -> RadixTree -- ^ Radix tree.-   -> m RadixTree+   -> RadixTree database -- ^ Radix tree.+   -> m (RadixTree database) {-# SPECIALISE subtreeRadixTree    :: RadixRoot-   -> RadixTree-   -> ResourceT IO RadixTree #-}+   -> RadixTree DB+   -> ResourceT IO (RadixTree DB) #-} subtreeRadixTree root RadixTree {..} = do    result <- loadCold root cache _radixDatabase    case result of@@ -134,49 +141,49 @@ -- | -- Check if a radix tree is empty. isEmptyRadixTree-   :: RadixTree -- ^ Radix tree.+   :: RadixTree database -- ^ Radix tree.    -> Bool-{-# INLINE isEmptyRadixTree #-}+{-# INLINABLE isEmptyRadixTree #-} isEmptyRadixTree = (==) defaultRoot . _radixRoot  -- | -- Check if a state root is valid. isValidRadixRoot-   :: MonadIO m+   :: RadixDatabase config m database    => RadixRoot -- ^ State root.-   -> RadixTree -- ^ Radix tree.+   -> RadixTree database -- ^ Radix tree.    -> m Bool {-# SPECIALISE isValidRadixRoot    :: RadixRoot-   -> RadixTree+   -> RadixTree DB    -> ResourceT IO Bool #-} isValidRadixRoot root RadixTree {..} =-   isJust <$> get _radixDatabase defaultReadOptions key+   isJust <$> load _radixDatabase key    where    key = fromShort root  -- | -- Search for a value in a radix tree. searchRadixTree-   :: MonadIO m+   :: RadixDatabase config m database    => Bool -- ^ Overwrite state root?-   -> (RadixTree -> m (Maybe (RadixBranch, RadixCache))) -- ^ Loading strategy.+   -> (RadixTree database -> m (Maybe (RadixBranch, RadixCache))) -- ^ Loading strategy.    -> ByteString -- ^ Key.-   -> RadixTree -- ^ Radix tree.+   -> RadixTree database -- ^ Radix tree.    -> m (Either RadixError RadixSearchResult) {-# SPECIALISE searchRadixTree    :: Bool-   -> (RadixTree -> ResourceT IO (Maybe (RadixBranch, RadixCache)))+   -> (RadixTree DB -> ResourceT IO (Maybe (RadixBranch, RadixCache)))    -> ByteString-   -> RadixTree+   -> RadixTree DB    -> ResourceT IO (Either RadixError RadixSearchResult) #-}-searchRadixTree flag load = \ key tree@RadixTree {..} -> do+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 branches roots prefixes key tree@RadixTree {..} = do       -- Load the root branch.-      result <- load tree+      result <- strategy tree       case result of          Nothing -> pure $ Left $ StateRootDoesNotExist _radixRoot          Just (branch@RadixBranch {..}, cache') -> do@@ -191,10 +198,10 @@             let prefixes' = prefix:prefixes             let key' = drop n key             -- Check the termination criteria.-            let residue = not $ null overflow+            let residue = not $ List.null overflow             let bit = head key'             let child = bool _radixLeft _radixRight bit-            if null key' || residue || isNothing child+            if List.null key' || residue || isNothing child             then pure $ Right (fromList roots', fromList branches', fromList prefixes', overflow, key', cache')             else do                -- Recurse.@@ -206,13 +213,13 @@ -- | -- Search for a value in a Merkleized radix tree. searchMerkleizedRadixTree-   :: MonadIO m+   :: RadixDatabase config m database    => ByteString -- ^ Key.-   -> RadixTree -- ^ Radix tree.+   -> RadixTree database -- ^ Radix tree.    -> m (Either RadixError RadixSearchResult) {-# SPECIALISE searchMerkleizedRadixTree    :: ByteString-   -> RadixTree+   -> RadixTree DB    -> ResourceT IO (Either RadixError RadixSearchResult) #-} searchMerkleizedRadixTree =    searchRadixTree True $ \ RadixTree {..} ->@@ -221,13 +228,13 @@ -- | -- Search for a value in a non-Merkleized radix tree. searchNonMerkleizedRadixTree-   :: MonadIO m+   :: RadixDatabase config m database    => ByteString -- ^ Key.-   -> RadixTree -- ^ Radix tree.+   -> RadixTree database -- ^ Radix tree.    -> m (Either RadixError RadixSearchResult) {-# SPECIALISE searchNonMerkleizedRadixTree    :: ByteString-   -> RadixTree+   -> RadixTree DB    -> ResourceT IO (Either RadixError RadixSearchResult) #-} searchNonMerkleizedRadixTree =    searchRadixTree False $ \ RadixTree {..} ->@@ -236,16 +243,16 @@ -- | -- Insert a key and value into a radix tree. insertRadixTree-   :: MonadIO m+   :: RadixDatabase config m database    => ByteString -- ^ Key.    -> ByteString -- ^ Value.-   -> RadixTree -- ^ Radix tree.-   -> m RadixTree+   -> RadixTree database -- ^ Radix tree.+   -> m (RadixTree database) {-# SPECIALISE insertRadixTree    :: ByteString    -> ByteString-   -> RadixTree-   -> ResourceT IO RadixTree #-}+   -> RadixTree DB+   -> ResourceT IO (RadixTree DB) #-} insertRadixTree key value tree =    if isEmptyRadixTree tree    then pure $ initializeRadixTree key value tree@@ -264,9 +271,9 @@ initializeRadixTree    :: ByteString -- ^ Key.    -> ByteString -- ^ Value.-   -> RadixTree -- ^ Radix tree.-   -> RadixTree-{-# INLINE initializeRadixTree #-}+   -> RadixTree database -- ^ Radix tree.+   -> RadixTree database+{-# INLINABLE initializeRadixTree #-} initializeRadixTree key value tree@RadixTree {..} =    seq bloom $ setBloom bloom $ setBuffer buffer $ setRoot root tree    where@@ -280,9 +287,9 @@ insertRadixTreeAt    :: RadixSearchResult -- ^ Search result.    -> ByteString -- ^ Value.-   -> RadixTree -- ^ Radix tree.-   -> RadixTree-{-# INLINE insertRadixTreeAt #-}+   -> RadixTree database -- ^ Radix tree.+   -> RadixTree database+{-# INLINABLE insertRadixTreeAt #-} insertRadixTreeAt (_:|roots, branch:|branches, prefix:|_, _, _, cache) value tree@RadixTree {..} =    seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setRoot state tree    where@@ -297,9 +304,9 @@ insertRadixTreeAfter    :: RadixSearchResult -- ^ Search result.    -> ByteString -- ^ Value.-   -> RadixTree -- ^ Radix tree.-   -> RadixTree-{-# INLINE insertRadixTreeAfter #-}+   -> RadixTree database -- ^ Radix tree.+   -> RadixTree database+{-# INLINABLE insertRadixTreeAfter #-} insertRadixTreeAfter (_:|roots, branch:|branches, prefix:|_, _, keyOverflow, cache) value tree@RadixTree {..} =    seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setRoot state tree    where@@ -318,9 +325,9 @@ insertRadixTreeBefore    :: RadixSearchResult -- ^ Search result.    -> ByteString -- ^ Value.-   -> RadixTree -- ^ Radix tree.-   -> RadixTree-{-# INLINE insertRadixTreeBefore #-}+   -> RadixTree database -- ^ Radix tree.+   -> RadixTree database+{-# INLINABLE insertRadixTreeBefore #-} insertRadixTreeBefore (_:|roots, branch:|branches, prefix:|_, prefixOverflow, _, cache) value tree@RadixTree {..} =    seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setRoot state tree    where@@ -340,9 +347,9 @@ insertRadixTreeBetween    :: RadixSearchResult -- ^ Search result.    -> ByteString -- ^ Value.-   -> RadixTree -- ^ Radix tree.-   -> RadixTree-{-# INLINE insertRadixTreeBetween #-}+   -> RadixTree database -- ^ Radix tree.+   -> RadixTree database+{-# INLINABLE insertRadixTreeBetween #-} insertRadixTreeBetween (_:|roots, branch:|branches, prefix:|_, prefixOverflow, keyOverflow, cache) value tree@RadixTree {..} =    seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setRoot state tree    where@@ -365,14 +372,14 @@ -- | -- Delete a value from a radix tree. deleteRadixTree-   :: MonadIO m+   :: RadixDatabase config m database    => ByteString -- ^ Key.-   -> RadixTree -- ^ Radix tree.-   -> m RadixTree+   -> RadixTree database -- ^ Radix tree.+   -> m (RadixTree database) {-# SPECIALISE deleteRadixTree    :: ByteString-   -> RadixTree-   -> ResourceT IO RadixTree #-}+   -> RadixTree DB+   -> ResourceT IO (RadixTree DB) #-} deleteRadixTree key tree@RadixTree {..} =    if isEmptyRadixTree tree    then pure tree@@ -417,9 +424,9 @@ -- TODO (enzo): Documentation. deleteRadixTreeNoChildrenNoParent    :: RadixSearchResult -- ^ Search result.-   -> RadixTree -- ^ Radix tree.-   -> RadixTree-{-# INLINE deleteRadixTreeNoChildrenNoParent #-}+   -> RadixTree database -- ^ Radix tree.+   -> RadixTree database+{-# INLINABLE deleteRadixTreeNoChildrenNoParent #-} deleteRadixTreeNoChildrenNoParent (_, _, _, _, _, cache) tree@RadixTree {..} =    seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setRoot state tree    where@@ -430,9 +437,9 @@ -- TODO (enzo): Documentation. deleteRadixTreeNoChildrenParentWithLeaf    :: RadixSearchResult -- ^ Search result.-   -> RadixTree -- ^ Radix tree.-   -> RadixTree-{-# INLINE deleteRadixTreeNoChildrenParentWithLeaf #-}+   -> RadixTree database -- ^ Radix tree.+   -> RadixTree database+{-# INLINABLE deleteRadixTreeNoChildrenParentWithLeaf #-} deleteRadixTreeNoChildrenParentWithLeaf (_:|_:roots, _:|branch:branches, prefix:|prefixes, _, _, cache) tree@RadixTree {..} =    seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setRoot state tree    where@@ -443,6 +450,8 @@    bloom = flip insertList _radixBloom $ root':roots    buffer = merkleSpoof root' parent $ storeHot root' branch' _radixBuffer    state = bool _radixRoot root' $ isNothing parent+deleteRadixTreeNoChildrenParentWithLeaf _ _ =+   throw $ InvalidArgument "unknown parent"  -- TODO (enzo): Documentation. deleteRadixTreeNoChildrenParentWithoutLeaf@@ -450,9 +459,9 @@    -> RadixBranch -- ^ Branch.    -> RadixCache -- ^ Cache.    -> Bool -- ^ Lineage.-   -> RadixTree -- ^ Radix tree.-   -> RadixTree-{-# INLINE deleteRadixTreeNoChildrenParentWithoutLeaf #-}+   -> RadixTree database -- ^ Radix tree.+   -> RadixTree database+{-# INLINABLE deleteRadixTreeNoChildrenParentWithoutLeaf #-} deleteRadixTreeNoChildrenParentWithoutLeaf (_:|_:roots, _:|_:branches, _:|prefixes, _, _, _) branch@RadixBranch {..} cache test tree@RadixTree {..} =    seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setRoot state tree    where@@ -464,6 +473,8 @@    bloom = flip insertList _radixBloom $ root':roots    buffer = merkleSpoof root' parent $ storeHot root' branch' _radixBuffer    state = bool _radixRoot root' $ isNothing parent+deleteRadixTreeNoChildrenParentWithoutLeaf _ _ _ _ _ =+   throw $ InvalidArgument "unknown parent"  -- TODO (enzo): Documentation. deleteRadixTreeOneChild@@ -471,9 +482,9 @@    -> RadixBranch -- ^ Branch.    -> RadixCache -- ^ Cache.    -> Bool -- ^ Lineage.-   -> RadixTree -- ^ Radix tree.-   -> RadixTree-{-# INLINE deleteRadixTreeOneChild #-}+   -> RadixTree database -- ^ Radix tree.+   -> RadixTree database+{-# INLINABLE deleteRadixTreeOneChild #-} deleteRadixTreeOneChild (_:|roots, _:|branches, prefix:|_, _, _, _) branch@RadixBranch {..} cache test tree@RadixTree {..} =    seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setRoot state tree    where@@ -483,15 +494,15 @@    bits = prefix ++ test:maybe [] toBits _radixPrefix    parent = listToMaybe $ zip3 roots branches prefix    bloom = flip insertList _radixBloom $ root':roots-   buffer =  merkleSpoof root' parent $ storeHot root' branch' _radixBuffer+   buffer = merkleSpoof root' parent $ storeHot root' branch' _radixBuffer    state = bool _radixRoot root' $ isNothing parent  -- TODO (enzo): Documentation. deleteRadixTreeTwoChildren    :: RadixSearchResult -- ^ Search result.-   -> RadixTree -- ^ Radix tree.-   -> RadixTree-{-# INLINE deleteRadixTreeTwoChildren #-}+   -> RadixTree database -- ^ Radix tree.+   -> RadixTree database+{-# INLINABLE deleteRadixTreeTwoChildren #-} deleteRadixTreeTwoChildren (_:|roots, branch:|branches, prefix:|_, _, _, cache) tree@RadixTree {..} =    seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setRoot state tree    where@@ -505,22 +516,22 @@ -- | -- Lookup a value in a radix tree. lookupRadixTree-   :: MonadIO m-   => (ByteString -> RadixTree -> m (Either RadixError RadixSearchResult)) -- ^ Search algorithm.+   :: RadixDatabase config m database+   => (ByteString -> RadixTree database -> m (Either RadixError RadixSearchResult)) -- ^ Search algorithm.    -> ByteString -- ^ Key.-   -> RadixTree -- ^ Radix tree.-   -> m (Maybe (ByteString, RadixTree))+   -> RadixTree database -- ^ Radix tree.+   -> m (Maybe (ByteString, RadixTree database)) {-# SPECIALISE lookupRadixTree-   :: (ByteString -> RadixTree -> ResourceT IO (Either RadixError RadixSearchResult))+   :: (ByteString -> RadixTree DB -> ResourceT IO (Either RadixError RadixSearchResult))    -> ByteString-   -> RadixTree-   -> ResourceT IO (Maybe (ByteString, RadixTree)) #-}+   -> RadixTree DB+   -> ResourceT IO (Maybe (ByteString, RadixTree DB)) #-} lookupRadixTree search key tree = do    found <- search key tree    case found of       Left err -> throw err       Right (_, RadixBranch {..}:|_, _, prefixOverflow, keyOverflow, cache') ->-         if not $ null prefixOverflow && null keyOverflow+         if not $ List.null prefixOverflow && List.null keyOverflow          then pure Nothing          else pure $ do             value <- _radixLeaf@@ -530,27 +541,27 @@ -- | -- Lookup a value in a Merkleized radix tree. lookupMerkleizedRadixTree-   :: MonadIO m+   :: RadixDatabase config m database    => ByteString -- ^ Key.-   -> RadixTree -- ^ Radix tree.-   -> m (Maybe (ByteString, RadixTree))+   -> RadixTree database -- ^ Radix tree.+   -> m (Maybe (ByteString, RadixTree database)) {-# SPECIALISE lookupMerkleizedRadixTree    :: ByteString-   -> RadixTree-   -> ResourceT IO (Maybe (ByteString, RadixTree)) #-}+   -> RadixTree DB+   -> ResourceT IO (Maybe (ByteString, RadixTree DB)) #-} lookupMerkleizedRadixTree = lookupRadixTree searchMerkleizedRadixTree  -- | -- Lookup a value in a non-Merkleized radix tree. lookupNonMerkleizedRadixTree-   :: MonadIO m+   :: RadixDatabase config m database    => ByteString -- ^ Key.-   -> RadixTree -- ^ Radix tree.-   -> m (Maybe (ByteString, RadixTree))+   -> RadixTree database -- ^ Radix tree.+   -> m (Maybe (ByteString, RadixTree database)) {-# SPECIALISE lookupNonMerkleizedRadixTree    :: ByteString-   -> RadixTree-   -> ResourceT IO (Maybe (ByteString, RadixTree)) #-}+   -> RadixTree DB+   -> ResourceT IO (Maybe (ByteString, RadixTree DB)) #-} lookupNonMerkleizedRadixTree = lookupRadixTree searchNonMerkleizedRadixTree  -- |@@ -560,7 +571,7 @@    -> Maybe (RadixRoot, RadixBranch, Bool) -- ^ Parent.    -> RadixBuffer -- ^ Buffer.    -> RadixBuffer-{-# INLINE merkleSpoof #-}+{-# INLINABLE merkleSpoof #-} merkleSpoof mask = \ case    Nothing -> id    Just (root, branch, test) ->@@ -569,12 +580,12 @@ -- | -- Merkleize a radix tree. This will flush the buffer to disk. merkleizeRadixTree-   :: MonadIO m-   => RadixTree -- ^ Radix tree.-   -> m (RadixRoot, RadixTree)+   :: RadixDatabase config m database+   => RadixTree database-- ^ Radix tree.+   -> m (RadixRoot, RadixTree database) {-# SPECIALISE merkleizeRadixTree-   :: RadixTree-   -> ResourceT IO (RadixRoot, RadixTree) #-}+   :: RadixTree DB+   -> ResourceT IO (RadixRoot, RadixTree DB) #-} merkleizeRadixTree RadixTree {..} = do    (root, cache) <- loop _radixRoot _radixCache    let tree = RadixTree bloom _radixBloomSize Map.empty cache _radixCacheSize root _radixDatabase root@@ -615,18 +626,19 @@ -- Create a conduit from a Merkleized radix tree. sourceMerkleizedRadixTree    :: MonadResource m-   => [Bool] -- ^ Bit patten.+   => RadixDatabase config (ConduitM () ByteString m) database+   => [Bool] -- ^ Bit mask.    -> Int -- ^ LRU cache size in items.    -> BoundedChan RadixRoot -- ^ Terminal state root producer.-   -> RadixTree -- ^ Radix tree.-   -> Source m ByteString+   -> RadixTree database -- ^ Radix tree.+   -> ConduitM () ByteString m () {-# SPECIALISE sourceMerkleizedRadixTree    :: [Bool]    -> Int    -> BoundedChan RadixRoot-   -> RadixTree-   -> Source (ResourceT IO) ByteString #-}-sourceMerkleizedRadixTree patten cacheSize chan+   -> RadixTree DB+   -> ConduitM () ByteString (ResourceT IO) () #-}+sourceMerkleizedRadixTree mask cacheSize chan    | cacheSize <= 0 = throw $ InvalidArgument "invalid LRU cache size"    | otherwise = \ tree -> do       cache <- liftIO $ newMVar $ LRU.empty cacheSize@@ -643,35 +655,110 @@          then pure ()          else do             let key = fromShort _radixCheckpoint-            result <- get _radixDatabase defaultReadOptions key+            result <- load _radixDatabase key             case result of                Nothing -> pure ()                Just bytes -> do                   let RadixBranch {..} = deserialise $ fromStrict bytes-                  let success = all id $ zipWith (==) patten $ toBits $ fromShort _radixCheckpoint+                  let success = all id $ zipWith (==) mask $ toBits $ fromShort _radixCheckpoint                   when success $ yield bytes                   forM_ [_radixLeft, _radixRight] $ \ case                      Nothing -> pure ()                      Just root -> loop cache `flip` roots' $ setCheckpoint root tree  -- |+-- Create a Merkleized radix tree from a conduit.+sinkMerkleizedRadixTree+   :: MonadResource m+   => RadixDatabase config (ConduitM ByteString () m) database+   => RadixRoot -- ^ Target state root.+   -> BoundedChan RadixRoot -- ^ Terminal state root consumer.+   -> RadixTree database -- ^ Radix tree.+   -> ConduitM ByteString () m (Either [RadixRoot] (RadixTree database))+{-# SPECIALISE sinkMerkleizedRadixTree+   :: RadixRoot+   -> BoundedChan RadixRoot+   -> RadixTree DB+   -> ConduitM ByteString () (ResourceT IO) (Either [RadixRoot] (RadixTree DB)) #-}+sinkMerkleizedRadixTree checkpoint chan tree@RadixTree {..} =+   loop1 Map.empty $ singleton checkpoint Nothing where+   loop1 = \ buffer want ->+      if Map.null want+      then pure $ Right $ setCheckpoint checkpoint $ setRoot checkpoint tree+      else await >>= \ case+         Nothing -> pure $ Left $ keys want+         Just bytes ->+            case deserialiseOrFail $ fromStrict bytes of+               Right RadixBranch {..} -> do+                  let key = Byte.take 20 $ hash bytes+                  let root = toShort key+                  let wanted = member root want+                  exists <- if wanted+                     then pure False+                     else isJust <$> load _radixDatabase key+                  if exists+                  then loop1 buffer $ Map.delete root want+                  else do+                     children <- foldM step [] $ maybe id (:) _radixLeft $ maybe id (:) _radixRight []+                     let buffer' = Map.insert root (key, bytes, children) buffer+                     if not wanted+                     then loop1 buffer' want+                     else loop3 buffer' `uncurry` loop2 buffer' (want, []) root+               _ -> loop1 buffer want+      where+      step accum root = do+         valid <- isValidRadixRoot root tree+         if valid+         then pure accum+         else pure $ root:accum+   loop2 buffer accum@(want, candidates) root =+      case Map.lookup root buffer of+         Nothing -> accum+         Just (key, bytes, []) -> (want, (root, key, bytes):candidates)+         Just (_, _, children) ->+            let want' = foldr step want children+            in foldl' (loop2 buffer) (want', candidates) children+      where+      step = flip Map.insert $ Just root+   loop3 buffer want = \ case+      [] -> loop1 buffer want+      (root, key, bytes):candidates -> do+         store _radixDatabase key bytes+         let buffer' = Map.delete root buffer+         case want ! root of+            Nothing -> do+               let want' = Map.delete root want+               loop1 buffer' want'+            Just root' -> do+               let want' = Map.delete root want+               let (key', bytes', siblings') = buffer ! root'+               let children' = List.delete root siblings'+               if List.null children'+               then loop3 buffer' want' $ (root', key', bytes'):candidates+               else do+                  let buffer'' = Map.insert root' (key', bytes', children') buffer'+                  liftIO $ void $ tryWriteChan chan root+                  loop3 buffer'' want' candidates++-- | -- Print a radix tree. printRadixTree    :: MonadIO m+   => RadixDatabase config m database    => Bool -- ^ Overwrite state root?-   -> (RadixTree -> m (Maybe (RadixBranch, RadixCache))) -- ^ Loading strategy.-   -> RadixTree -- ^ Radix tree.+   -> (RadixTree database -> m (Maybe (RadixBranch, RadixCache))) -- ^ Loading strategy.+   -> RadixTree database -- ^ Radix tree.    -> m () {-# SPECIALISE printRadixTree    :: Bool-   -> (RadixTree -> ResourceT IO (Maybe (RadixBranch, RadixCache)))-   -> RadixTree+   -> (RadixTree DB -> ResourceT IO (Maybe (RadixBranch, RadixCache)))+   -> RadixTree DB    -> ResourceT IO () #-}-printRadixTree flag load = \ tree@RadixTree {..} -> do+printRadixTree flag strategy = \ tree@RadixTree {..} -> do    let tree' = tree `bool` setRoot _radixCheckpoint tree $ flag    loop tree' 0 where    loop tree@RadixTree {..} i = do-      result <- load tree+      result <- strategy tree       case fst <$> result of          Nothing -> throw $ StateRootDoesNotExist _radixRoot          Just branch@RadixBranch {..} -> do@@ -686,10 +773,11 @@ -- Print a Merkleized radix tree. printMerkleizedRadixTree    :: MonadIO m-   => RadixTree -- ^ Radix tree.+   => RadixDatabase config m database+   => RadixTree database -- ^ Radix tree.    -> m () {-# SPECIALISE printMerkleizedRadixTree-   :: RadixTree+   :: RadixTree DB    -> ResourceT IO () #-} printMerkleizedRadixTree =    printRadixTree True $ \ RadixTree {..} ->@@ -699,10 +787,11 @@ -- Print a non-Merkleized radix tree. printNonMerkleizedRadixTree    :: MonadIO m-   => RadixTree -- ^ Radix tree.+   => RadixDatabase config m database+   => RadixTree database -- ^ Radix tree.    -> m () {-# SPECIALISE printNonMerkleizedRadixTree-   :: RadixTree+   :: RadixTree DB    -> ResourceT IO () #-} printNonMerkleizedRadixTree =    printRadixTree False $ \ RadixTree {..} ->
src/Network/DFINITY/RadixTree/Lenses.hs view
@@ -56,19 +56,19 @@ getLeaf :: RadixBranch -> Maybe ByteString getLeaf = view radixLeaf -getBloom :: RadixTree -> RadixBloom+getBloom :: RadixTree database -> RadixBloom getBloom = view radixBloom -getBuffer :: RadixTree -> RadixBuffer+getBuffer :: RadixTree database -> RadixBuffer getBuffer = view radixBuffer -getCache :: RadixTree -> RadixCache+getCache :: RadixTree database -> RadixCache getCache = view radixCache -getCheckpoint :: RadixTree -> RadixRoot+getCheckpoint :: RadixTree database -> RadixRoot getCheckpoint = view radixCheckpoint -getRoot :: RadixTree -> RadixRoot+getRoot :: RadixTree database -> RadixRoot getRoot = view radixRoot  setPrefix :: Maybe RadixPrefix -> RadixBranch -> RadixBranch@@ -89,17 +89,17 @@ setLeaf :: Maybe ByteString -> RadixBranch -> RadixBranch setLeaf = set radixLeaf -setBloom :: RadixBloom -> RadixTree -> RadixTree+setBloom :: RadixBloom -> RadixTree database -> RadixTree database setBloom = set radixBloom -setBuffer :: RadixBuffer -> RadixTree -> RadixTree+setBuffer :: RadixBuffer -> RadixTree database -> RadixTree database setBuffer = set radixBuffer -setCache :: RadixCache -> RadixTree -> RadixTree+setCache :: RadixCache -> RadixTree database -> RadixTree database setCache = set radixCache -setCheckpoint :: RadixRoot -> RadixTree -> RadixTree+setCheckpoint :: RadixRoot -> RadixTree database -> RadixTree database setCheckpoint = set radixCheckpoint -setRoot :: RadixRoot -> RadixTree -> RadixTree+setRoot :: RadixRoot -> RadixTree database -> RadixTree database setRoot = set radixRoot
src/Network/DFINITY/RadixTree/Memory.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE RecordWildCards #-}- {-# OPTIONS -Wall #-}  module Network.DFINITY.RadixTree.Memory@@ -10,42 +8,53 @@    ) where  import Codec.Serialise (deserialise, serialise)-import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Resource (ResourceT) import Crypto.Hash.SHA256 (hash) import Data.ByteString.Char8 as Byte (take) 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 (defaultReadOptions, defaultWriteOptions, get, put)+import Database.LevelDB (DB)  import Network.DFINITY.RadixTree.Types  loadHot-   :: MonadIO m-   => RadixRoot -- ^ State root.-   -> RadixBuffer -- ^ Buffer.-   -> RadixCache -- ^ Cache.-   -> RadixDatabase -- ^ Database.+   :: RadixDatabase config m database+   => RadixRoot+   -> RadixBuffer+   -> RadixCache+   -> database    -> m (Maybe (RadixBranch, RadixCache))+{-# SPECIALISE loadHot+   :: RadixRoot+   -> RadixBuffer+   -> RadixCache+   -> DB+   -> ResourceT IO (Maybe (RadixBranch, RadixCache)) #-} loadHot root buffer cache database =    case Map.lookup root buffer of       Just branch -> pure $ Just (branch, cache)       Nothing -> loadCold root cache database  loadCold-   :: MonadIO m-   => RadixRoot -- ^ State root.-   -> RadixCache -- ^ Cache.-   -> RadixDatabase -- ^ Database.+   :: RadixDatabase config m database+   => RadixRoot+   -> RadixCache+   -> database    -> m (Maybe (RadixBranch, RadixCache))+{-# SPECIALISE loadCold+   :: RadixRoot+   -> RadixCache+   -> DB+   -> ResourceT IO (Maybe (RadixBranch, RadixCache)) #-} loadCold root cache database =    case LRU.lookup root cache of       Just (branch, cache') ->          seq cache' $ seq branch $ pure $ Just (branch, cache')       Nothing -> do          let key = fromShort root-         result <- get database defaultReadOptions key+         result <- load database key          case result of             Just bytes -> do                let branch = deserialise $ fromStrict bytes@@ -54,20 +63,25 @@             Nothing -> pure $ Nothing  storeHot-   :: RadixRoot -- ^ State root.-   -> RadixBranch -- ^ Branch.-   -> RadixBuffer -- ^ Buffer.+   :: RadixRoot+   -> RadixBranch    -> RadixBuffer+   -> RadixBuffer storeHot = Map.insert  storeCold-   :: MonadIO m-   => RadixBranch -- ^ Branch.-   -> RadixCache -- ^ Cache.-   -> RadixDatabase -- ^ Database.+   :: RadixDatabase config m database+   => RadixBranch+   -> RadixCache+   -> database    -> m (RadixRoot, RadixCache)+{-# SPECIALISE storeCold+   :: RadixBranch+   -> RadixCache+   -> DB+   -> ResourceT IO (RadixRoot, RadixCache) #-} storeCold branch cache database = do-   put database defaultWriteOptions key bytes+   store database key bytes    seq cache' $ pure (root, cache')    where    bytes = toStrict $ serialise branch
src/Network/DFINITY/RadixTree/Types.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-}  {-# OPTIONS -Wall #-}@@ -8,7 +11,7 @@    , RadixBranch(..)    , RadixBuffer    , RadixCache-   , RadixDatabase+   , RadixDatabase(..)    , RadixError(..)    , RadixPrefix(..)    , RadixRoot@@ -19,10 +22,11 @@ import Codec.Serialise as CBOR (Serialise(..), serialise) import Codec.Serialise.Decoding (decodeBytes, decodeInt, decodeListLen) import Codec.Serialise.Encoding (encodeBytes, encodeInt, encodeListLen)-import Crypto.Hash.SHA256 (hash) import Control.DeepSeq (NFData(..)) import Control.Exception (Exception) import Control.Monad (void)+import Control.Monad.Trans.Resource (MonadResource)+import Crypto.Hash.SHA256 (hash) import Data.BloomFilter (Bloom) import Data.Bool (bool) import Data.ByteString.Base16 as Base16 (encode)@@ -36,7 +40,7 @@ import Data.Map.Strict (Map) import Data.Maybe (isJust) import Data.Monoid ((<>))-import Database.LevelDB (DB)+import Database.LevelDB (DB, Options, defaultReadOptions, defaultWriteOptions, get, open, put) import Text.Printf (printf)  import Network.DFINITY.RadixTree.Bits@@ -100,8 +104,16 @@  type RadixCache = LruCache RadixRoot RadixBranch -type RadixDatabase = DB+class Monad m => RadixDatabase config m database | database -> config where+   create :: config -> m database+   load :: database -> ByteString -> m (Maybe ByteString)+   store :: database -> ByteString -> ByteString -> m () +instance MonadResource m => RadixDatabase (FilePath, Options) m DB where+   create = uncurry open+   load database = get database defaultReadOptions+   store database = put database defaultWriteOptions+ data RadixError    = InvalidArgument String    | StateRootDoesNotExist RadixRoot@@ -147,7 +159,7 @@  type RadixSearchResult = (NonEmpty RadixRoot, NonEmpty RadixBranch, NonEmpty [Bool], [Bool], [Bool], RadixCache) -data RadixTree+data RadixTree database    = RadixTree    { _radixBloom :: RadixBloom    , _radixBloomSize :: Int@@ -155,6 +167,6 @@    , _radixCache :: RadixCache    , _radixCacheSize :: Int    , _radixCheckpoint :: RadixRoot-   , _radixDatabase :: RadixDatabase+   , _radixDatabase :: database    , _radixRoot :: RadixRoot    }
test/Main.hs view
@@ -10,7 +10,7 @@  import Control.Monad (foldM_, mzero) import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Trans.Resource (runResourceT)+import Control.Monad.Trans.Resource (MonadResource, runResourceT) import Data.Aeson (FromJSON(..), Object, Value(..), eitherDecode) import Data.ByteString.Base16 (decode, encode) import Data.ByteString.Char8 (ByteString, unpack)@@ -20,19 +20,20 @@ import Data.HashMap.Strict as Map (elems, lookup) import Data.Text as Text (Text, drop) import Data.Text.Encoding (encodeUtf8)+import Database.LevelDB (DB, Options(..)) import System.Console.CmdArgs (Data, cmdArgs)  import Network.DFINITY.RadixTree  data Args    = Args-   { database :: FilePath-   , file :: FilePath+   { json :: FilePath+   , path :: FilePath    , test :: String    } deriving Data  instance Default Args where-   def = Args "test/testdb" "test/tests.json" "*"+   def = Args "test/tests.json" "test/testdb" "*"  data Op    = Insert ByteString ByteString@@ -53,7 +54,9 @@       Merkleize value -> "Merkleize" ++ pretty value       where pretty = mappend " 0x" . unpack . encode -parse :: Object -> Maybe Op+parse+   :: Object+   -> Maybe Op parse object = do    op <- Map.lookup "op" object    case op of@@ -63,14 +66,21 @@       "stateRoot" -> Merkleize <$> get "value" object       _ -> Nothing -get :: Text -> Object -> Maybe ByteString+get+   :: Text+   -> Object+   -> Maybe ByteString get key object = do    value <- Map.lookup key object    case value of       String text -> Just $ fst $ decode $ encodeUtf8 $ Text.drop 2 text       _ -> Nothing -step :: MonadIO m => RadixTree -> Op -> m RadixTree+step+   :: MonadResource m+   => RadixTree DB+   -> Op+   -> m (RadixTree DB) step tree op = do    liftIO $ print op    case op of@@ -109,11 +119,12 @@ main :: IO () main = do    Args {..} <- cmdArgs def-   contents <- Lazy.readFile file+   contents <- Lazy.readFile json    case eitherDecode contents of       Left err -> fail err       Right vctors -> runResourceT $ do-         tree <- createRadixTree 100 100 database Nothing+         let options = def {createIfMissing = True}+         tree <- createRadixTree 262144 2048 Nothing (path, options)          if test == "*"          then foldM_ step tree `mapM_` elems vctors          else case Map.lookup test vctors of