mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
ca29851f6d
commit
ce9510efeb
|
|
@ -63,7 +63,9 @@ library
|
|||
import: shared-properties
|
||||
|
||||
exposed-modules:
|
||||
HBS2.Hash
|
||||
, HBS2.Defaults
|
||||
, HBS2.Hash
|
||||
, HBS2.Merkle
|
||||
, HBS2.Clock
|
||||
, HBS2.Prelude
|
||||
, HBS2.Prelude.Plated
|
||||
|
|
@ -86,6 +88,7 @@ library
|
|||
, hashable
|
||||
, interpolatedstring-perl6
|
||||
, memory
|
||||
, microlens-platform
|
||||
, prettyprinter
|
||||
, safe
|
||||
, serialise
|
||||
|
|
|
|||
|
|
@ -0,0 +1,9 @@
|
|||
module HBS2.Defaults where
|
||||
|
||||
defChunkSize :: Integer
|
||||
defChunkSize = 500
|
||||
|
||||
defBlockSize :: Integer
|
||||
defBlockSize = 256 * 1024
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,164 @@
|
|||
{-# Language TemplateHaskell #-}
|
||||
{-# Language DeriveFunctor #-}
|
||||
module HBS2.Merkle where
|
||||
|
||||
import Codec.Serialise
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.Data
|
||||
import Data.Foldable (traverse_)
|
||||
import Data.List qualified as List
|
||||
import Lens.Micro.Platform
|
||||
import Safe
|
||||
import GHC.Generics
|
||||
|
||||
import HBS2.Hash
|
||||
|
||||
class Foldable t => Chunks t a where
|
||||
chunks :: Int -> a -> t a
|
||||
|
||||
instance Chunks [] ByteString where
|
||||
chunks i bs = go [] bs
|
||||
where
|
||||
size = fromIntegral i
|
||||
go acc x | BS.null x = acc
|
||||
| BS.length x <= size = acc <> [x]
|
||||
| otherwise = go (acc <> [BS.take size x]) (BS.drop size x)
|
||||
|
||||
instance Chunks [] LBS.ByteString where
|
||||
chunks i bs = go [] bs
|
||||
where
|
||||
size = fromIntegral i
|
||||
go acc x | LBS.null x = acc
|
||||
| LBS.length x <= size = acc <> [x]
|
||||
| otherwise = go (acc <> [LBS.take size x]) (LBS.drop size x)
|
||||
|
||||
instance Chunks [] [a] where
|
||||
chunks i xs = go xs
|
||||
where
|
||||
go [] = []
|
||||
go es | length es <= i = [es]
|
||||
| otherwise = let (p, ps) = List.splitAt i es in p : go ps
|
||||
|
||||
|
||||
data PTree a = T [PTree a] | L a
|
||||
deriving stock (Show, Functor, Generic)
|
||||
|
||||
|
||||
instance Foldable PTree where
|
||||
foldr fn acc (L a) = fn a acc
|
||||
foldr fn acc (T xs) = go acc xs
|
||||
where
|
||||
go b [] = b
|
||||
go b (y:ys) = foldr fn (go b ys) y
|
||||
|
||||
instance Traversable PTree where
|
||||
traverse fn (L a) = L <$> fn a
|
||||
traverse fn (T xs) = T <$> traverse (traverse fn) xs
|
||||
|
||||
newtype MaxNum a = MaxNum a
|
||||
newtype MaxSize a = MaxSize a
|
||||
|
||||
|
||||
newtype MNodeData =
|
||||
MNodeData
|
||||
{ _mnodeHeight :: Integer
|
||||
}
|
||||
deriving stock (Generic,Data,Show)
|
||||
|
||||
makeLenses ''MNodeData
|
||||
|
||||
instance Serialise MNodeData
|
||||
|
||||
data MTree a = MNode MNodeData [Hash HbSync] | MLeaf a
|
||||
deriving stock (Generic,Data,Show)
|
||||
|
||||
instance Serialise a => Serialise (MTree a)
|
||||
|
||||
newMNode :: Integer -> [Hash HbSync] -> MTree a
|
||||
newMNode h = MNode (MNodeData h)
|
||||
|
||||
toPTree :: (Chunks [] a)
|
||||
=> MaxSize Int
|
||||
-> MaxNum Int
|
||||
-> a
|
||||
-> PTree a
|
||||
|
||||
toPTree (MaxSize s) (MaxNum n) items | n <= 1 =
|
||||
case T $ fmap L (chunks s items) of
|
||||
T [L x] -> L x
|
||||
_ -> T []
|
||||
|
||||
toPTree (MaxSize s) (MaxNum n) items = go $ T (fmap L (chunks s items))
|
||||
where
|
||||
go (T []) = T []
|
||||
go (T [L x]) = L x
|
||||
go (T xs) | length xs <= n = T xs
|
||||
| otherwise = go $ T $ fmap go [ T x | x <- chunks n xs ]
|
||||
|
||||
go leaf = leaf
|
||||
|
||||
|
||||
makeMerkle :: (Monad m, Serialise a, Serialise (MTree a))
|
||||
=> Integer -- | initial height
|
||||
-> PTree a
|
||||
-> ((Hash HbSync, MTree a, LBS.ByteString) -> m ())
|
||||
-> m (Hash HbSync)
|
||||
|
||||
makeMerkle h0 pt f = fst <$> go h0 pt
|
||||
where
|
||||
go hx (T xs) = do
|
||||
rs <- mapM (go hx) xs
|
||||
let hxx = maximumDef hx (fmap snd rs)
|
||||
let o = newMNode hxx (fmap fst rs)
|
||||
let bs = serialise o
|
||||
let h = hashObject bs
|
||||
f (h, o, bs)
|
||||
pure (h, 1+hxx)
|
||||
|
||||
go hx (L x) = do
|
||||
let o = MLeaf x
|
||||
let bs = serialise o
|
||||
let h = hashObject bs
|
||||
f (h, o, bs)
|
||||
pure (h, 1+hx)
|
||||
|
||||
|
||||
|
||||
walkMerkle' :: (Serialise (MTree a), Monad m)
|
||||
=> Hash HbSync
|
||||
-> ( Hash HbSync -> m (Maybe LBS.ByteString) )
|
||||
-> ( MTree a -> m () )
|
||||
-> m ()
|
||||
|
||||
walkMerkle' root flookup sink = go root
|
||||
where
|
||||
go hash = do
|
||||
t <- (deserialise <$>) <$> flookup hash
|
||||
case t of
|
||||
Just n@(MLeaf _) -> sink n
|
||||
Just n@(MNode _ hashes) -> sink n >> traverse_ go hashes
|
||||
Nothing -> pure ()
|
||||
|
||||
walkMerkle :: (Serialise (MTree a), Monad m)
|
||||
=> Hash HbSync
|
||||
-> ( Hash HbSync -> m (Maybe LBS.ByteString) )
|
||||
-> ( a -> m () )
|
||||
-> m ()
|
||||
|
||||
walkMerkle root flookup sink = walkMerkle' root flookup withTree
|
||||
where
|
||||
withTree = \case
|
||||
(MLeaf s) -> sink s
|
||||
(MNode _ _) -> pure ()
|
||||
|
||||
-- walkMerkle root flookup sink = go root
|
||||
-- where
|
||||
-- go hash = do
|
||||
-- t <- (deserialise <$>) <$> flookup hash
|
||||
-- case t of
|
||||
-- Nothing -> pure ()
|
||||
-- Just (MLeaf s) -> sink s
|
||||
-- Just (MNode _ hashes) -> traverse_ go hashes
|
||||
|
||||
|
|
@ -1,8 +1,12 @@
|
|||
module HBS2.Prelude
|
||||
( module Data.String
|
||||
, module HBS2.Defaults
|
||||
-- , module HBS2.Prelude
|
||||
) where
|
||||
|
||||
import Data.String (IsString(..))
|
||||
|
||||
import HBS2.Defaults
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
module HBS2.Prelude.Plated
|
||||
( module HBS2.Prelude.Plated
|
||||
, module HBS2.Prelude
|
||||
, module Data.Data
|
||||
, module Data.Generics.Uniplate.Operations
|
||||
, Data
|
||||
, Generic
|
||||
) where
|
||||
|
||||
|
|
@ -12,6 +12,8 @@ import Data.Generics.Uniplate.Operations
|
|||
import GHC.Generics(Generic)
|
||||
import Safe
|
||||
|
||||
import HBS2.Prelude
|
||||
|
||||
uniLastMay :: forall to from . (Data from, Data to) => from -> Maybe to
|
||||
uniLastMay = lastMay . universeBi
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,5 @@
|
|||
# Revision history for hbs2
|
||||
|
||||
## 0.1.0.0 -- YYYY-mm-dd
|
||||
|
||||
* First version. Released on an unsuspecting world.
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
Copyright (c) 2023,
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* 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.
|
||||
|
||||
* Neither the name of nor the names of other
|
||||
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
|
||||
OWNER 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.
|
||||
|
|
@ -0,0 +1,83 @@
|
|||
module Main where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString qualified as B
|
||||
import Data.Function
|
||||
import Options.Applicative
|
||||
import Prettyprinter
|
||||
import System.IO
|
||||
|
||||
import Streaming.Prelude qualified as S
|
||||
import Streaming qualified as S
|
||||
|
||||
import HBS2.Storage
|
||||
import HBS2.Storage.Simple
|
||||
import HBS2.Prelude
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Merkle
|
||||
import HBS2.Hash
|
||||
|
||||
newtype HashRef = HashRef (Hash HbSync)
|
||||
deriving newtype (Eq,Ord,IsString,Pretty)
|
||||
deriving stock (Data)
|
||||
|
||||
newtype OptInputFile = OptInputFile { unOptFile :: FilePath }
|
||||
deriving newtype (Eq,Ord,IsString)
|
||||
deriving stock (Data)
|
||||
|
||||
newtype Opts =
|
||||
Opts {
|
||||
optInputFile :: Maybe OptInputFile
|
||||
}
|
||||
deriving stock (Data)
|
||||
|
||||
readChunked :: MonadIO m => Handle -> Int -> S.Stream (S.Of ByteString) m ()
|
||||
readChunked handle size = fuu
|
||||
where
|
||||
fuu = fix \next -> do
|
||||
chunk <- liftIO do
|
||||
B.hGet handle size
|
||||
unless (B.null chunk) do
|
||||
S.yield chunk
|
||||
next
|
||||
|
||||
runStore :: Opts -> IO ()
|
||||
runStore opts = do
|
||||
|
||||
let fname = uniLastMay @OptInputFile opts
|
||||
|
||||
handle <- maybe (pure stdin) (flip openFile ReadMode . unOptFile) fname
|
||||
|
||||
hashes <- readChunked handle (fromIntegral defBlockSize) -- FIXME: to settings!
|
||||
& S.map (hashObject . B.copy)
|
||||
& S.map HashRef
|
||||
& S.toList_
|
||||
|
||||
let pt = toPTree (MaxSize 2048) (MaxNum 2048) hashes
|
||||
|
||||
mapM_ (print . pretty) hashes
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = join . customExecParser (prefs showHelpOnError) $
|
||||
info (helper <*> parser)
|
||||
( fullDesc
|
||||
<> header "hbsync block fetch"
|
||||
<> progDesc "fetches blocks from hbsync peers"
|
||||
)
|
||||
where
|
||||
parser :: Parser (IO ())
|
||||
parser = hsubparser ( command "store" (info pStore (progDesc "store block"))
|
||||
)
|
||||
|
||||
common = do
|
||||
pure ()
|
||||
|
||||
pStore = do
|
||||
_ <- common
|
||||
file <- optional $ strArgument ( metavar "FILE" )
|
||||
pure $ runStore ( Opts file )
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,92 @@
|
|||
cabal-version: 3.0
|
||||
name: hbs2
|
||||
version: 0.1.0.0
|
||||
-- synopsis:
|
||||
-- description:
|
||||
license: BSD-3-Clause
|
||||
license-file: LICENSE
|
||||
-- author:
|
||||
-- maintainer:
|
||||
-- copyright:
|
||||
category: Network
|
||||
build-type: Simple
|
||||
extra-doc-files: CHANGELOG.md
|
||||
-- extra-source-files:
|
||||
|
||||
|
||||
common shared-properties
|
||||
ghc-options:
|
||||
-Wall
|
||||
-- -fno-warn-unused-matches
|
||||
-- -fno-warn-unused-do-bind
|
||||
-- -Werror=missing-methods
|
||||
-- -Werror=incomplete-patterns
|
||||
-- -fno-warn-unused-binds
|
||||
-threaded
|
||||
-rtsopts
|
||||
"-with-rtsopts=-N4 -A64m -AL256m -I0"
|
||||
|
||||
|
||||
default-language: Haskell2010
|
||||
|
||||
default-extensions:
|
||||
ApplicativeDo
|
||||
, BangPatterns
|
||||
, BlockArguments
|
||||
, ConstraintKinds
|
||||
, DataKinds
|
||||
, DeriveDataTypeable
|
||||
, DeriveGeneric
|
||||
, DerivingStrategies
|
||||
, DerivingVia
|
||||
, ExtendedDefaultRules
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, GADTs
|
||||
, GeneralizedNewtypeDeriving
|
||||
, ImportQualifiedPost
|
||||
, LambdaCase
|
||||
, MultiParamTypeClasses
|
||||
, OverloadedStrings
|
||||
, QuasiQuotes
|
||||
, ScopedTypeVariables
|
||||
, StandaloneDeriving
|
||||
, TupleSections
|
||||
, TypeApplications
|
||||
, TypeFamilies
|
||||
|
||||
|
||||
executable hbs2
|
||||
import: shared-properties
|
||||
main-is: Main.hs
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
build-depends: base ^>=4.15.1.0, hbs2-core, hbs2-storage-simple
|
||||
, aeson
|
||||
, async
|
||||
, base58-bytestring
|
||||
, binary
|
||||
, bytestring
|
||||
, cborg
|
||||
, clock
|
||||
, containers
|
||||
, cryptonite
|
||||
, deepseq
|
||||
, hashable
|
||||
, interpolatedstring-perl6
|
||||
, memory
|
||||
, optparse-applicative
|
||||
, prettyprinter
|
||||
, safe
|
||||
, serialise
|
||||
, streaming
|
||||
, text
|
||||
, uniplate
|
||||
|
||||
|
||||
|
||||
hs-source-dirs: .
|
||||
default-language: Haskell2010
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue