merkle-patricia-db (empty) → 0.1.0
raw patch · 14 files changed
+1419/−0 lines, 14 filesdep +HUnitdep +aesondep +ansi-wl-pprintsetup-changed
Dependencies added: HUnit, aeson, ansi-wl-pprint, base, base16-bytestring, binary, bytestring, containers, cryptonite, data-default, ethereum-rlp, hspec, hspec-contrib, leveldb-haskell, memory, merkle-patricia-db, mtl, nibblestring, resourcet, test-framework, test-framework-hunit, text, transformers
Files
- LICENSE +13/−0
- Setup.hs +8/−0
- merkle-patricia-db.cabal +82/−0
- src/Blockchain/Database/KeyVal.hs +83/−0
- src/Blockchain/Database/MerklePatricia.hs +79/−0
- src/Blockchain/Database/MerklePatricia/Diff.hs +79/−0
- src/Blockchain/Database/MerklePatricia/Internal.hs +301/−0
- src/Blockchain/Database/MerklePatricia/InternalMem.hs +290/−0
- src/Blockchain/Database/MerklePatricia/MPDB.hs +35/−0
- src/Blockchain/Database/MerklePatricia/Map.hs +50/−0
- src/Blockchain/Database/MerklePatricia/NodeData.hs +142/−0
- src/Blockchain/Database/MerklePatricia/StateRoot.hs +65/−0
- src/Blockchain/Database/MerklePatriciaMem.hs +58/−0
- test/MerklePatriciaSpec.hs +134/−0
+ LICENSE view
@@ -0,0 +1,13 @@+Copyright 2016 BlockApps, Inc++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.
+ Setup.hs view
@@ -0,0 +1,8 @@++module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain+
+ merkle-patricia-db.cabal view
@@ -0,0 +1,82 @@+name: merkle-patricia-db+version: 0.1.0+cabal-version: >= 1.10+build-type: Simple+author: Jamshid+license-file: LICENSE+maintainer: jamshidnh@gmail.com+synopsis: A modified Merkle Patricia DB+category: Data Structures+license: Apache-2.0+description: + The modified Merkle Patricia DB described in the Ethereum Yellowpaper++source-repository head+ type: git+ location: https://github.com/jamshidh/ethereum-merkle-patricia-db++source-repository this+ type: git+ location: https://github.com/jamshidh/ethereum-merkle-patricia-db+ branch: master+ tag: v0.0.1+ +library+ default-language: Haskell2010+ build-depends: base >= 4 && < 5+ , base16-bytestring+ , binary+ , bytestring+ , cryptonite+ , data-default+ , ethereum-rlp+ , leveldb-haskell+ , nibblestring+ , resourcet+ , transformers+ , ansi-wl-pprint+ , containers+ , mtl+ , memory+ , text+ exposed-modules: Blockchain.Database.MerklePatricia+ , Blockchain.Database.MerklePatriciaMem+ , Blockchain.Database.KeyVal+ , Blockchain.Database.MerklePatricia.Internal+ , Blockchain.Database.MerklePatricia.InternalMem+ , Blockchain.Database.MerklePatricia.Diff+ , Blockchain.Database.MerklePatricia.Map+ , Blockchain.Database.MerklePatricia.NodeData+ , Blockchain.Database.MerklePatricia.MPDB+ , Blockchain.Database.MerklePatricia.StateRoot+ ghc-options: -Wall+ -fwarn-unused-imports+ buildable: True+ hs-source-dirs: src+++test-suite test-merkle-patricia-db+ default-language: Haskell2010+ hs-source-dirs: test+ type: exitcode-stdio-1.0+ main-is: MerklePatriciaSpec.hs+ build-depends: base >=4 && < 5+ , data-default+ , leveldb-haskell+ , resourcet+ , bytestring+ , base16-bytestring+ , transformers+ , binary+ , ethereum-rlp+ , nibblestring+ , ansi-wl-pprint+ , test-framework+ , test-framework-hunit+ , HUnit+ , containers+ , aeson+ , mtl+ , hspec+ , hspec-contrib+ , merkle-patricia-db
+ src/Blockchain/Database/KeyVal.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Blockchain.Database.KeyVal (+ PointedKeyValDB(..),+ KeyValMPLevelDB,+ KeyValMPMap+ ) where++import Blockchain.Database.MerklePatricia+import Blockchain.Database.MerklePatriciaMem+import Control.Monad.Trans+import Control.Monad.Trans.Resource+import Control.Monad.Trans.State++{-+ A general interface for a key value "database" with a distinguished element+ representing a "snapshot" or "summary" of the database. The "snapshot" can also+ include the database handle or connection string.++ Below, a and b represent key and value types respectively, and c is the type of the+ "snapshot".++ The unfortunate parameter t represents in some cases a file path for the on disk+ db.+-}++class (Monad m) => PointedKeyValDB m a b c t | c -> t where+ getKV :: Monad m => a-> m (Maybe b)+ putKV :: Monad m => (a,b) -> m c+ deleteKV :: Monad m => a -> m c+ emptyKV :: Monad m => t -> m c++type KeyValMPLevelDB m = StateT MPDB (ResourceT m)+type KeyValMPMap m = StateT MPMem m++data Void++instance (+ Monad m,+ MonadBaseControl IO m,+ MonadThrow m,+ MonadIO m+ )+ => PointedKeyValDB (KeyValMPLevelDB m) Key Val MPDB String where++ getKV key = do+ db <- get+ runResourceT $ getKeyVal db key++ putKV kvPair = do+ db <- get+ runResourceT $ putKeyVal db (fst kvPair) (snd kvPair)++ deleteKV key = do+ db <- get+ runResourceT $ deleteKey db key++ emptyKV path = liftIO $ runResourceT $ openMPDB path -- fix++instance (+ Monad m+ )+ => PointedKeyValDB (KeyValMPMap m) Key Val MPMem Void where++ getKV key = do+ db <- get+ getKeyValMem db key++ putKV kvPair = do+ db <- get+ putKeyValMem db (fst kvPair) (snd kvPair)++ deleteKV key = do+ db <- get+ deleteKeyMem db key++ emptyKV _ = return initializeBlankMem -- fix
+ src/Blockchain/Database/MerklePatricia.hs view
@@ -0,0 +1,79 @@+-- | This is an implementation of the modified Merkle Patricia database+-- described in the Ethereum Yellowpaper+-- (<http://gavwood.com/paper.pdf>). This modified version works like a+-- canonical Merkle Patricia database, but includes certain+-- optimizations. In particular, a new type of "shortcut node" has been+-- added to represent multiple traditional nodes that fall in a linear+-- string (ie- a stretch of parent child nodes where no branch choices+-- exist).+--+-- A Merkle Patricia Database effeciently retains its full history, and a+-- snapshot of all key-value pairs at a given time can be looked up using+-- a "stateRoot" (a pointer to the root of the tree representing that+-- data). Many of the functions in this module work by updating this+-- object, so for anything more complicated than a single update, use of+-- the state monad is recommended.+--+-- The underlying data is actually stored in LevelDB. This module+-- provides the logic to organize the key-value pairs in the appropriate+-- Patricia Merkle Tree.++module Blockchain.Database.MerklePatricia (+ Key, Val, MPDB(..), StateRoot(..),+ openMPDB, emptyTriePtr, sha2StateRoot, unboxStateRoot,+ putKeyVal, getKeyVal, deleteKey, keyExists,+ initializeBlank+ ) where++import Control.Monad.Trans.Resource+import Data.Default+import Data.Maybe (isJust)+import qualified Database.LevelDB as DB++import Blockchain.Data.RLP+import Blockchain.Database.MerklePatricia.Internal+++-- | Adds a new key/value pair.+putKeyVal::MonadResource m=>MPDB -- ^ The object containing the current stateRoot.+ ->Key -- ^ Key of the data to be inserted.+ ->Val -- ^ Value of the new data+ ->m MPDB -- ^ The object containing the stateRoot to the data after the insert.+putKeyVal db = unsafePutKeyVal db . keyToSafeKey++-- | Retrieves all key/value pairs whose key starts with the given parameter.+getKeyVal::MonadResource m=>MPDB -- ^ Object containing the current stateRoot.+ -> Key -- ^ Key of the data to be inserted.+ -> m (Maybe Val) -- ^ The requested value.+getKeyVal db key = do+ vals <- unsafeGetKeyVals db (keyToSafeKey key)+ return $+ if not (null vals)+ then Just $ snd (head vals)+ -- Since we hash the keys, it's impossible+ -- for vals to have more than one item+ else Nothing++-- | Deletes a key (and its corresponding data) from the database.+--+-- Note that the key/value pair will still be present in the history, and+-- can be accessed by using an older 'MPDB' object.+deleteKey::MonadResource m=>MPDB -- ^ The object containing the current stateRoot.+ ->Key -- ^ The key to be deleted.+ ->m MPDB -- ^ The object containing the stateRoot to the data after the delete.+deleteKey db = unsafeDeleteKey db . keyToSafeKey++-- | Returns True is a key exists.+keyExists::MonadResource m=>MPDB -- ^ The object containing the current stateRoot.+ ->Key -- ^ The key to be deleted.+ ->m Bool -- ^ True if the key exists+keyExists db key = isJust <$> getKeyVal db key++-- | Initialize the DB by adding a blank stateroot.+initializeBlank::MonadResource m=>MPDB -- ^ The object containing the current stateRoot.+ ->m ()+initializeBlank db =+ let bytes = rlpSerialize $ rlpEncode (0::Integer)+ StateRoot key = emptyTriePtr+ in DB.put (ldb db) def key bytes+
+ src/Blockchain/Database/MerklePatricia/Diff.hs view
@@ -0,0 +1,79 @@+module Blockchain.Database.MerklePatricia.Diff (dbDiff, DiffOp(..)) where++import Blockchain.Database.MerklePatricia.Internal+import Blockchain.Database.MerklePatricia.NodeData++import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Resource+import Data.Function+import qualified Data.NibbleString as N++-- Probably the entire MPDB system ought to be in this monad+type MPReaderM a = ReaderT MPDB a++data MPChoice = Data NodeData | Ref NodeRef | Value Val | None deriving (Eq)++node :: MonadResource m=>MPChoice -> MPReaderM m NodeData+node (Data nd) = return nd+node (Ref nr) = do+ derefNode <- asks getNodeData+ lift $ derefNode nr+node _ = return EmptyNodeData++simplify :: NodeData -> [MPChoice]+simplify EmptyNodeData = replicate 17 None -- 17: not a mistake+simplify FullNodeData{ choices = ch, nodeVal = v } =+ maybe None Value v : map Ref ch+simplify n@ShortcutNodeData{ nextNibbleString = k, nextVal = v } = None : delta h+ where+ delta m =+ let pre = replicate m None+ post = replicate (16 - m - 1) None+ in pre ++ [x] ++ post+ x | N.null t = either Ref Value v+ | otherwise = Data n{ nextNibbleString = t }+ (h,t) = (fromIntegral $ N.head k, N.tail k)++enter :: MonadResource m=>MPChoice -> MPReaderM m [MPChoice]+enter = liftM simplify . node++data DiffOp =+ Create {key::[N.Nibble], val::Val} |+ Update {key::[N.Nibble], oldVal::Val, newVal::Val} |+ Delete {key::[N.Nibble], oldVal::Val}+ deriving (Show, Eq)++diffChoice :: MonadResource m=>Maybe N.Nibble -> MPChoice -> MPChoice -> MPReaderM m [DiffOp]+diffChoice n ch1 ch2 = case (ch1, ch2) of+ (None, Value v) -> return [Create sn v]+ (Value v, None) -> return [Delete sn v]+ (Value v1, Value v2)+ | v1 /= v2 -> return [Update sn v1 v2]+ _ | ch1 == ch2 -> return []+ | otherwise -> pRecurse ch1 ch2+ where+ sn = maybe [] (:[]) n+ prefix =+ let prepend n' op = op{key = n':(key op)}+ in map (maybe id prepend n)+ pRecurse = liftM prefix .* recurse++diffChoices :: MonadResource m=>[MPChoice] -> [MPChoice] -> MPReaderM m [DiffOp]+diffChoices =+ liftM concat .* sequence .* zipWith3 diffChoice maybeNums+ where maybeNums = Nothing : map Just [0..]++recurse :: MonadResource m=>MPChoice -> MPChoice -> MPReaderM m [DiffOp]+recurse = join .* (liftM2 diffChoices `on` enter)++infixr 9 .*+(.*) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)+(.*) = (.) . (.)++diff :: MonadResource m=>NodeRef -> NodeRef -> MPReaderM m [DiffOp]+diff = recurse `on` Ref++dbDiff :: MonadResource m => MPDB -> StateRoot -> StateRoot -> m [DiffOp]+dbDiff db root1 root2 = runReaderT ((diff `on` PtrRef) root1 root2) db
+ src/Blockchain/Database/MerklePatricia/Internal.hs view
@@ -0,0 +1,301 @@+{-# LANGUAGE OverloadedStrings #-}++module Blockchain.Database.MerklePatricia.Internal (+ Key,+ Val,+ MPDB(..),+ StateRoot(..),+ NodeData(..),+ openMPDB,+ emptyTriePtr,+ sha2StateRoot,+ unboxStateRoot,+ unsafePutKeyVal,+ unsafeGetKeyVals,+ unsafeGetAllKeyVals,+ unsafeDeleteKey,+ getNodeData,+ putNodeData,+ keyToSafeKey,+ getCommonPrefix,+ replace,+ prependToKey+ ) where++import Control.Monad.Trans.Resource+import Data.ByteArray (convert)+import Crypto.Hash as Crypto+import qualified Data.ByteString as B+import Data.Default+import Data.Function+import Data.List+import Data.Maybe+import qualified Data.NibbleString as N+import qualified Database.LevelDB as DB++import Blockchain.Data.RLP+import Blockchain.Database.MerklePatricia.MPDB+import Blockchain.Database.MerklePatricia.NodeData+import Blockchain.Database.MerklePatricia.StateRoot++unsafePutKeyVal::MonadResource m=>MPDB->Key->Val->m MPDB+unsafePutKeyVal db key val = do+ dbNodeData <- getNodeData db (PtrRef $ stateRoot db)+ dbPutNodeData <- putKV_NodeData db key val dbNodeData+ p <- putNodeData db dbPutNodeData+ return db{stateRoot=p}++unsafeGetKeyVals::MonadResource m=>MPDB->Key->m [(Key, Val)]+unsafeGetKeyVals db =+ let dbNodeRef = PtrRef $ stateRoot db+ in getKeyVals_NodeRef db dbNodeRef++unsafeGetAllKeyVals::MonadResource m=>MPDB->m [(Key, Val)]+unsafeGetAllKeyVals db = unsafeGetKeyVals db N.empty++unsafeDeleteKey::MonadResource m=>MPDB->Key->m MPDB+unsafeDeleteKey db key = do+ dbNodeData <- getNodeData db (PtrRef $ stateRoot db)+ dbDeleteNodeData <- deleteKey_NodeData db key dbNodeData+ p <- putNodeData db dbDeleteNodeData+ return db{stateRoot=p}++keyToSafeKey::N.NibbleString->N.NibbleString+keyToSafeKey key =+ N.EvenNibbleString $ convert $ (Crypto.hash keyByteString :: Crypto.Digest Crypto.Keccak_256)+ where+ N.EvenNibbleString keyByteString = key+++putKV_NodeData::MonadResource m=>MPDB->Key->Val->NodeData->m NodeData++putKV_NodeData _ key val EmptyNodeData =+ return $ ShortcutNodeData key (Right val)++putKV_NodeData db key val (FullNodeData options nodeValue)+ | options `slotIsEmpty` N.head key =+ do+ tailNode <- newShortcut db (N.tail key) $ Right val+ return $ FullNodeData (replace options (N.head key) tailNode) nodeValue++ | otherwise =+ do+ let conflictingNodeRef = options!!fromIntegral (N.head key)+ newNode <- putKV_NodeRef db (N.tail key) val conflictingNodeRef+ return $ FullNodeData (replace options (N.head key) newNode) nodeValue++putKV_NodeData db key1 val1 (ShortcutNodeData key2 val2)+ | key1 == key2 =+ case val2 of+ Right _ -> return $ ShortcutNodeData key1 $ Right val1+ Left ref -> do+ newNodeRef <- putKV_NodeRef db key1 val1 ref+ return $ ShortcutNodeData key2 (Left newNodeRef)++ | N.null key1 = do+ newNodeRef <- newShortcut db (N.tail key2) val2+ return $ FullNodeData (list2Options 0 [(N.head key2, newNodeRef)]) $ Just val1++ | key1 `N.isPrefixOf` key2 = do+ tailNode <- newShortcut db (N.drop (N.length key1) key2) val2+ modifiedTailNode <- putKV_NodeRef db "" val1 tailNode+ return $ ShortcutNodeData key1 $ Left modifiedTailNode++ | key2 `N.isPrefixOf` key1 =+ case val2 of+ Right val -> putKV_NodeData db key2 val (ShortcutNodeData key1 $ Right val1)+ Left ref -> do+ newNode <- putKV_NodeRef db (N.drop (N.length key2) key1) val1 ref+ return $ ShortcutNodeData key2 $ Left newNode++ | N.head key1 == N.head key2 =+ let (commonPrefix, suffix1, suffix2) =+ getCommonPrefix (N.unpack key1) (N.unpack key2)+ in do+ nodeAfterCommonBeforePut <- newShortcut db (N.pack suffix2) val2+ nodeAfterCommon <- putKV_NodeRef db (N.pack suffix1) val1 nodeAfterCommonBeforePut+ return $ ShortcutNodeData (N.pack commonPrefix) $ Left nodeAfterCommon++ | otherwise = do+ tailNode1 <- newShortcut db (N.tail key1) $ Right val1+ tailNode2 <- newShortcut db (N.tail key2) val2+ return $ FullNodeData+ (list2Options 0 $ sortBy (compare `on` fst)+ [(N.head key1, tailNode1), (N.head key2, tailNode2)])+ Nothing++-----++getKeyVals_NodeData::MonadResource m=>MPDB->NodeData->Key->m [(Key, Val)]++getKeyVals_NodeData _ EmptyNodeData _ = return []++getKeyVals_NodeData db (FullNodeData {choices=cs}) "" = do+ partialKVs <- sequence $ (\ref -> getKeyVals_NodeRef db ref "") <$> cs+ return $ concatMap+ (uncurry $ map . (prependToKey . N.singleton)) (zip [0..] partialKVs)++getKeyVals_NodeData db (FullNodeData {choices=cs}) key+ | ref == emptyRef = return []+ | otherwise = fmap (prependToKey $ N.singleton $ N.head key) <$>+ getKeyVals_NodeRef db ref (N.tail key)+ where ref = cs !! fromIntegral (N.head key)++getKeyVals_NodeData db ShortcutNodeData{nextNibbleString=s, nextVal=Left ref} key+ | key `N.isPrefixOf` s = prependNext ""+ | s `N.isPrefixOf` key = prependNext $ N.drop (N.length s) key+ | otherwise = return []+ where prependNext key' = fmap (prependToKey s) <$> getKeyVals_NodeRef db ref key'++getKeyVals_NodeData _ ShortcutNodeData{nextNibbleString=s, nextVal=Right val} key =+ return $+ if key `N.isPrefixOf` s+ then [(s,val)]+ else []++-----++deleteKey_NodeData::MonadResource m=>MPDB->Key->NodeData->m NodeData++deleteKey_NodeData _ _ EmptyNodeData = return EmptyNodeData++deleteKey_NodeData db key nd@(FullNodeData options val)+ | N.null key = return $ FullNodeData options Nothing++ | options `slotIsEmpty` N.head key = return nd++ | otherwise = do+ let nodeRef = options!!fromIntegral (N.head key)+ newNodeRef <- deleteKey_NodeRef db (N.tail key) nodeRef+ let newOptions = replace options (N.head key) newNodeRef+ simplify_NodeData db $ FullNodeData newOptions val++deleteKey_NodeData _ key1 nd@(ShortcutNodeData key2 (Right _)) =+ return $+ if key1 == key2+ then EmptyNodeData+ else nd++deleteKey_NodeData db key1 nd@(ShortcutNodeData key2 (Left ref))+ | key2 `N.isPrefixOf` key1 = do+ newNodeRef <- deleteKey_NodeRef db (N.drop (N.length key2) key1) ref+ simplify_NodeData db $ ShortcutNodeData key2 $ Left newNodeRef++ | otherwise = return nd++-----++putKV_NodeRef::MonadResource m=>MPDB->Key->Val->NodeRef->m NodeRef+putKV_NodeRef db key val nodeRef = do+ nodeData <- getNodeData db nodeRef+ newNodeData <- putKV_NodeData db key val nodeData+ nodeData2NodeRef db newNodeData+++getKeyVals_NodeRef::MonadResource m=>MPDB->NodeRef->Key->m [(Key, Val)]+getKeyVals_NodeRef db ref key = do+ nodeData <- getNodeData db ref+ getKeyVals_NodeData db nodeData key++--TODO- This is looking like a lift, I probably should make NodeRef some sort of Monad....++deleteKey_NodeRef::MonadResource m=>MPDB->Key->NodeRef->m NodeRef+deleteKey_NodeRef db key nodeRef =+ nodeData2NodeRef db =<< deleteKey_NodeData db key =<< getNodeData db nodeRef++-----++getNodeData::MonadResource m=>MPDB->NodeRef->m NodeData+getNodeData _ (SmallRef x) = return $ rlpDecode $ rlpDeserialize x+getNodeData db (PtrRef ptr@(StateRoot p)) = do+ bytes <-+ fromMaybe+ (error $ "Missing StateRoot in call to getNodeData: " ++ formatStateRoot ptr) <$>+ DB.get (ldb db) def p+ return $ bytes2NodeData bytes+ where+ bytes2NodeData::B.ByteString->NodeData+ bytes2NodeData bytes | B.null bytes = EmptyNodeData+ bytes2NodeData bytes = rlpDecode $ rlpDeserialize $ B.pack $ B.unpack bytes++putNodeData::MonadResource m=>MPDB->NodeData->m StateRoot+putNodeData db nd = do+ let bytes = rlpSerialize $ rlpEncode nd+ ptr = convert $ (Crypto.hash bytes :: Crypto.Digest Crypto.Keccak_256)++ DB.put (ldb db) def ptr bytes+ return $ StateRoot ptr++-----++-- Only used to canonicalize the DB after a+-- delete. We need to concatinate ShortcutNodeData links, convert+-- FullNodeData to ShortcutNodeData when possible, etc.++-- Important note- this function should only apply to immediate items,+-- and not recurse deep into the database (ie- by simplifying all options+-- in a FullNodeData, etc). Failure to adhere will result in a+-- performance nightmare! Any delete could result in a full read through+-- the whole database. The delete function only will "break" the+-- canonical structure locally, so deep recursion isn't required.++simplify_NodeData::MonadResource m=>MPDB->NodeData->m NodeData+simplify_NodeData _ EmptyNodeData = return EmptyNodeData+simplify_NodeData db nd@(ShortcutNodeData key (Left ref)) = do+ refNodeData <- getNodeData db ref+ case refNodeData of+ (ShortcutNodeData key2 v2) -> return $ ShortcutNodeData (key `N.append` key2) v2+ _ -> return nd+simplify_NodeData db (FullNodeData options Nothing) = do+ case options2List options of+ [(n, nodeRef)] ->+ simplify_NodeData db $ ShortcutNodeData (N.singleton n) $ Left nodeRef+ _ -> return $ FullNodeData options Nothing+simplify_NodeData _ x = return x++-----++newShortcut::MonadResource m=>MPDB->Key->Either NodeRef Val->m NodeRef+newShortcut _ "" (Left ref) = return ref+newShortcut db key val = nodeData2NodeRef db $ ShortcutNodeData key val++nodeData2NodeRef::MonadResource m=>MPDB->NodeData->m NodeRef+nodeData2NodeRef db nodeData =+ case rlpSerialize $ rlpEncode nodeData of+ bytes | B.length bytes < 32 -> return $ SmallRef bytes+ _ -> PtrRef <$> putNodeData db nodeData++list2Options::N.Nibble->[(N.Nibble, NodeRef)]->[NodeRef]+list2Options start [] = replicate (fromIntegral $ 0x10 - start) emptyRef+list2Options start x | start > 15 =+ error $+ "value of 'start' in list2Option is greater than 15, it is: " ++ show start+ ++ ", second param is " ++ show x+list2Options start ((firstNibble, firstPtr):rest) =+ replicate (fromIntegral $ firstNibble - start) emptyRef ++ [firstPtr] ++ list2Options (firstNibble+1) rest++options2List::[NodeRef]->[(N.Nibble, NodeRef)]+options2List theList = filter ((/= emptyRef) . snd) $ zip [0..] theList++prependToKey::Key->(Key, Val)->(Key, Val)+prependToKey prefix (key, val) = (prefix `N.append` key, val)++replace::Integral i=>[a]->i->a->[a]+replace lst i newVal = left ++ [newVal] ++ right+ where+ (left, _:right) = splitAt (fromIntegral i) lst++slotIsEmpty::[NodeRef]->N.Nibble->Bool+slotIsEmpty [] _ =+ error "slotIsEmpty was called for value greater than the size of the list"+slotIsEmpty (x:_) 0 | x == emptyRef = True+slotIsEmpty _ 0 = False+slotIsEmpty (_:rest) n = slotIsEmpty rest (n-1)+++getCommonPrefix::Eq a=>[a]->[a]->([a], [a], [a])+getCommonPrefix (c1:rest1) (c2:rest2)+ | c1 == c2 = prefixTheCommonPrefix c1 (getCommonPrefix rest1 rest2)+ where+ prefixTheCommonPrefix c (p, x, y) = (c:p, x, y)+getCommonPrefix x y = ([], x, y)
+ src/Blockchain/Database/MerklePatricia/InternalMem.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE OverloadedStrings #-}++module Blockchain.Database.MerklePatricia.InternalMem (+ MPMem(..),+ unsafePutKeyValMem,+ unsafeGetKeyValsMem,+ unsafeGetAllKeyValsMem,+ unsafeDeleteKeyMem,+ getNodeDataMem,+ putNodeDataMem,+ Key, Val,+ keyToSafeKeyMem+ ) where++import qualified Data.ByteString as B+import Data.ByteArray (convert)+import Crypto.Hash as Crypto+import Data.Function+import Data.List+import qualified Data.Map as Map+import Data.Maybe+import qualified Data.NibbleString as N++import Blockchain.Data.RLP+import Blockchain.Database.MerklePatricia.NodeData+import Blockchain.Database.MerklePatricia.StateRoot++type MPMap = Map.Map B.ByteString B.ByteString++data MPMem = MPMem {+ mpMap :: MPMap,+ mpStateRoot :: StateRoot+ } deriving Show+++unsafePutKeyValMem::Monad m=>MPMem->Key->Val->m MPMem+unsafePutKeyValMem db key val = do+ dbNodeData <- getNodeDataMem db (PtrRef $ mpStateRoot db)+ dbPutNodeData <- putKV_NodeDataMem db key val dbNodeData+ putNodeDataMem (fst dbPutNodeData) (snd dbPutNodeData)++unsafeGetKeyValsMem::Monad m=>MPMem->Key->m [(Key,Val)]+unsafeGetKeyValsMem db =+ let dbNodeRef = PtrRef $ mpStateRoot db+ in getKeyVals_NodeRefMem db dbNodeRef++unsafeGetAllKeyValsMem::Monad m=>MPMem->m [(Key,Val)]+unsafeGetAllKeyValsMem db = unsafeGetKeyValsMem db N.empty++unsafeDeleteKeyMem::Monad m=>MPMem->Key->m MPMem+unsafeDeleteKeyMem db key = do+ dbNodeData <- getNodeDataMem db (PtrRef $ mpStateRoot db)+ dbDeleteNodeData <- deleteKey_NodeDataMem db key dbNodeData+ putNodeDataMem (fst dbDeleteNodeData) (snd dbDeleteNodeData)++keyToSafeKeyMem::N.NibbleString->N.NibbleString+keyToSafeKeyMem key =+ N.EvenNibbleString . convert $ (Crypto.hash keyByteString :: Crypto.Digest Crypto.Keccak_256)+ where+ N.EvenNibbleString keyByteString = key++-----++putKV_NodeDataMem::Monad m=>MPMem->Key->Val->NodeData-> m (MPMem,NodeData)++putKV_NodeDataMem db key val EmptyNodeData =+ return $ (db,ShortcutNodeData key (Right val))++putKV_NodeDataMem db key val (FullNodeData options nodeValue)+ | options `slotIsEmpty` N.head key =+ do+ tailNode <- newShortcutMem db (N.tail key) $ Right val+ return $ (fst tailNode, FullNodeData (replace options (N.head key) (snd tailNode)) nodeValue)++ | otherwise =+ do+ let conflictingNodeRef = options!!fromIntegral (N.head key)+ newNode <- putKV_NodeRefMem db (N.tail key) val conflictingNodeRef+ return $ (fst newNode, FullNodeData (replace options (N.head key) (snd newNode)) nodeValue)++putKV_NodeDataMem db key1 val1 (ShortcutNodeData key2 val2)+ | key1 == key2 =+ case val2 of+ Right _ -> return $ (db, ShortcutNodeData key1 $ Right val1)+ Left ref -> do+ newNodeRef <- putKV_NodeRefMem db key1 val1 ref+ return $ (fst newNodeRef, ShortcutNodeData key2 (Left . snd $ newNodeRef))++ | N.null key1 = do+ newNodeRef <- newShortcutMem db (N.tail key2) val2+ return $ (fst newNodeRef, FullNodeData (list2Options 0 [(N.head key2, snd newNodeRef)]) $ Just val1)++ | key1 `N.isPrefixOf` key2 = do+ tailNode <- newShortcutMem db (N.drop (N.length key1) key2) val2+ modifiedTailNode <- putKV_NodeRefMem (fst tailNode) "" val1 (snd tailNode)+ return $ (fst modifiedTailNode, ShortcutNodeData key1 $ Left (snd modifiedTailNode))++ | key2 `N.isPrefixOf` key1 =+ case val2 of+ Right val -> putKV_NodeDataMem db key2 val (ShortcutNodeData key1 $ Right val1)+ Left ref -> do+ newNode <- putKV_NodeRefMem db (N.drop (N.length key2) key1) val1 ref+ return $ (fst newNode, ShortcutNodeData key2 $ Left (snd newNode))++ | N.head key1 == N.head key2 =+ let (commonPrefix, suffix1, suffix2) =+ getCommonPrefix (N.unpack key1) (N.unpack key2)+ in do+ nodeAfterCommonBeforePut <- newShortcutMem db (N.pack suffix2) val2+ nodeAfterCommon <- putKV_NodeRefMem (fst nodeAfterCommonBeforePut)+ (N.pack suffix1)+ val1+ (snd nodeAfterCommonBeforePut)++ return $ (fst nodeAfterCommon,+ ShortcutNodeData (N.pack commonPrefix) $ Left (snd nodeAfterCommon))++ | otherwise = do+ tailNode1 <- newShortcutMem db (N.tail key1) $ Right val1+ tailNode2 <- newShortcutMem (fst tailNode1) (N.tail key2) val2+ return $ (fst tailNode2, FullNodeData+ (list2Options 0 $ sortBy (compare `on` fst) [(N.head key1, snd tailNode1),+ (N.head key2, snd tailNode2)])+ Nothing)++-----++getKeyVals_NodeDataMem::Monad m=>MPMem->NodeData->Key->m [(Key, Val)]++getKeyVals_NodeDataMem _ EmptyNodeData _ = return []++getKeyVals_NodeDataMem db (FullNodeData {choices=cs}) "" = do+ partialKVs <- sequence $ (\ref -> getKeyVals_NodeRefMem db ref "") <$> cs+ return $ concatMap+ (uncurry $ map . (prependToKey . N.singleton)) (zip [0..] partialKVs)++getKeyVals_NodeDataMem db (FullNodeData {choices=cs}) key+ | ref == emptyRef = return []+ | otherwise = fmap (prependToKey $ N.singleton $ N.head key) <$>+ getKeyVals_NodeRefMem db ref (N.tail key)+ where ref = cs !! fromIntegral (N.head key)++getKeyVals_NodeDataMem db ShortcutNodeData{nextNibbleString=s, nextVal=Left ref} key+ | key `N.isPrefixOf` s = prependNext ""+ | s `N.isPrefixOf` key = prependNext $ N.drop (N.length s) key+ | otherwise = return []+ where prependNext key' = fmap (prependToKey s) <$> getKeyVals_NodeRefMem db ref key'++getKeyVals_NodeDataMem _ ShortcutNodeData{nextNibbleString=s, nextVal=Right val} key =+ return $+ if key `N.isPrefixOf` s+ then [(s,val)]+ else []++-----++deleteKey_NodeDataMem::Monad m=>MPMem->Key->NodeData-> m (MPMem,NodeData)++deleteKey_NodeDataMem db _ EmptyNodeData = return (db,EmptyNodeData)++deleteKey_NodeDataMem db key nd@(FullNodeData options val)+ | N.null key = return $ (db,FullNodeData options Nothing)++ | options `slotIsEmpty` N.head key = return (db,nd)++ | otherwise = do+ let nodeRef = options!!fromIntegral (N.head key)+ newNodeRef <- deleteKey_NodeRefMem db (N.tail key) nodeRef+ let newOptions = replace options (N.head key) (snd newNodeRef)+ simplify_NodeDataMem db $ FullNodeData newOptions val++deleteKey_NodeDataMem db key1 nd@(ShortcutNodeData key2 (Right _)) =+ return $+ if key1 == key2+ then (db,EmptyNodeData)+ else (db,nd)++deleteKey_NodeDataMem db key1 nd@(ShortcutNodeData key2 (Left ref))+ | key2 `N.isPrefixOf` key1 = do+ newNodeRef <- deleteKey_NodeRefMem db (N.drop (N.length key2) key1) ref+ simplify_NodeDataMem (fst newNodeRef) $ ShortcutNodeData key2 $ Left (snd newNodeRef)++ | otherwise = return (db, nd)++-----++putKV_NodeRefMem::Monad m=>MPMem->Key->Val->NodeRef->m (MPMem,NodeRef)+putKV_NodeRefMem db key val nodeRef = do+ nodeData <- getNodeDataMem db nodeRef+ db' <- putKV_NodeDataMem db key val nodeData+ nodeData2NodeRefMem (fst db') (snd db')+++getKeyVals_NodeRefMem::Monad m=>MPMem->NodeRef->Key->m [(Key, Val)]+getKeyVals_NodeRefMem db ref key = do+ nodeData <- getNodeDataMem db ref+ getKeyVals_NodeDataMem db nodeData key++--TODO- This is looking like a lift, I probably should make NodeRef some sort of Monad....++deleteKey_NodeRefMem::Monad m=>MPMem->Key->NodeRef->m (MPMem,NodeRef)+deleteKey_NodeRefMem db key nodeRef = do+ ref <- getNodeDataMem db nodeRef+ db'<- deleteKey_NodeDataMem db key ref++ nodeData2NodeRefMem (fst db') ref++-----++getNodeDataMem::Monad m=>MPMem->NodeRef->m NodeData+getNodeDataMem _ (SmallRef x) = return $ rlpDecode $ rlpDeserialize x+getNodeDataMem db (PtrRef ptr@(StateRoot p)) = do+ let bytes = fromMaybe (error $ "Missing StateRoot in call to getNodeData: " ++ formatStateRoot ptr)+ (Map.lookup p (mpMap db))++ return $ bytes2NodeData bytes+ where+ bytes2NodeData::B.ByteString->NodeData+ bytes2NodeData bytes | B.null bytes = EmptyNodeData+ bytes2NodeData bytes = rlpDecode $ rlpDeserialize $ B.pack $ B.unpack bytes++putNodeDataMem::Monad m=>MPMem->NodeData->m MPMem+putNodeDataMem db nd = do+ let bytes = rlpSerialize $ rlpEncode nd+ ptr = convert (Crypto.hash bytes :: Crypto.Digest Crypto.Keccak_256)+ map' = Map.insert ptr bytes (mpMap db)+ return $ MPMem { mpMap = map', mpStateRoot = StateRoot ptr }+++simplify_NodeDataMem::Monad m=>MPMem->NodeData->m (MPMem,NodeData)+simplify_NodeDataMem db EmptyNodeData = return (db,EmptyNodeData)+simplify_NodeDataMem db nd@(ShortcutNodeData key (Left ref)) = do+ refNodeData <- getNodeDataMem db ref+ case refNodeData of+ (ShortcutNodeData key2 v2) -> return $ (db,ShortcutNodeData (key `N.append` key2) v2)+ _ -> return (db,nd)+simplify_NodeDataMem db (FullNodeData options Nothing) = do+ case options2List options of+ [(n, nodeRef)] ->+ simplify_NodeDataMem db $ ShortcutNodeData (N.singleton n) $ Left nodeRef+ _ -> return $ (db,FullNodeData options Nothing)+simplify_NodeDataMem db x = return (db,x)++newShortcutMem::Monad m=>MPMem->Key->Either NodeRef Val->m (MPMem,NodeRef)+newShortcutMem db "" (Left ref) = return (db,ref)+newShortcutMem db key val = nodeData2NodeRefMem db $ ShortcutNodeData key val++nodeData2NodeRefMem::Monad m=>MPMem->NodeData->m (MPMem,NodeRef)+nodeData2NodeRefMem db nodeData =+ case rlpSerialize $ rlpEncode nodeData of+ bytes | B.length bytes < 32 -> return $ (db,SmallRef bytes)+ _ -> do+ new <- putNodeDataMem db nodeData+ return (new, PtrRef . mpStateRoot $ new)++list2Options::N.Nibble->[(N.Nibble, NodeRef)]->[NodeRef]+list2Options start [] = replicate (fromIntegral $ 0x10 - start) emptyRef+list2Options start x | start > 15 =+ error $+ "value of 'start' in list2Option is greater than 15, it is: " ++ show start+ ++ ", second param is " ++ show x+list2Options start ((firstNibble, firstPtr):rest) =+ replicate (fromIntegral $ firstNibble - start) emptyRef ++ [firstPtr] ++ list2Options (firstNibble+1) rest++options2List::[NodeRef]->[(N.Nibble, NodeRef)]+options2List theList = filter ((/= emptyRef) . snd) $ zip [0..] theList++prependToKey::Key->(Key, Val)->(Key, Val)+prependToKey prefix (key, val) = (prefix `N.append` key, val)++replace::Integral i=>[a]->i->a->[a]+replace lst i newVal = left ++ [newVal] ++ right+ where+ (left, _:right) = splitAt (fromIntegral i) lst++slotIsEmpty::[NodeRef]->N.Nibble->Bool+slotIsEmpty [] _ =+ error "slotIsEmpty was called for value greater than the size of the list"+slotIsEmpty (x:_) 0 | x == emptyRef = True+slotIsEmpty _ 0 = False+slotIsEmpty (_:rest) n = slotIsEmpty rest (n-1)+++getCommonPrefix::Eq a=>[a]->[a]->([a], [a], [a])+getCommonPrefix (c1:rest1) (c2:rest2)+ | c1 == c2 = prefixTheCommonPrefix c1 (getCommonPrefix rest1 rest2)+ where+ prefixTheCommonPrefix c (p, x, y) = (c:p, x, y)+getCommonPrefix x y = ([], x, y)+
+ src/Blockchain/Database/MerklePatricia/MPDB.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings #-}++module Blockchain.Database.MerklePatricia.MPDB (+ MPDB(..),+ openMPDB+ ) where++import Control.Monad.Trans.Resource+import Data.Binary+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Default+import qualified Database.LevelDB as DB++import Blockchain.Database.MerklePatricia.StateRoot++-- | This is the database reference type, contianing both the handle to the underlying database, as well+-- as the stateRoot to the current tree holding the data.+--+-- The MPDB acts a bit like a traditional database handle, although because it contains the stateRoot,+-- many functions act by updating its value. Because of this, it is recommended that this item be+-- stored and modified within the state monad.+data MPDB = MPDB {+ ldb :: DB.DB,+ stateRoot :: StateRoot+}++-- | This function is used to create an MPDB object corresponding to the blank database.+-- After creation, the stateRoot can be changed to a previously saved version.+openMPDB::String -- ^ The filepath with the location of the underlying database.+ ->ResourceT IO MPDB+openMPDB path = do+ ldb' <- DB.open path def{DB.createIfMissing=True}+ DB.put ldb' def (BL.toStrict $ encode emptyTriePtr) B.empty+ return MPDB{ ldb=ldb', stateRoot=emptyTriePtr }
+ src/Blockchain/Database/MerklePatricia/Map.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}++module Blockchain.Database.MerklePatricia.Map (+ map+ ) where++--In the Haskel sense of the word, 'map' is perhaps the incorrect word to use here.+--This is more of a 'mapM', but this is a one-off situation that is+--more about iterating over the full MP space than a complete functional treatment+--of the MP tree. I could also call this traverse, but I think it makes+--more sense to just go with the simple term here.++import Prelude hiding (map)++import Control.Monad+--import Control.Monad.IO.Class+--import qualified Data.ByteString.Char8 as BC+--import qualified Data.ByteString.Base16 as B16+import qualified Data.NibbleString as N+import qualified Database.LevelDB as LDB++import Blockchain.Data.RLP+import Blockchain.Database.MerklePatricia+import Blockchain.Database.MerklePatricia.Internal+import Blockchain.Database.MerklePatricia.NodeData++map::LDB.MonadResource m=>(Key->RLPObject->m ())->MPDB->m ()+map f mpdb = do+ mapNodeRef (ldb mpdb) "" f (PtrRef $ stateRoot mpdb)++mapNodeData::LDB.MonadResource m=>LDB.DB->Key->(Key->RLPObject->m ())->NodeData->m ()+mapNodeData _ _ _ EmptyNodeData = return ()+mapNodeData db partialKey f FullNodeData {choices=choices', nodeVal = maybeV} = do+ forM_ (zip [0..] choices') $ \(k, ch) -> do+ mapNodeRef db (partialKey `N.append` N.singleton k) f ch+ case maybeV of+ Nothing -> return ()+ Just v -> f partialKey v+mapNodeData db partialKey f ShortcutNodeData {nextNibbleString=remainingKey, nextVal=nv} =+ case nv of+ Left nr -> mapNodeRef db (partialKey `N.append` remainingKey) f nr+ Right v -> f (partialKey `N.append` remainingKey) v+++mapNodeRef::LDB.MonadResource m=>LDB.DB->Key->(Key->RLPObject->m ())->NodeRef->m ()+mapNodeRef db partialKey f (PtrRef sr) = do+ nodeData <- getNodeData (MPDB db sr) $ PtrRef sr+ mapNodeData db partialKey f nodeData+mapNodeRef _ _ _ (SmallRef _) = return () --TODO I might have to deal with this also+
+ src/Blockchain/Database/MerklePatricia/NodeData.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE OverloadedStrings #-}++module Blockchain.Database.MerklePatricia.NodeData (+ Key,+ Val,+ NodeData(..),+ NodeRef(..),+ emptyRef+ ) where++import Data.Bits+import qualified Data.ByteString as B+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Char8 as BC+import Data.ByteString.Internal+import qualified Data.NibbleString as N+import Numeric+import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))++import Blockchain.Data.RLP+import Blockchain.Database.MerklePatricia.StateRoot++-------------------------++-- | The type of the database key+type Key = N.NibbleString++-- | The type of the values in the database+type Val = RLPObject++-------------------------++data NodeRef = SmallRef B.ByteString | PtrRef StateRoot deriving (Show, Eq)++emptyRef::NodeRef+emptyRef = SmallRef $ B.pack [0x80]++instance Pretty NodeRef where+ pretty (SmallRef x) = green $ text $ BC.unpack $ B16.encode x+ pretty (PtrRef x) = green $ pretty $ x++-------------------------++data NodeData = EmptyNodeData+ | FullNodeData {+ -- Why not make choices a map (choices::M.Map N.Nibble NodeRef)? Because this type tends to be created+ -- more than items are looked up in it.... It would actually slow things down to use it.+ choices :: [NodeRef],+ nodeVal :: Maybe Val+ }+ | ShortcutNodeData {+ nextNibbleString :: Key,+ nextVal :: Either NodeRef Val+ }+ deriving (Show, Eq)++formatVal::Maybe RLPObject->Doc+formatVal Nothing = red $ text "NULL"+formatVal (Just x) = green $ pretty x++instance Pretty NodeData where+ pretty EmptyNodeData = text " <EMPTY>"+ pretty (ShortcutNodeData s (Left p)) = text $ " " ++ show (pretty s) ++ " -> " ++ show (pretty p)+ pretty (ShortcutNodeData s (Right val)) = text $ " " ++ show (pretty s) ++ " -> " ++ show (green $ pretty val)+ pretty (FullNodeData cs val) = text " val: " </> formatVal val </> text "\n " </> vsep (showChoice <$> zip ([0..]::[Int]) cs)+ where+ showChoice::(Int, NodeRef)->Doc+ showChoice (v, SmallRef "") = blue (text $ showHex v "") </> text ": " </> red (text "NULL")+ showChoice (v, p) = blue (text $ showHex v "") </> text ": " </> green (pretty p)++instance RLPSerializable NodeData where+ rlpEncode EmptyNodeData = RLPString ""+ rlpEncode (FullNodeData {choices=cs, nodeVal=val}) = RLPArray ((encodeChoice <$> cs) ++ [encodeVal val])+ where+ encodeChoice::NodeRef->RLPObject+ encodeChoice (SmallRef "") = rlpEncode (0::Integer)+ encodeChoice (PtrRef (StateRoot x)) = rlpEncode x+ encodeChoice (SmallRef o) = rlpDeserialize o+ encodeVal::Maybe Val->RLPObject+ encodeVal Nothing = rlpEncode (0::Integer)+ encodeVal (Just x) = x+ rlpEncode (ShortcutNodeData {nextNibbleString=s, nextVal=val}) =+ RLPArray[rlpEncode $ BC.unpack $ termNibbleString2String terminator s, encodeVal val]+ where+ terminator =+ case val of+ Left _ -> False+ Right _ -> True+ encodeVal::Either NodeRef Val->RLPObject+ encodeVal (Left (PtrRef x)) = rlpEncode x+ encodeVal (Left (SmallRef x)) = rlpDeserialize x+ encodeVal (Right x) = x++ rlpDecode (RLPString "") = EmptyNodeData+ rlpDecode (RLPScalar 0) = EmptyNodeData+ rlpDecode (RLPArray [a, val])+ | terminator = ShortcutNodeData s $ Right val+ | B.length (rlpSerialize val) >= 32 =+ ShortcutNodeData s (Left $ PtrRef $ StateRoot (BC.pack $ rlpDecode val))+ | otherwise =+ ShortcutNodeData s (Left $ SmallRef $ rlpSerialize val)+ where+ (terminator, s) = string2TermNibbleString $ rlpDecode a+ rlpDecode (RLPArray x) | length x == 17 =+ FullNodeData (getPtr <$> childPointers) val+ where+ childPointers = init x+ val = case last x of+ RLPScalar 0 -> Nothing+ RLPString "" -> Nothing+ x' -> Just x'+ getPtr::RLPObject->NodeRef+ getPtr o | B.length (rlpSerialize o) < 32 = SmallRef $ rlpSerialize o+ --getPtr o@(RLPArray [_, _]) = SmallRef $ rlpSerialize o+ getPtr p = PtrRef $ StateRoot $ rlpDecode p+ rlpDecode x = error ("Missing case in rlpDecode for NodeData: " ++ show x)+++++++string2TermNibbleString::String->(Bool, N.NibbleString)+string2TermNibbleString [] = error "string2TermNibbleString called with empty String"+string2TermNibbleString (c:rest) =+ (terminator, s)+ where+ w = c2w c+ (flags, extraNibble) = if w > 0xF then (w `shiftR` 4, 0xF .&. w) else (w, 0)+ terminator = flags `shiftR` 1 == 1+ oddLength = flags .&. 1 == 1+ s = if oddLength then N.OddNibbleString extraNibble (BC.pack rest) else N.EvenNibbleString (BC.pack rest)++termNibbleString2String::Bool->N.NibbleString->B.ByteString+termNibbleString2String terminator s =+ case s of+ (N.EvenNibbleString s') -> B.singleton (extraNibble `shiftL` 4) `B.append` s'+ (N.OddNibbleString n rest) -> B.singleton (extraNibble `shiftL` 4 + n) `B.append` rest+ where+ extraNibble =+ (if terminator then 2 else 0) ++ (if odd $ N.length s then 1 else 0)
+ src/Blockchain/Database/MerklePatricia/StateRoot.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++module Blockchain.Database.MerklePatricia.StateRoot (+ StateRoot(..),+ emptyTriePtr,+ sha2StateRoot,+ unboxStateRoot,+ formatStateRoot+ ) where++import Control.Monad+import qualified Data.ByteString.Base16 as B16+import Data.ByteArray (convert)+import Crypto.Hash as Crypto+++import Data.Binary+import qualified Data.ByteString as B+import Data.String+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import Blockchain.Data.RLP++import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))++import GHC.Generics++-- | Internal nodes are indexed in the underlying database by their 256-bit SHA3 hash.+-- This types represents said hash.+--+-- The stateRoot is of this type,+-- (ie- the pointer to the full set of key/value pairs at a particular time in history), and+-- will be of interest if you need to refer to older or parallel version of the data.++newtype StateRoot = StateRoot B.ByteString deriving (Show, Eq, Read, Generic, IsString)++formatStateRoot :: StateRoot -> String+formatStateRoot (StateRoot sr) = T.unpack . decodeUtf8 . B16.encode $ sr++instance Pretty StateRoot where+ pretty = text . formatStateRoot++instance Binary StateRoot where+ put (StateRoot x) = sequence_ $ put <$> B.unpack x+ get = StateRoot <$> B.pack <$> replicateM 32 get++instance RLPSerializable StateRoot where+ rlpEncode (StateRoot x) = rlpEncode x+ rlpDecode x = StateRoot $ rlpDecode x++-- | The stateRoot of the empty database.+emptyTriePtr::StateRoot+emptyTriePtr =+ let root = rlpEncode (0::Integer)+ rootHash = convert $ (Crypto.hash . rlpSerialize $ root :: Crypto.Digest Crypto.Keccak_256)+ in StateRoot rootHash++sha2StateRoot::Digest Crypto.Keccak_256 -> StateRoot+sha2StateRoot = StateRoot . convert++unboxStateRoot :: StateRoot -> B.ByteString+unboxStateRoot (StateRoot b) = b
+ src/Blockchain/Database/MerklePatriciaMem.hs view
@@ -0,0 +1,58 @@++module Blockchain.Database.MerklePatriciaMem (+ putKeyValMem, getKeyValMem, deleteKeyMem, keyExistsMem,+ initializeBlankMem,+ MPMem(..)+ ) where++import Data.ByteArray (convert)+import Crypto.Hash as Crypto+import qualified Data.Map as Map+import Data.Maybe (isJust)++import Blockchain.Data.RLP+import Blockchain.Database.MerklePatricia.InternalMem+import Blockchain.Database.MerklePatricia.StateRoot++putKeyValMem::Monad m=>MPMem+ ->Key+ ->Val+ ->m MPMem+putKeyValMem db = unsafePutKeyValMem db . keyToSafeKeyMem+++getKeyValMem::Monad m=>MPMem+ -> Key+ -> m (Maybe Val)+getKeyValMem db key = do+ vals <- unsafeGetKeyValsMem db (keyToSafeKeyMem key)+ return $+ if not (null vals)+ then Just $ snd (head vals)+ -- Since we hash the keys, it's impossible+ -- for vals to have more than one item+ else Nothing++deleteKeyMem::Monad m=>MPMem+ ->Key+ ->m MPMem+deleteKeyMem db = unsafeDeleteKeyMem db . keyToSafeKeyMem++keyExistsMem::Monad m=>MPMem+ ->Key+ ->m Bool+keyExistsMem db key = isJust <$> getKeyValMem db key+++initializeBlankMem ::MPMem+initializeBlankMem =+ let theRLP = rlpEncode (0::Integer)+ bytes = rlpSerialize theRLP+ key = convert $ (Crypto.hash bytes :: Crypto.Digest Crypto.Keccak_256)+ in+ MPMem {+ mpMap = Map.insert key bytes Map.empty,+ mpStateRoot = StateRoot bytes+ }++
+ test/MerklePatriciaSpec.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Blockchain.Data.RLP+import Blockchain.Database.MerklePatricia+import Blockchain.Database.MerklePatricia.Internal+import Blockchain.Database.MerklePatricia.InternalMem+import Blockchain.Database.MerklePatricia.MPDB+import Blockchain.Database.MerklePatriciaMem+import Control.Monad.Trans.Resource+import qualified Data.NibbleString as N+import qualified Database.LevelDB as LD+import Test.Hspec+import Test.Hspec.Contrib.HUnit (fromHUnitTest)+import Test.HUnit++bigTest :: [(Key,String)]+bigTest=+ [+ ("00000000000000000000000000000000ffffffffffffffff0000000000000000", "90467269656e647320262046616d696c79"),+ ("00000000000000000000000000000000ffffffffffffffff0000000000000001", "8772656631323334"),+ ("00000000000000000000000000000000ffffffffffffffff0000000000000002", "04"),+ ("00000000000000000000000000000000ffffffffffffffff0000000000000003", "84548123a8"),+ ("0000000000000000000000000000000000000000000000000000000000000000", "974c696162696c69746965733a496e697469616c4c6f616e"),+ ("0000000000000000000000000000000000000000000000000000000000000001", "a0fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe7960"),+ ("0000000000000000000000000000000000000000000000000000000000000002", "83555344"),+ ("0000000000000000000000000000000000000000000000010000000000000000", "8f4173736574733a436865636b696e67"),+ ("0000000000000000000000000000000000000000000000010000000000000001", "830186a0"),+ ("0000000000000000000000000000000000000000000000010000000000000002", "83555344"),+ ("00000000000000000000000000000002ffffffffffffffff0000000000000003", "84548123a8")+ ]++addAllKVs::RLPSerializable obj=>MonadResource m=>MPDB->[(N.NibbleString, obj)]->m MPDB+addAllKVs x [] = return x+addAllKVs mpdb (x:rest) = do+ mpdb' <- unsafePutKeyVal mpdb (fst x) (rlpEncode $ rlpSerialize $ rlpEncode $ snd x)+ addAllKVs mpdb' rest++addAllKVsMem::RLPSerializable obj=>Monad m=>MPMem->[(N.NibbleString, obj)]->m MPMem+addAllKVsMem x [] = return x+addAllKVsMem mpdb (x:rest) = do+ mpdb' <- unsafePutKeyValMem mpdb (fst x) (rlpEncode $ rlpSerialize $ rlpEncode $ snd x)+ addAllKVsMem mpdb' rest++blank :: MPMem+blank = initializeBlankMem {mpStateRoot=emptyTriePtr}++testGetPut :: Test+testGetPut = TestCase $ do+ db <- putSingleKV key val+ res <- getSingleKV db key++ assertEqual "get . put = id" res [(key,val)]++testGetPutRepeated :: Test+testGetPutRepeated = TestCase $ do+ db <- putSingleKV key val+ db2 <- unsafePutKeyValMem db key2 val2++ res <- getSingleKV db2 key2++ assertEqual "get . put . put = id" res [(key2,val2)]++testGetPutRepeatedII :: Test+testGetPutRepeatedII = TestCase $ do+ db <- addAllKVsMem blank bigTest++ res <- getSingleKV db "00000000000000000000000000000002ffffffffffffffff0000000000000003"++ assertEqual "get . putn = id" res [("00000000000000000000000000000002ffffffffffffffff0000000000000003",rlpEncode $ rlpSerialize $ rlpEncode ("84548123a8" :: String))]++testSingleInsert :: Test+testSingleInsert = TestCase $ do+ sr <- runResourceT $ do+ db <- LD.open "/tmp/testDB" LD.defaultOptions{LD.createIfMissing=True}++ let ldb' = MPDB {ldb=db,stateRoot=emptyTriePtr}++ initializeBlank ldb'++ addAllKVs ldb' [head bigTest]++ sr2 <- addAllKVsMem blank [head bigTest]++ assertEqual "disk - mem single insert" (stateRoot sr) (mpStateRoot sr2)+++testMultipleInserts :: Test+testMultipleInserts = TestCase $ do+ sr <- runResourceT $ do+ db <- LD.open "/tmp/testDB2" LD.defaultOptions{LD.createIfMissing=True}++ let ldb' = MPDB {ldb=db,stateRoot=emptyTriePtr}++ initializeBlank ldb'++ addAllKVs ldb' bigTest++ sr2 <- addAllKVsMem blank bigTest++ assertEqual "disk - mem multiple insert" (stateRoot sr) (mpStateRoot sr2)+++key :: N.NibbleString+key = (N.EvenNibbleString "anyString")++val :: RLPObject+val = (RLPString "anotherString")++key2 :: N.NibbleString+key2 = (N.EvenNibbleString "otherString")++val2 :: RLPObject+val2 = (RLPString "thatString2")++putSingleKV :: (Monad m) => Key->Val->m MPMem+putSingleKV k v= unsafePutKeyValMem blank k v++getSingleKV :: (Monad m) => MPMem -> Key -> m [(Key,Val)]+getSingleKV db key' = unsafeGetKeyValsMem db key'++spec :: Spec+spec = do+ describe "the old merkle-patricia test suite" $ do+ fromHUnitTest $ TestList [TestLabel " get . put = id" testGetPut,+ TestLabel " get . put . put = id" testGetPutRepeated,+ TestLabel " get . putn = id" testGetPutRepeatedII,+ TestLabel " single insert" testSingleInsert,+ TestLabel " multiple insert" testMultipleInserts]++main :: IO ()+main = hspec spec