diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/merkle-patricia-db.cabal b/merkle-patricia-db.cabal new file mode 100644 --- /dev/null +++ b/merkle-patricia-db.cabal @@ -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 diff --git a/src/Blockchain/Database/KeyVal.hs b/src/Blockchain/Database/KeyVal.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Database/KeyVal.hs @@ -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 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,79 @@ +-- | 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, 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 + diff --git a/src/Blockchain/Database/MerklePatricia/Diff.hs b/src/Blockchain/Database/MerklePatricia/Diff.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Database/MerklePatricia/Diff.hs @@ -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 diff --git a/src/Blockchain/Database/MerklePatricia/Internal.hs b/src/Blockchain/Database/MerklePatricia/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Database/MerklePatricia/Internal.hs @@ -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) diff --git a/src/Blockchain/Database/MerklePatricia/InternalMem.hs b/src/Blockchain/Database/MerklePatricia/InternalMem.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Database/MerklePatricia/InternalMem.hs @@ -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) + 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,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 } diff --git a/src/Blockchain/Database/MerklePatricia/Map.hs b/src/Blockchain/Database/MerklePatricia/Map.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Database/MerklePatricia/Map.hs @@ -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 + 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,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 " " + 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) diff --git a/src/Blockchain/Database/MerklePatricia/StateRoot.hs b/src/Blockchain/Database/MerklePatricia/StateRoot.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Database/MerklePatricia/StateRoot.hs @@ -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 diff --git a/src/Blockchain/Database/MerklePatriciaMem.hs b/src/Blockchain/Database/MerklePatriciaMem.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Database/MerklePatriciaMem.hs @@ -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 + } + + diff --git a/test/MerklePatriciaSpec.hs b/test/MerklePatriciaSpec.hs new file mode 100644 --- /dev/null +++ b/test/MerklePatriciaSpec.hs @@ -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