dfinity-radix-tree 0.2.1 → 0.3.0

raw patch · 8 files changed

+338/−214 lines, 8 filesdep +concurrent-extraPVP ok

version bump matches the API change (PVP)

Dependencies added: concurrent-extra

API changes (from Hackage documentation)

Files

• .travis.yml +10/−0
• CHANGELOG.md +6/−0
• dfinity-radix-tree.cabal +4/−1
• src/Network/DFINITY/RadixTree.hs +21/−211
• src/Network/DFINITY/RadixTree/Conduit.hs +214/−0
• src/Network/DFINITY/RadixTree/Lock.hs +29/−0
• test/Main.hs +1/−1
• test/tests.json +53/−1

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

@@ -1,3 +1,9 @@+0.3.0 Enzo Haussecker <enzo@dfinity.org> Thu Aug 02 2018++ * Add thread safety to parallel download combinators+ * Separate impure code from base module+ * Remove deprecated functions+ 0.2.1 Enzo Haussecker <enzo@dfinity.org> Wed Jul 25 2018   * Fix bug related to temporary reference creation

@@ -1,5 +1,5 @@ Name:               dfinity-radix-tree-Version:            0.2.1+Version:            0.3.0 Synopsis:           A generic data integrity layer. Description:    This library allows you to construct a Merkle tree on top of any underlying@@ -27,6 +27,7 @@       base16-bytestring,       bloomfilter,       bytestring,+      concurrent-extra,       conduit,       containers,       cryptohash-sha256,@@ -44,6 +45,7 @@       Haskell2010    Exposed-Modules:       Network.DFINITY.RadixTree+      Network.DFINITY.RadixTree.Conduit    GHC-Options:       -O2       -Wall@@ -54,6 +56,7 @@       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

@@ -1,10 +1,10 @@-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-}  {-# OPTIONS -Wall #-} {-# OPTIONS -Werror=incomplete-patterns #-}+{-# OPTIONS -fno-warn-unused-top-binds #-}  -- | -- Module     : Network.DFINITY.RadixTree@@ -26,7 +26,6 @@     -- ** Create    , createRadixTree-   , subtreeRadixTree     -- ** Insert    , insertRadixTree@@ -39,47 +38,34 @@     -- ** Query    , lookupRadixTree-   , lookupMerkleizedRadixTree-   , lookupNonMerkleizedRadixTree     -- ** Test    , isEmptyRadixTree    , isValidRadixRoot -   -- ** Stream-   , sourceMerkleizedRadixTree-   , sinkMerkleizedRadixTree-    -- ** Debug    , contentsRadixTree    , contentsMerkleizedRadixTree    , contentsNonMerkleizedRadixTree+    , printRadixTree    , printMerkleizedRadixTree    , printNonMerkleizedRadixTree     ) 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.Exception (throw)-import Control.Monad (foldM, forM_, forever, void, when)+import Control.Monad (foldM, forM_) import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Trans.Resource (MonadResource, ResourceT, allocate, release)-import Crypto.Hash.SHA256 (hash)+import Control.Monad.Trans.Resource (ResourceT) import Data.BloomFilter as Bloom (elem, insert, insertList) import Data.Bool (bool)-import Data.ByteString.Char8 as Byte (ByteString, take)-import Data.ByteString.Lazy (fromStrict)-import Data.ByteString.Short (fromShort, toShort)-import Data.Conduit (ConduitM, await, yield)+import Data.ByteString (ByteString)+import Data.ByteString.Short (fromShort) 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 ((!), delete, empty, insert, keys, lookup, member, null, singleton)+import Data.LruCache as LRU (empty)+import Data.Map.Strict as Map (empty) import Data.Maybe (fromJust, isJust, isNothing, listToMaybe) import Data.Tuple (swap) import Database.LevelDB (DB)@@ -124,26 +110,6 @@       cache = LRU.empty cacheSize  -- |--- Create a radix tree from a radix tree.-subtreeRadixTree-   :: RadixDatabase m database-   => RadixRoot -- ^ State root.-   -> RadixTree database -- ^ Radix tree.-   -> m (RadixTree database)-{-# SPECIALISE subtreeRadixTree-   :: RadixRoot-   -> RadixTree DB-   -> ResourceT IO (RadixTree DB) #-}-subtreeRadixTree root RadixTree {..} = do-   result <- loadCold root cache _radixDatabase-   case result of-      Nothing -> throw $ StateRootDoesNotExist root-      _ -> pure $ RadixTree bloom _radixBloomSize Map.empty cache _radixCacheSize root _radixDatabase 0 root-      where-      bloom = emptyRadixBloom _radixBloomSize-      cache = LRU.empty _radixCacheSize---- | -- Check if a radix tree is empty. isEmptyRadixTree    :: RadixTree database -- ^ Radix tree.@@ -203,10 +169,10 @@             let prefixes' = prefix:prefixes             let key' = drop n key             -- Check the termination criteria.-            let residue = not $ List.null overflow+            let residue = not $ null overflow             let bit = head key'             let child = bool _radixLeft _radixRight bit-            if List.null key' || residue || isNothing child+            if null key' || residue || isNothing child             then pure $ Right (fromList roots', fromList nodes', fromList prefixes', overflow, key', cache')             else do                -- Recurse.@@ -246,7 +212,7 @@       loadHot _radixRoot _radixBuffer _radixCache _radixDatabase  -- |--- Insert a key and value into a radix tree.+-- Insert a value into a radix tree. insertRadixTree    :: RadixDatabase m database    => ByteString -- ^ Key.@@ -285,7 +251,7 @@    prefix = createPrefix $ toBits key    node = setPrefix prefix $ Just value `setLeaf` def    root = createRootFromNonce _radixNonce-   bloom = Bloom.insert root _radixBloom+   bloom = insert root _radixBloom    nonce = _radixNonce + 1    buffer = storeHot root node _radixBuffer @@ -440,7 +406,7 @@ deleteRadixTreeNoChildrenNoParent (_, _, _, _, _, cache) tree@RadixTree {..} =    seq bloom $ setBloom bloom $ setBuffer buffer $ setCache cache $ setRoot state tree    where-   bloom = Bloom.insert defaultRoot _radixBloom+   bloom = insert defaultRoot _radixBloom    buffer = storeHot defaultRoot def _radixBuffer    state = defaultRoot @@ -529,23 +495,21 @@  -- | -- Lookup a value in a radix tree.-lookupRadixTree'+lookupRadixTree    :: RadixDatabase m database-   => (ByteString -> RadixTree database -> m (Either RadixError RadixSearchResult)) -- ^ Search algorithm.-   -> ByteString -- ^ Key.+   => ByteString -- ^ Key.    -> RadixTree database -- ^ Radix tree.    -> m (Maybe (ByteString, RadixTree database))-{-# SPECIALISE lookupRadixTree'-   :: (ByteString -> RadixTree DB -> ResourceT IO (Either RadixError RadixSearchResult))-   -> ByteString+{-# SPECIALISE lookupRadixTree+   :: ByteString    -> RadixTree DB    -> ResourceT IO (Maybe (ByteString, RadixTree DB)) #-}-lookupRadixTree' search key tree = do-   found <- search key tree+lookupRadixTree key tree = do+   found <- searchNonMerkleizedRadixTree key tree    case found of       Left err -> throw err       Right (_, RadixNode {..}:|_, _, prefixOverflow, keyOverflow, cache') ->-         if not $ List.null prefixOverflow && List.null keyOverflow+         if not $ null prefixOverflow && null keyOverflow          then pure Nothing          else pure $ do             value <- _radixLeaf@@ -553,42 +517,6 @@             pure (value, tree')  -- |--- A convenient alias for `lookupNonMerkleizedRadixTree`.-lookupRadixTree-   :: RadixDatabase m database-   => ByteString -- ^ Key.-   -> RadixTree database -- ^ Radix tree.-   -> m (Maybe (ByteString, RadixTree database))-{-# SPECIALISE lookupRadixTree-   :: ByteString-   -> RadixTree DB-   -> ResourceT IO (Maybe (ByteString, RadixTree DB)) #-}-lookupRadixTree = lookupNonMerkleizedRadixTree---- |--- Lookup a value in a Merkleized radix tree.-lookupMerkleizedRadixTree-   :: RadixDatabase m database-   => ByteString -- ^ Key.-   -> RadixTree database -- ^ Radix tree.-   -> m (Maybe (ByteString, RadixTree database))-{-# DEPRECATED lookupMerkleizedRadixTree "The function is will be removed in the next release. Please use 'lookupRadixTree' instead." #-}-lookupMerkleizedRadixTree = lookupRadixTree' searchMerkleizedRadixTree---- |--- Lookup a value in a non-Merkleized radix tree.-lookupNonMerkleizedRadixTree-   :: RadixDatabase m database-   => ByteString -- ^ Key.-   -> RadixTree database -- ^ Radix tree.-   -> m (Maybe (ByteString, RadixTree database))-{-# SPECIALISE lookupNonMerkleizedRadixTree-   :: ByteString-   -> RadixTree DB-   -> ResourceT IO (Maybe (ByteString, RadixTree DB)) #-}-lookupNonMerkleizedRadixTree = lookupRadixTree' searchNonMerkleizedRadixTree---- | -- Mask a node in a Merkleized radix tree. merkleSpoof    :: RadixRoot -- ^ State root.@@ -602,7 +530,7 @@       storeHot root $ test `setChild` Just mask $ node  -- |--- Merkleize a radix tree. This will flush the buffer to disk.+-- Merkleize a radix tree. This will flush the buffer to the database. merkleizeRadixTree    :: RadixDatabase m database    => RadixTree database-- ^ Radix tree.@@ -645,124 +573,6 @@                      (root'', cache''') <- loop right cache''                      let node' = setChildren (Just root', Just root'') node                      storeCold node' cache''' _radixDatabase---- |--- Create a conduit from a Merkleized radix tree.-sourceMerkleizedRadixTree-   :: MonadResource m-   => RadixDatabase (ConduitM () ByteString m) database-   => [Bool] -- ^ Bit mask.-   -> Int -- ^ LRU cache size in items.-   -> BoundedChan RadixRoot -- ^ Terminal state root producer.-   -> RadixTree database -- ^ Radix tree.-   -> ConduitM () ByteString m ()-{-# SPECIALISE sourceMerkleizedRadixTree-   :: [Bool]-   -> Int-   -> BoundedChan RadixRoot-   -> 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-      (,) action _ <- flip allocate killThread $ forkIO $ forever $ do-         root <- readChan chan-         modifyMVar_ cache $ pure . LRU.insert root ()-      loop cache tree []-      release action-      where-      loop cache tree@RadixTree {..} roots = do-         seen <- liftIO $ readMVar cache-         let roots' = _radixCheckpoint:roots-         if flip any roots' $ isJust . flip LRU.lookup seen-         then pure ()-         else do-            let key = fromShort _radixCheckpoint-            result <- 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` roots' $ setCheckpoint root tree---- |--- Create a Merkleized radix tree from a conduit.-sinkMerkleizedRadixTree-   :: MonadResource m-   => RadixDatabase (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 RadixNode {..} -> 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  -- | -- Get the contents of a radix tree.

@@ -0,0 +1,214 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS -Wall #-}+{-# OPTIONS -Werror=incomplete-patterns #-}++-- |+-- 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.SHA256 (hash)+import Data.ByteString.Lazy (fromStrict)+import Data.ByteString.Short (ShortByteString, fromShort, toShort)+import Data.ByteString.Char8 as Byte (ByteString, take)+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 ()+{-# SPECIALISE sourceRadixTree+   :: [Bool]+   -> Int+   -> BoundedChan RadixRoot+   -> RadixTree DB+   -> RWLock+   -> ConduitT () ByteString (ResourceT IO) () #-}+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++-- |+-- 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))+{-# SPECIALISE sinkRadixTree+   :: RadixRoot+   -> BoundedChan RadixRoot+   -> RadixTree DB+   -> RWLock+   -> ConduitT ByteString Void (ResourceT IO) (Either [RadixRoot] (RadixTree DB)) #-}+sinkRadixTree checkpoint chan tree@RadixTree {..} lock =+   loop1 Map.empty $ 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 $ 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 = Byte.take 20 $ hash bytes+                     let root = toShort key+                     let want = member root targets+                     exists <- if want+                        then pure False+                        else do+                           result <- withReadLock lock $ load _radixDatabase key+                           pure $ isJust result+                     if exists+                     then loop1 buffer $ Map.delete root 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'

@@ -0,0 +1,29 @@+{-# OPTIONS -Wall #-}++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

@@ -84,7 +84,7 @@          printNonMerkleizedRadixTree tree'          pure tree'       Lookup key value -> do-         result <- lookupNonMerkleizedRadixTree key tree+         result <- lookupRadixTree key tree          case result of             Just (value', tree') | value == value' -> pure tree'             Just (value', _) -> throw

@@ -5,7 +5,7 @@       "value": "0x4cf812be9be2c6008325050f43d06676a08612c7"     }   ],-  "setAndGet": [+  "insert_and_lookup": [     {       "op": "set",       "key": "0x74657374",@@ -62,6 +62,58 @@       "op": "get",       "key": "0x74657374",       "value": "0x636174313131"+    }+  ],+  "insert_and_lookup_2": [+    {+      "op": "set",+      "key": "0x61",+      "value": "0x3239"+    },+    {+      "op": "set",+      "key": "0x612f",+      "value": "0x3136313438"+    },+    {+      "op": "set",+      "key": "0x612f30",+      "value": "0x36373132"+    },+    {+      "op": "set",+      "key": "0x612f31",+      "value": "0x3732"+    },+    {+      "op": "set",+      "key": "0x62",+      "value": "0x3237"+    },+    {+      "op": "set",+      "key": "0x622f",+      "value": "0x3136313438"+    },+    {+      "op": "set",+      "key": "0x622f30",+      "value": "0x36373132"+    },+    {+      "op": "set",+      "key": "0x622f31",+      "value": "0x3232"+    },+    {+      "op": "set",+      "key": "0x622f31",+      "value": "0x3730"+    },+    {+      "op": "get",+      "key": "0x612f31",+      "value": "0x3732"     }   ],   "insert_and_delete": [