packages feed

ethereum-merkle-patricia-db (empty) → 0.0.1

raw patch · 8 files changed

+763/−0 lines, 8 filesdep +HUnitdep +ansi-wl-pprintdep +basesetup-changed

Dependencies added: HUnit, ansi-wl-pprint, base, base16-bytestring, binary, bytestring, containers, cryptohash, data-default, ethereum-rlp, leveldb-haskell, nibblestring, resourcet, test-framework, test-framework-hunit, transformers

Files

+ LICENSE view
@@ -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.+
+ Setup.hs view
@@ -0,0 +1,8 @@++module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain+
+ ethereum-merkle-patricia-db.cabal view
@@ -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
+ src/Blockchain/Database/MerklePatricia.hs view
@@ -0,0 +1,312 @@+{-# LANGUAGE OverloadedStrings #-}++-- | 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,+  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)+++
+ src/Blockchain/Database/MerklePatricia/MPDB.hs view
@@ -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 }
+ src/Blockchain/Database/MerklePatricia/NodeData.hs view
@@ -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 "    <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 (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)
+ src/Blockchain/Database/MerklePatricia/SHAPtr.hs view
@@ -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)
+ test/Main.hs view
@@ -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