wip

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

hbs2-core/lib/HBS2/Defaults.hs

@@ -0,0 +1,9 @@
+module HBS2.Defaults where
+
+defChunkSize :: Integer
+defChunkSize = 500
+
+defBlockSize :: Integer
+defBlockSize = 256 * 1024
+
+

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
+

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
+
 
 

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
 

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.

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.

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 )
+
+

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
+
+
+