stable-tree 0.1.0 → 0.2.0
raw patch · 7 files changed
+367/−354 lines, 7 files
Files
- demo/Main.hs +7/−6
- src/Data/StableTree/IO.hs +0/−285
- src/Data/StableTree/IO/Ram.hs +0/−58
- src/Data/StableTree/Persist.hs +296/−0
- src/Data/StableTree/Persist/Ram.hs +58/−0
- stable-tree.cabal +4/−3
- tests/TestAll.hs +2/−2
demo/Main.hs view
@@ -6,9 +6,9 @@ ( main ) where -import Data.StableTree ( fromMap )-import Data.StableTree.IO ( store )-import Data.StableTree.IO.Ram ( storage )+import Data.StableTree ( fromMap )+import Data.StableTree.Persist ( store )+import Data.StableTree.Persist.Ram ( storage ) import qualified Data.Map as Map import Data.IORef ( readIORef )@@ -17,14 +17,15 @@ -- out the total number of unique entries in that store and how many database -- entries would be required from a naive database implementation every -- so-often.+main :: IO () main = do (s, trees, values) <- storage mapM_ (doRun s trees values) [0,100..1000::Int]- store s (fromMap $ Map.fromList [(a,a+1)|a<-[100..1000]])+ Right _ <- store s (fromMap $ Map.fromList [(a,a+1)|a<-[100..1000]]) prTrees trees values- store s (fromMap $ Map.fromList [(a,a+1)|a<-[200..1000]])+ Right _ <- store s (fromMap $ Map.fromList [(a,a+1)|a<-[200..1000]]) prTrees trees values- store s (fromMap $ Map.fromList [(a,a+1)|a<-[0..400]++[600..1000]])+ Right _ <- store s (fromMap $ Map.fromList [(a,a+1)|a<-[0..400]++[600..1000]]) prTrees trees values where
− src/Data/StableTree/IO.hs
@@ -1,285 +0,0 @@-{-# LANGUAGE LambdaCase, OverloadedStrings #-}--- |--- Module : Data.StableTree.IO--- Copyright : Jeremy Groven--- License : BSD3------ Logic for dealing with the actual storage of Stable Trees. The key exports--- here are 'Error', 'Store', 'load', and 'store'. A user needs to implement--- the 'loadTree', 'loadValue', 'storeTree' and 'storeValue' parts of 'Store',--- and make an appropriate Error type to report storage errors, and then the--- 'load' and 'store' functions can just do their thing. If necessary, a user--- can also implement 'Build' for custom data types.-module Data.StableTree.IO-( Store(..)-, Build(..)-, Error(..)-, Id-, load-, store-, buildBinary-, buildSerialize-) where--import Data.StableTree.Types hiding ( hash )-import Data.StableTree ( StableTree(..) )--import qualified Data.Binary as B-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as Lazy-import qualified Data.Map as Map-import qualified Data.Serialize as S-import Blaze.ByteString.Builder ( Builder, toByteString )-import Blaze.ByteString.Builder.ByteString ( fromByteString, fromLazyByteString )-import Blaze.ByteString.Builder.Char8 ( fromShow, fromString, fromChar )-import Blaze.ByteString.Builder.Word ( fromWord64be )-import Control.Arrow ( second )-import Control.Monad.Except ( ExceptT, runExceptT, liftIO, throwError )-import Crypto.Hash.Skein256 ( hash )-import Data.ByteString ( ByteString )-import Data.Int ( Int8, Int16, Int32, Int64 )-import Data.Map ( Map )-import Data.Monoid ( (<>), mconcat )-import Data.Serialize.Get ( runGet, getWord64be )-import Data.Text ( Text )-import Data.Word ( Word, Word8, Word16, Word32, Word64 )---- |Things go wrong with end-user storage, but things can also go wrong with--- reconstructing tree values. Implement 'stableTreeError' to allow 'load' and--- 'store' to report their own errors.-class Error e where- stableTreeError :: Text -> e---- |The opaque type to identify values and branches of trees.-data Id = Id !Word64 !Word64 !Word64 !Word64 deriving ( Show, Eq, Ord )---- |Write appropriate functions here to load and store primitive parts of--- trees.-data Store e k v = Store- { loadTree :: Id -> IO (Either e (Int, Map k Id))- , loadValue :: Id -> IO (Either e v)- , storeTree :: Id -> Int -> Map k Id -> IO (Maybe e)- , storeValue :: Id -> v -> IO (Maybe e)- }---- |Retrieve a tree given its id.-load :: (IsKey k, Ord k, Error e) => Store e k v -> Id -> IO (Either e (StableTree k v))-load s i = runExceptT $ load' s i--load' :: (IsKey k, Ord k, Error e) => Store e k v -> Id -> ExceptT e IO (StableTree k v)-load' storage treeId =- liftEitherIO (loadTree storage treeId) >>= \case- (0, contents) -> loadBottom contents- (depth, contents) -> loadBranch depth contents- where- loadBottom contents = do- vals <- loadValues contents Map.empty- case nextBottom vals of- Left i -> return $ StableTree_I i- Right (c,r) ->- if Map.null r- then return $ StableTree_C c- else err "Too many terminal keys in loadBottom"-- loadValues cont accum =- case Map.minViewWithKey cont of- Nothing -> return accum- Just ((k,valId),rest) -> do- v <- liftEitherIO $ loadValue storage valId- loadValues rest $ Map.insert k v accum-- loadBranch depth contents = do- children <- loadChildren contents Map.empty- let classify s = case s of StableTree_I i -> Right i- StableTree_C c -> Left c- (cs, is) = Map.mapEither classify children- case Map.minViewWithKey is >>= return . second Map.minViewWithKey of- Nothing -> go cs Nothing- Just (_, Just (_,_)) ->- err "Too many incomplete trees in loadBranch"- Just ((ik,iv), Nothing) ->- case Map.maxViewWithKey cs of- Nothing -> go cs $ Just (ik, iv)- Just ((ck,_), _) ->- if ck > ik- then err "Saw complete trees after incomplete..."- else go cs $ Just (ik, iv)- where- go completes mIncomplete =- case nextBranch completes mIncomplete of- Left i ->- if getDepth i == depth- then return $ StableTree_I i- else err "Depth mismatch in loadBranch"- Right (c,m) | Map.null m ->- if getDepth c == depth- then return $ StableTree_C c- else err "Depth mismatch in loadBranch"- _ -> err "Too many terminal keys in loadBranch"-- loadChildren cont accum =- case Map.minViewWithKey cont of- Nothing -> return accum- Just ((k,valId),rest) -> do- subtree <- load' storage valId- loadChildren rest $ Map.insert k subtree accum-- err = throwError . stableTreeError---- |Store a tree using a 'Store' and return its calculated 'Id'-store :: (Build k, Ord k, Build v)- => Store e k v- -> StableTree k v- -> IO (Either e Id)-store storage (StableTree_I i) = runExceptT $ store' storage i-store storage (StableTree_C c) = runExceptT $ store' storage c--store' :: (Build k, Ord k, Build v)- => Store e k v- -> Tree c k v- -> ExceptT e IO Id-store' storage tree =- case branchContents tree of- Left subtrees -> storeBranch subtrees- Right kvmap -> storeBottom kvmap-- where- storeBranch (complete, mIncomplete) = do- key_ids <- storeSubtrees complete Map.empty- case mIncomplete of- Nothing -> storeKeyIds key_ids- Just (k,v) -> do- treeId <- store' storage v- storeKeyIds $ Map.insert k treeId key_ids-- storeSubtrees kvmap accum =- case Map.minViewWithKey kvmap of- Nothing -> return accum- Just ((k,t), rest) -> do- treeId <- store' storage t- storeSubtrees rest $ Map.insert k treeId accum-- storeBottom kvmap = do- key_ids <- storeValues kvmap Map.empty- storeKeyIds key_ids-- storeValues kvmap accum = do- case Map.minViewWithKey kvmap of- Nothing -> return accum- Just ((k,v), rest) -> do- let valId = calcId $ build v- _ <- liftMaybeIO $ storeValue storage valId v- storeValues rest $ Map.insert k valId accum-- storeKeyIds key_ids =- let depth = getDepth tree- valId = treeHash depth key_ids- in do liftMaybeIO $ storeTree storage valId depth key_ids- return valId--treeHash :: Build k => Int -> Map k Id -> Id-treeHash depth contents =- let builders = [(build k, build v) | (k,v) <- Map.toAscList contents]- w_len = [(len k, k, v) | (k, v) <- builders]- bodybs = toByteString $ mconcat [l <> k <> v | (l,k,v) <- w_len]- bodylen = fromShow $ BS.length bodybs- header = (fromString "tree ")- <> bodylen <> fromChar ' '- <> fromShow depth <> fromChar '\0'- in calcId $ header <> fromByteString bodybs- where- len = fromShow . BS.length . toByteString--calcId :: Builder -> Id-calcId = right . runGet get . hash 256 . toByteString- where- right ei =- case ei of- Left _ -> error "Got a left!?"- Right v -> v-- get = do- a <- getWord64be- b <- getWord64be- c <- getWord64be- d <- getWord64be- return $ Id a b c d--liftEitherIO :: IO (Either a b) -> ExceptT a IO b-liftEitherIO act =- liftIO act >>= \case- Left err -> throwError err- Right val -> return val--liftMaybeIO :: IO (Maybe e) -> ExceptT e IO ()-liftMaybeIO act =- liftIO act >>= \case- Just err -> throwError err- Nothing -> return ()---- |Typeclass to generate unique 'ByteString's for StableTree keys and values.--- Used to generate the unique identities for values and branches.-class Build t where- build :: t -> Builder---- |Generate a builder for something that is already a 'Binary'-buildBinary :: B.Binary t => t -> Builder-buildBinary = fromLazyByteString . B.encode---- |Generate a builder for something that is already a 'Serialize'-buildSerialize :: S.Serialize t => t -> Builder-buildSerialize = fromByteString . S.encode--instance Build Id where- build (Id a b c d) = w a <> w b <> w c <> w d- where- w = fromWord64be--instance Build Char where- build = buildSerialize--instance Build Double where- build = buildSerialize--instance Build Float where- build = buildSerialize--instance Build Int where- build = buildSerialize--instance Build Int8 where- build = buildSerialize--instance Build Int16 where- build = buildSerialize--instance Build Int32 where- build = buildSerialize--instance Build Int64 where- build = buildSerialize--instance Build Integer where- build = buildSerialize--instance Build Word where- build = buildSerialize--instance Build Word8 where- build = buildSerialize--instance Build Word16 where- build = buildSerialize--instance Build Word32 where- build = buildSerialize--instance Build Word64 where- build = buildSerialize--instance Build ByteString where- build = fromByteString--instance Build Lazy.ByteString where- build = fromLazyByteString-
− src/Data/StableTree/IO/Ram.hs
@@ -1,58 +0,0 @@--- |--- Module : Data.StableTree.IO.Ram--- Copyright : Jeremy Groven--- License : BSD3------ A sample implementation of StableTree storage that just writes stuff to some--- Maps that are wrapped in IORefs.-module Data.StableTree.IO.Ram-( RamError(..)-, storage-) where--import Data.StableTree.IO ( Id, Error(..), Store(..) )--import qualified Data.Map as Map-import Data.IORef ( IORef, newIORef, readIORef, modifyIORef )-import Data.Map ( Map )-import Data.Text ( Text )---- |Error type for RAM storage. Not a lot can go wrong in RAM...-data RamError = NoKey- | ApiError Text- deriving ( Show )--instance Error RamError where- stableTreeError = ApiError---- |Create a new RAM store-storage :: IO ( Store RamError k v- , IORef (Map Id (Int,Map k Id))- , IORef (Map Id v) )-storage = do- trees <- newIORef Map.empty- values <- newIORef Map.empty- return ( Store (lt trees) (lv values) (st trees) (sv values)- , trees- , values )- where- lt store tid = do- m <- readIORef store- case Map.lookup tid m of- Nothing -> return $ Left NoKey- Just pair -> return $ Right pair-- lv store vid = do- m <- readIORef store- case Map.lookup vid m of- Nothing -> return $ Left NoKey- Just v -> return $ Right v-- st store tid depth tree = do- modifyIORef store $ Map.insert tid (depth,tree)- return Nothing-- sv store vid val = do- modifyIORef store $ Map.insert vid val- return Nothing-
+ src/Data/StableTree/Persist.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE LambdaCase, OverloadedStrings #-}+-- |+-- Module : Data.StableTree.Persist+-- Copyright : Jeremy Groven+-- License : BSD3+--+-- Logic for dealing with the actual persistence of Stable Trees. The key+-- exports here are 'Error', 'Store', 'load', and 'store'. A user needs to+-- implement the 'loadTree', 'loadValue', 'storeTree' and 'storeValue' parts of+-- 'Store', and make an appropriate Error type to report storage errors, and+-- then the 'load' and 'store' functions can just do their thing. If necessary,+-- a user can also implement 'Build' for custom data types.+module Data.StableTree.Persist+( Store(..)+, Build(..)+, Error(..)+, Id+, encodeId+, decodeId+, load+, store+, buildBinary+, buildSerialize+) where++import Data.StableTree.Types hiding ( hash )+import Data.StableTree ( StableTree(..) )++import qualified Data.Binary as B+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as Lazy+import qualified Data.Map as Map+import qualified Data.Serialize as S+import Blaze.ByteString.Builder ( Builder, toByteString )+import Blaze.ByteString.Builder.ByteString ( fromByteString, fromLazyByteString )+import Blaze.ByteString.Builder.Char8 ( fromShow, fromString, fromChar )+import Blaze.ByteString.Builder.Word ( fromWord64be )+import Control.Arrow ( second )+import Control.Monad.Except ( ExceptT, runExceptT, lift, throwError )+import Crypto.Hash.Skein256 ( hash )+import Data.ByteString ( ByteString )+import Data.Int ( Int8, Int16, Int32, Int64 )+import Data.Map ( Map )+import Data.Monoid ( (<>), mconcat )+import Data.Serialize.Get ( runGet, getWord64be )+import Data.Text ( Text )+import Data.Word ( Word, Word8, Word16, Word32, Word64 )++-- |Things go wrong with end-user storage, but things can also go wrong with+-- reconstructing tree values. Implement 'stableTreeError' to allow 'load' and+-- 'store' to report their own errors.+class Error e where+ stableTreeError :: Text -> e++-- |The opaque type to identify values and branches of trees.+data Id = Id !Word64 !Word64 !Word64 !Word64 deriving ( Show, Eq, Ord )++-- |Convert an Id into a 32-byte ByteString. Useful for actual storage of Ids+encodeId :: Id -> ByteString+encodeId = toByteString . build++-- |Convert a stored ByteString back into an Id. Gives a "Left err" if the+-- given ByteString isn't 32 bytes long+decodeId :: ByteString -> Either String Id+decodeId = runGet decode+ where+ decode = do+ a <- getWord64be+ b <- getWord64be+ c <- getWord64be+ d <- getWord64be+ return $ Id a b c d++-- |Write appropriate functions here to load and store primitive parts of+-- trees.+data Store m e k v = Store+ { loadTree :: Id -> m (Either e (Int, Map k Id))+ , loadValue :: Id -> m (Either e v)+ , storeTree :: Id -> Int -> Map k Id -> m (Maybe e)+ , storeValue :: Id -> v -> m (Maybe e)+ }++-- |Retrieve a tree given its id.+load :: (Monad m, IsKey k, Ord k, Error e) => Store m e k v -> Id -> m (Either e (StableTree k v))+load s i = runExceptT $ load' s i++load' :: (Monad m, IsKey k, Ord k, Error e) => Store m e k v -> Id -> ExceptT e m (StableTree k v)+load' storage treeId =+ liftEither (loadTree storage treeId) >>= \case+ (0, contents) -> loadBottom contents+ (depth, contents) -> loadBranch depth contents+ where+ loadBottom contents = do+ vals <- loadValues contents Map.empty+ case nextBottom vals of+ Left i -> return $ StableTree_I i+ Right (c,r) ->+ if Map.null r+ then return $ StableTree_C c+ else err "Too many terminal keys in loadBottom"++ loadValues cont accum =+ case Map.minViewWithKey cont of+ Nothing -> return accum+ Just ((k,valId),rest) -> do+ v <- liftEither $ loadValue storage valId+ loadValues rest $ Map.insert k v accum++ loadBranch depth contents = do+ children <- loadChildren contents Map.empty+ let classify s = case s of StableTree_I i -> Right i+ StableTree_C c -> Left c+ (cs, is) = Map.mapEither classify children+ case Map.minViewWithKey is >>= return . second Map.minViewWithKey of+ Nothing -> go cs Nothing+ Just (_, Just (_,_)) ->+ err "Too many incomplete trees in loadBranch"+ Just ((ik,iv), Nothing) ->+ case Map.maxViewWithKey cs of+ Nothing -> go cs $ Just (ik, iv)+ Just ((ck,_), _) ->+ if ck > ik+ then err "Saw complete trees after incomplete..."+ else go cs $ Just (ik, iv)+ where+ go completes mIncomplete =+ case nextBranch completes mIncomplete of+ Left i ->+ if getDepth i == depth+ then return $ StableTree_I i+ else err "Depth mismatch in loadBranch"+ Right (c,m) | Map.null m ->+ if getDepth c == depth+ then return $ StableTree_C c+ else err "Depth mismatch in loadBranch"+ _ -> err "Too many terminal keys in loadBranch"++ loadChildren cont accum =+ case Map.minViewWithKey cont of+ Nothing -> return accum+ Just ((k,valId),rest) -> do+ subtree <- load' storage valId+ loadChildren rest $ Map.insert k subtree accum++ err = throwError . stableTreeError++-- |Store a tree using a 'Store' and return its calculated 'Id'+store :: (Monad m, Build k, Ord k, Build v)+ => Store m e k v+ -> StableTree k v+ -> m (Either e Id)+store storage (StableTree_I i) = runExceptT $ store' storage i+store storage (StableTree_C c) = runExceptT $ store' storage c++store' :: (Monad m, Build k, Ord k, Build v)+ => Store m e k v+ -> Tree c k v+ -> ExceptT e m Id+store' storage tree =+ case branchContents tree of+ Left subtrees -> storeBranch subtrees+ Right kvmap -> storeBottom kvmap++ where+ storeBranch (complete, mIncomplete) = do+ key_ids <- storeSubtrees complete Map.empty+ case mIncomplete of+ Nothing -> storeKeyIds key_ids+ Just (k,v) -> do+ treeId <- store' storage v+ storeKeyIds $ Map.insert k treeId key_ids++ storeSubtrees kvmap accum =+ case Map.minViewWithKey kvmap of+ Nothing -> return accum+ Just ((k,t), rest) -> do+ treeId <- store' storage t+ storeSubtrees rest $ Map.insert k treeId accum++ storeBottom kvmap = do+ key_ids <- storeValues kvmap Map.empty+ storeKeyIds key_ids++ storeValues kvmap accum = do+ case Map.minViewWithKey kvmap of+ Nothing -> return accum+ Just ((k,v), rest) -> do+ let valId = calcId $ build v+ _ <- liftMaybe $ storeValue storage valId v+ storeValues rest $ Map.insert k valId accum++ storeKeyIds key_ids =+ let depth = getDepth tree+ valId = treeHash depth key_ids+ in do liftMaybe $ storeTree storage valId depth key_ids+ return valId++treeHash :: Build k => Int -> Map k Id -> Id+treeHash depth contents =+ let builders = [(build k, build v) | (k,v) <- Map.toAscList contents]+ w_len = [(len k, k, v) | (k, v) <- builders]+ bodybs = toByteString $ mconcat [l <> k <> v | (l,k,v) <- w_len]+ bodylen = fromShow $ BS.length bodybs+ header = (fromString "tree ")+ <> bodylen <> fromChar ' '+ <> fromShow depth <> fromChar '\0'+ in calcId $ header <> fromByteString bodybs+ where+ len = fromShow . BS.length . toByteString++calcId :: Builder -> Id+calcId = right . decodeId . hash 256 . toByteString+ where+ right ei =+ case ei of+ Left _ -> error "Got a left!?"+ Right v -> v++liftEither :: Monad m => m (Either a b) -> ExceptT a m b+liftEither act =+ lift act >>= \case+ Left err -> throwError err+ Right val -> return val++liftMaybe :: Monad m => m (Maybe e) -> ExceptT e m ()+liftMaybe act =+ lift act >>= \case+ Just err -> throwError err+ Nothing -> return ()++-- |Typeclass to generate unique 'ByteString's for StableTree keys and values.+-- Used to generate the unique identities for values and branches.+class Build t where+ build :: t -> Builder++-- |Generate a builder for something that is already a 'Binary'+buildBinary :: B.Binary t => t -> Builder+buildBinary = fromLazyByteString . B.encode++-- |Generate a builder for something that is already a 'Serialize'+buildSerialize :: S.Serialize t => t -> Builder+buildSerialize = fromByteString . S.encode++instance Build Id where+ build (Id a b c d) = w a <> w b <> w c <> w d+ where+ w = fromWord64be++instance Build Char where+ build = buildSerialize++instance Build Double where+ build = buildSerialize++instance Build Float where+ build = buildSerialize++instance Build Int where+ build = buildSerialize++instance Build Int8 where+ build = buildSerialize++instance Build Int16 where+ build = buildSerialize++instance Build Int32 where+ build = buildSerialize++instance Build Int64 where+ build = buildSerialize++instance Build Integer where+ build = buildSerialize++instance Build Word where+ build = buildSerialize++instance Build Word8 where+ build = buildSerialize++instance Build Word16 where+ build = buildSerialize++instance Build Word32 where+ build = buildSerialize++instance Build Word64 where+ build = buildSerialize++instance Build ByteString where+ build = fromByteString++instance Build Lazy.ByteString where+ build = fromLazyByteString+
+ src/Data/StableTree/Persist/Ram.hs view
@@ -0,0 +1,58 @@+-- |+-- Module : Data.StableTree.Persist.Ram+-- Copyright : Jeremy Groven+-- License : BSD3+--+-- A sample implementation of StableTree storage that just writes stuff to some+-- Maps that are wrapped in IORefs.+module Data.StableTree.Persist.Ram+( RamError(..)+, storage+) where++import Data.StableTree.Persist ( Id, Error(..), Store(..) )++import qualified Data.Map as Map+import Data.IORef ( IORef, newIORef, readIORef, modifyIORef )+import Data.Map ( Map )+import Data.Text ( Text )++-- |Error type for RAM storage. Not a lot can go wrong in RAM...+data RamError = NoKey+ | ApiError Text+ deriving ( Show )++instance Error RamError where+ stableTreeError = ApiError++-- |Create a new RAM store+storage :: IO ( Store IO RamError k v+ , IORef (Map Id (Int,Map k Id))+ , IORef (Map Id v) )+storage = do+ trees <- newIORef Map.empty+ values <- newIORef Map.empty+ return ( Store (lt trees) (lv values) (st trees) (sv values)+ , trees+ , values )+ where+ lt store tid = do+ m <- readIORef store+ case Map.lookup tid m of+ Nothing -> return $ Left NoKey+ Just pair -> return $ Right pair++ lv store vid = do+ m <- readIORef store+ case Map.lookup vid m of+ Nothing -> return $ Left NoKey+ Just v -> return $ Right v++ st store tid depth tree = do+ modifyIORef store $ Map.insert tid (depth,tree)+ return Nothing++ sv store vid val = do+ modifyIORef store $ Map.insert vid val+ return Nothing+
stable-tree.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: stable-tree-version: 0.1.0+version: 0.2.0 synopsis: Trees whose branches are resistant to change -- description: homepage: https://github.com/tsuraan/stable-tree@@ -23,13 +23,14 @@ hs-source-dirs: demo main-is: Main.hs default-language: Haskell2010+ ghc-options: -Wall -fllvm library exposed-modules: Data.StableTree , Data.StableTree.Types , Data.StableTree.Types.Key- , Data.StableTree.IO- , Data.StableTree.IO.Ram+ , Data.StableTree.Persist+ , Data.StableTree.Persist.Ram -- other-modules: -- other-extensions: build-depends: base >=4.6 && <4.8
tests/TestAll.hs view
@@ -3,8 +3,8 @@ ) where import qualified Data.StableTree as ST-import Data.StableTree.IO ( store, load )-import Data.StableTree.IO.Ram ( storage )+import Data.StableTree.Persist ( store, load )+import Data.StableTree.Persist.Ram ( storage ) import qualified Data.Map as Map import Control.Arrow ( first )