diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 6128d798..7e141919 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -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 diff --git a/hbs2-core/lib/HBS2/Defaults.hs b/hbs2-core/lib/HBS2/Defaults.hs new file mode 100644 index 00000000..731d7565 --- /dev/null +++ b/hbs2-core/lib/HBS2/Defaults.hs @@ -0,0 +1,9 @@ +module HBS2.Defaults where + +defChunkSize :: Integer +defChunkSize = 500 + +defBlockSize :: Integer +defBlockSize = 256 * 1024 + + diff --git a/hbs2-core/lib/HBS2/Merkle.hs b/hbs2-core/lib/HBS2/Merkle.hs new file mode 100644 index 00000000..61cdf168 --- /dev/null +++ b/hbs2-core/lib/HBS2/Merkle.hs @@ -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 + diff --git a/hbs2-core/lib/HBS2/Prelude.hs b/hbs2-core/lib/HBS2/Prelude.hs index a57ce280..466d421a 100644 --- a/hbs2-core/lib/HBS2/Prelude.hs +++ b/hbs2-core/lib/HBS2/Prelude.hs @@ -1,8 +1,12 @@ module HBS2.Prelude ( module Data.String + , module HBS2.Defaults + -- , module HBS2.Prelude ) where import Data.String (IsString(..)) +import HBS2.Defaults + diff --git a/hbs2-core/lib/HBS2/Prelude/Plated.hs b/hbs2-core/lib/HBS2/Prelude/Plated.hs index 85ba5af0..ba9fbaaa 100644 --- a/hbs2-core/lib/HBS2/Prelude/Plated.hs +++ b/hbs2-core/lib/HBS2/Prelude/Plated.hs @@ -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 diff --git a/hbs2/CHANGELOG.md b/hbs2/CHANGELOG.md new file mode 100644 index 00000000..ccab0f21 --- /dev/null +++ b/hbs2/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for hbs2 + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/hbs2/LICENSE b/hbs2/LICENSE new file mode 100644 index 00000000..3cbe915d --- /dev/null +++ b/hbs2/LICENSE @@ -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. diff --git a/hbs2/Main.hs b/hbs2/Main.hs new file mode 100644 index 00000000..1a22ea16 --- /dev/null +++ b/hbs2/Main.hs @@ -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 ) + + diff --git a/hbs2/hbs2.cabal b/hbs2/hbs2.cabal new file mode 100644 index 00000000..2a49645b --- /dev/null +++ b/hbs2/hbs2.cabal @@ -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 + + +