diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ + +Copyright (c) 2014, Jamshid +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above +copyright notice, this list of conditions and the following +disclaimer in the documentation and/or other materials provided +with the distribution. + +3. Neither the name of the copyright holder nor the names of its +contributors may be used to endorse or promote products derived +from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,8 @@ + +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain + diff --git a/ethereum-merkle-patricia-db.cabal b/ethereum-merkle-patricia-db.cabal new file mode 100644 --- /dev/null +++ b/ethereum-merkle-patricia-db.cabal @@ -0,0 +1,69 @@ +name: ethereum-merkle-patricia-db +version: 0.0.1 +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: BSD3 +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: Haskell98 + build-depends: + base >= 4 && < 5 + , resourcet + , cryptohash + , bytestring + , base16-bytestring + , data-default + , nibblestring + , leveldb-haskell + , ethereum-rlp + , binary + , ansi-wl-pprint + exposed-modules: + Blockchain.Database.MerklePatricia + other-modules: + Blockchain.Database.MerklePatricia.MPDB + Blockchain.Database.MerklePatricia.SHAPtr + Blockchain.Database.MerklePatricia.NodeData + ghc-options: -Wall + buildable: True + hs-source-dirs: src + + +Test-Suite test-merkel-patricia-db + default-language: Haskell98 + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test, src + build-depends: base >=4 && < 5 + , data-default + , leveldb-haskell + , resourcet + , bytestring + , base16-bytestring + , transformers + , binary + , ethereum-rlp + , cryptohash + , nibblestring + , ansi-wl-pprint + , test-framework + , test-framework-hunit + , HUnit + , containers diff --git a/src/Blockchain/Database/MerklePatricia.hs b/src/Blockchain/Database/MerklePatricia.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Database/MerklePatricia.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | This is an implementation of the modified Merkle Patricia database described +-- in the Ethereum Yellowpaper (). 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, + initializeBlank, + putKeyVal, + getKeyVals, + deleteKey, + MPDB(..), + openMPDB, + SHAPtr(..), + emptyTriePtr, + ) where + +import Control.Monad.Trans.Resource +import qualified Crypto.Hash.SHA3 as C +import qualified Data.ByteString as B +import Data.Default +import Data.Function +import Data.Functor +import Data.List +import Data.Maybe +import qualified Data.NibbleString as N +import qualified Database.LevelDB as DB +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +import Blockchain.Data.RLP +import Blockchain.Database.MerklePatricia.MPDB +import Blockchain.Database.MerklePatricia.NodeData +import Blockchain.Database.MerklePatricia.SHAPtr + +--import Debug.Trace + + + +initializeBlank::MPDB->ResourceT IO () +initializeBlank db = + let bytes = rlpSerialize $ rlpEncode (0::Integer) + in + DB.put (ldb db) def (C.hash 256 bytes) bytes + + +getNodeData::MPDB->NodeRef->ResourceT IO NodeData +getNodeData _ (SmallRef x) = return $ rlpDecode $ rlpDeserialize x +getNodeData db (PtrRef ptr@(SHAPtr p)) = do + bytes <- fromMaybe (error $ "Missing SHAPtr in call to getNodeData: " ++ show (pretty 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 bytes + +------------------------- + +getKeyVals_NodeData::MPDB->NodeData->Key->ResourceT IO [(Key, Val)] +getKeyVals_NodeData _ EmptyNodeData _ = return [] +getKeyVals_NodeData _ (ShortcutNodeData {nextNibbleString=s,nextVal=Right v}) key | key `N.isPrefixOf` s = return [(s, v)] +getKeyVals_NodeData db ShortcutNodeData{nextNibbleString=s,nextVal=Left ref} key | key `N.isPrefixOf` s = + fmap (prependToKey s) <$> getKeyVals_NodeRef db ref "" +getKeyVals_NodeData db ShortcutNodeData{nextNibbleString=s,nextVal=Left ref} key | s `N.isPrefixOf` key = + fmap (prependToKey s) <$> getKeyVals_NodeRef db ref (N.drop (N.length s) key) +getKeyVals_NodeData _ ShortcutNodeData{} _ = return [] +getKeyVals_NodeData db (FullNodeData {choices=cs}) key = + if N.null key + then do + partialKVs <- (sequence $ (\ref -> getKeyVals_NodeRef db ref "") <$> cs)::ResourceT IO [[(Key, Val)]] + return $ concat $ (\(nibble, kvs) -> prependToKey (N.singleton nibble) <$> kvs) <$> zip [0..] partialKVs + else case cs!!fromIntegral (N.head key) of + x | x == emptyRef -> return [] + ref -> fmap (prependToKey $ N.singleton $ N.head key) <$> getKeyVals_NodeRef db ref (N.tail key) + +---- + +getKeyVals_NodeRef::MPDB->NodeRef->Key->ResourceT IO [(Key, Val)] +getKeyVals_NodeRef db ref key = do + nodeData <- getNodeData db ref + getKeyVals_NodeData db nodeData key + +-- | Retrieves all key/value pairs whose key starts with the given parameter. + + +getKeyVals::MPDB -- ^ Object containing the current stateRoot. + ->Key -- ^ The partial key (the query will return any key that is prefixed by this value) + ->ResourceT IO [(Key, Val)] -- ^ The requested data. +getKeyVals db = + getKeyVals_NodeRef db (PtrRef $ stateRoot db) + +------------------------------------ + +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) + +replace::Integral i=>[a]->i->a->[a] +replace lst i newVal = left ++ [newVal] ++ right + where + (left, _:right) = splitAt (fromIntegral i) lst + +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 + +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) + +newShortcut::MPDB->Key->Either NodeRef Val->ResourceT IO NodeRef +newShortcut _ key (Left ref) | N.null key = return ref +newShortcut db key val = nodeData2NodeRef db $ ShortcutNodeData key val + +putNodeData::MPDB->NodeData->ResourceT IO SHAPtr +putNodeData db nd = do + let bytes = rlpSerialize $ rlpEncode nd + ptr = C.hash 256 bytes + DB.put (ldb db) def ptr bytes + return $ SHAPtr ptr + +------------------------- + +nodeData2NodeRef::MPDB->NodeData->ResourceT IO NodeRef +nodeData2NodeRef db nodeData = + case rlpSerialize $ rlpEncode nodeData of + bytes | B.length bytes < 32 -> return $ SmallRef bytes + _ -> PtrRef <$> putNodeData db nodeData + +putKV_NodeRef::MPDB->Key->Val->NodeRef->ResourceT IO NodeRef +putKV_NodeRef db key val nodeRef = do + nodeData <- getNodeData db nodeRef + newNodeData <- putKV_NodeData db key val nodeData + nodeData2NodeRef db newNodeData + +putKV_NodeData::MPDB->Key->Val->NodeData->ResourceT IO 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 + +putKV_NodeData db key val (FullNodeData options nodeValue) = 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 _ key1 val (ShortcutNodeData key2 (Right _)) | key1 == key2 = + return $ ShortcutNodeData key1 $ Right val + +putKV_NodeData db key1 val (ShortcutNodeData key2 (Left ref)) | key1 == key2 = do + newNodeRef <- putKV_NodeRef db key1 val ref + return $ ShortcutNodeData key2 (Left newNodeRef) + +putKV_NodeData db "" val1 (ShortcutNodeData key2 val2) = do + newNodeRef <- newShortcut db (N.tail key2) val2 + return $ FullNodeData (list2Options 0 [(N.head key2, newNodeRef)]) $ Just val1 + +putKV_NodeData db key1 val1 (ShortcutNodeData key2 val2) | 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 + +putKV_NodeData db key1 val1 (ShortcutNodeData key2 (Right val2)) | key2 `N.isPrefixOf` key1 = + putKV_NodeData db key2 val2 (ShortcutNodeData key1 $ Right val1) + +putKV_NodeData db key1 val1 (ShortcutNodeData key2 (Left ref)) | key2 `N.isPrefixOf` key1 = do + newNode <- putKV_NodeRef db (N.drop (N.length key2) key1) val1 ref + return $ ShortcutNodeData key2 $ Left newNode + +putKV_NodeData db key1 val1 (ShortcutNodeData key2 val2) | N.head key1 == N.head key2 = do + nodeAfterCommonBeforePut <- newShortcut db (N.pack suffix2) val2 + nodeAfterCommon <- putKV_NodeRef db (N.pack suffix1) val1 nodeAfterCommonBeforePut + return $ ShortcutNodeData (N.pack commonPrefix) $ Left nodeAfterCommon + where + (commonPrefix, suffix1, suffix2) = getCommonPrefix (N.unpack key1) (N.unpack key2) + +putKV_NodeData db key1 val1 (ShortcutNodeData key2 val2) = 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 + +-- | Adds a new key/value pair. +putKeyVal::MPDB -- ^ The object containing the current stateRoot. + ->Key -- ^ Key of the data to be inserted. + ->Val -- ^ Value of the new data + ->ResourceT IO MPDB -- ^ The object containing the stateRoot to the data after the insert. +--putKeyVal db key val | trace ("^^^^^^^^^^putKeyVal: key = " ++ show (pretty key) ++ ", val = " ++ show (pretty val)) False = undefined +putKeyVal db key val = do + p <- putNodeData db =<< putKV_NodeData db key val =<< getNodeData db (PtrRef $ stateRoot db) + return db{stateRoot=p} + +-------------------- + +--The "simplify" functions are 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_NodeRef::MPDB->NodeRef->ResourceT IO NodeRef +simplify_NodeRef db ref = nodeData2NodeRef db =<< simplify_NodeData db =<< getNodeData db ref + +---- + +simplify_NodeData::MPDB->NodeData->ResourceT IO NodeData +simplify_NodeData _ EmptyNodeData = return EmptyNodeData +simplify_NodeData db nd@(ShortcutNodeData key (Left ref)) = do + refNodeData <- simplify_NodeData db =<< 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 + simplifiedOptions <- sequence $ simplify_NodeRef db <$> options + + case options2List simplifiedOptions of + [(n, nodeRef)] -> + simplify_NodeData db $ ShortcutNodeData (N.singleton n) $ Left nodeRef + _ -> return $ FullNodeData simplifiedOptions Nothing +simplify_NodeData _ x = return x + +---------- + +--TODO- This is looking like a lift, I probably should make NodeRef some sort of Monad.... + +deleteKey_NodeRef::MPDB->Key->NodeRef->ResourceT IO NodeRef +deleteKey_NodeRef db key nodeRef = + nodeData2NodeRef db =<< deleteKey_NodeData db key =<< getNodeData db nodeRef + +---- + +deleteKey_NodeData::MPDB->Key->NodeData->ResourceT IO NodeData + +deleteKey_NodeData _ _ EmptyNodeData = return EmptyNodeData + + +deleteKey_NodeData _ key1 (ShortcutNodeData key2 (Right _)) | key2 == key1 = return EmptyNodeData +deleteKey_NodeData _ _ nd@(ShortcutNodeData _ (Right _)) = return nd +deleteKey_NodeData db key1 (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 +deleteKey_NodeData _ _ nd@(ShortcutNodeData _ (Left _)) = return nd + + +deleteKey_NodeData _ "" (FullNodeData options _) = + return $ FullNodeData options Nothing +deleteKey_NodeData _ key nd@(FullNodeData options _) | options `slotIsEmpty` N.head key = + return nd +deleteKey_NodeData db key (FullNodeData options val) = 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 + +------------- + + +-- | 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::MPDB -- ^ The object containing the current stateRoot. + ->Key -- ^ The key to be deleted. + ->ResourceT IO MPDB -- ^ The object containing the stateRoot to the data after the delete. +deleteKey db key = do + p <- putNodeData db =<< deleteKey_NodeData db key =<< getNodeData db (PtrRef $ stateRoot db) + return db{stateRoot=p} + + +prependToKey::Key->(Key, Val)->(Key, Val) +prependToKey prefix (key, val) = (prefix `N.append` key, val) + + + diff --git a/src/Blockchain/Database/MerklePatricia/MPDB.hs b/src/Blockchain/Database/MerklePatricia/MPDB.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Database/MerklePatricia/MPDB.hs @@ -0,0 +1,37 @@ +{-# 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 Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +import Blockchain.Database.MerklePatricia.SHAPtr + +-- | 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::SHAPtr + } + +-- | 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 } diff --git a/src/Blockchain/Database/MerklePatricia/NodeData.hs b/src/Blockchain/Database/MerklePatricia/NodeData.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Database/MerklePatricia/NodeData.hs @@ -0,0 +1,145 @@ +{-# 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 Data.ByteString.Internal +import qualified Data.ByteString.Char8 as BC +import Data.Functor +import qualified Data.NibbleString as N +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) +import Numeric + +import Blockchain.Data.RLP +import Blockchain.Database.MerklePatricia.SHAPtr + +--import Debug.Trace + +------------------------- + +-- | 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 SHAPtr 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 + +formatVal::Maybe RLPObject->Doc +formatVal Nothing = red $ text "NULL" +formatVal (Just x) = green $ pretty x + +instance Pretty NodeData where + pretty EmptyNodeData = text " " + 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 (SHAPtr 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)) = rlpEncode 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 $ SHAPtr (BC.pack $ rlpDecode val)) + | otherwise = + ShortcutNodeData s (Left $ SmallRef $ rlpDecode 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 $ SHAPtr $ 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) diff --git a/src/Blockchain/Database/MerklePatricia/SHAPtr.hs b/src/Blockchain/Database/MerklePatricia/SHAPtr.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Database/MerklePatricia/SHAPtr.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Blockchain.Database.MerklePatricia.SHAPtr ( + SHAPtr(..), + emptyTriePtr + ) where + +import Control.Monad +import qualified Crypto.Hash.SHA3 as C +import Data.Binary +import qualified Data.ByteString as B +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Char8 as BC +import Data.Functor +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +import Blockchain.Data.RLP + +-- | 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 SHAPtr = SHAPtr B.ByteString deriving (Show, Eq) + +instance Pretty SHAPtr where + pretty (SHAPtr x) = yellow $ text $ BC.unpack (B16.encode x) + +instance Binary SHAPtr where + put (SHAPtr x) = sequence_ $ put <$> B.unpack x + get = SHAPtr <$> B.pack <$> replicateM 32 get + +instance RLPSerializable SHAPtr where + rlpEncode (SHAPtr x) = rlpEncode x + rlpDecode x = SHAPtr $ rlpDecode x + +-- | The stateRoot of the empty database. +emptyTriePtr::SHAPtr +emptyTriePtr = SHAPtr $ C.hash 256 $ rlpSerialize $ rlpEncode (0::Integer) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import qualified Data.ByteString as B +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Char8 as BC +import Data.Default +import Data.Functor +import Data.List +import qualified Data.Map as M +import Data.Monoid +import qualified Database.LevelDB as LD +import System.Exit +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit + +import qualified Data.NibbleString as N + +import Blockchain.Data.RLP +import Blockchain.Database.MerklePatricia + +bigTest= + [ + ("00000000000000000000000000000000ffffffffffffffff0000000000000000", "90467269656e647320262046616d696c79"), + ("00000000000000000000000000000000ffffffffffffffff0000000000000001", "8772656631323334"), + ("00000000000000000000000000000000ffffffffffffffff0000000000000002", "04"), + ("00000000000000000000000000000000ffffffffffffffff0000000000000003", "84548123a8"), + ("0000000000000000000000000000000000000000000000000000000000000000", "974c696162696c69746965733a496e697469616c4c6f616e"), + ("0000000000000000000000000000000000000000000000000000000000000001", "a0fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe7960"), + ("0000000000000000000000000000000000000000000000000000000000000002", "83555344"), + ("0000000000000000000000000000000000000000000000010000000000000000", "8f4173736574733a436865636b696e67"), + ("0000000000000000000000000000000000000000000000010000000000000001", "830186a0"), + ("0000000000000000000000000000000000000000000000010000000000000002", "83555344"), + ("00000000000000000000000000000002ffffffffffffffff0000000000000003", "84548123a8") + ] + + + + +putKeyVals::MPDB->[(N.NibbleString, B.ByteString)]->ResourceT IO MPDB +putKeyVals db [(k,v)] = putKeyVal db k (rlpEncode v) +putKeyVals db ((k, v):rest) = do + db'<- putKeyVal db k $ rlpEncode v + putKeyVals db' rest + +verifyDBDataIntegrity::MPDB->[(N.NibbleString, B.ByteString)]->ResourceT IO () +verifyDBDataIntegrity db valuesIn = do + db2 <- putKeyVals db valuesIn + --return (db, stateRoot2) + valuesOut <- getKeyVals db2 (N.EvenNibbleString B.empty) + liftIO $ assertEqual "roundtrip in-out db didn't match" (M.fromList $ fmap rlpEncode <$> valuesIn) (M.fromList valuesOut) + return () + +testShortcutNodeDataInsert::Assertion +testShortcutNodeDataInsert = do + runResourceT $ do + db <- openMPDB "/tmp/tmpDB" + verifyDBDataIntegrity db + [ + (N.EvenNibbleString $ BC.pack "abcd", BC.pack "abcd"), + (N.EvenNibbleString $ BC.pack "aefg", BC.pack "aefg") + ] + +testShortcutNodeDataInsert2::Assertion +testShortcutNodeDataInsert2 = do + runResourceT $ do + db <- openMPDB "/tmp/tmpDB" + verifyDBDataIntegrity db + [ + (N.EvenNibbleString $ BC.pack "abcd", BC.pack "abcd"), + (N.EvenNibbleString $ BC.pack "bb", BC.pack "bb") + ] + +testFullNodeDataInsert::Assertion +testFullNodeDataInsert = do + runResourceT $ do + db <- openMPDB "/tmp/tmpDB" + verifyDBDataIntegrity db + [ + (N.EvenNibbleString $ BC.pack "abcd", BC.pack "abcd"), + (N.EvenNibbleString $ BC.pack "bb", BC.pack "bb"), + (N.EvenNibbleString $ BC.pack "aefg", BC.pack "aefg") + ] + +testOther::Assertion +testOther = do + runResourceT $ do + db <- openMPDB "/tmp/tmpDB" + verifyDBDataIntegrity db [("", "abcd")] + verifyDBDataIntegrity db [("0123", "dog"), ("0123", "cat")] + verifyDBDataIntegrity db [("abcd", "abcd"), ("ab12", "bb"), ("ab21", "aefg")] + verifyDBDataIntegrity db [("ab", "abcd"), ("bb", "bb"), ("cb", "aefg"), ("bc", "qq")] + +prefixIfNeeded::B.ByteString->B.ByteString +prefixIfNeeded s | odd $ B.length s = "0" `B.append` s +prefixIfNeeded s = s + +testBigTest::Assertion +testBigTest = do + runResourceT $ do + db <- openMPDB "/tmp/tmpDB" + verifyDBDataIntegrity db (fmap (fst . B16.decode . prefixIfNeeded) <$> bigTest) + + + +main::IO () +main = + defaultMainWithOpts + [ + testCase "ShortcutNodeData Insert" testShortcutNodeDataInsert, + testCase "ShortcutNodeData2 Insert" testShortcutNodeDataInsert2, + testCase "FullNodeData Insert" testFullNodeDataInsert, + testCase "other" testOther, + testCase "bigTest" testBigTest + ] mempty