super slow

hbs2-core/hbs2-core.cabal

@@ -120,6 +120,7 @@ library
                      , stm-chans
                      , text
                      , transformers
+                     , temporary
                      , uniplate
                      , unordered-containers
 

hbs2-core/lib/HBS2/Actors.hs

@@ -14,6 +14,7 @@ import Control.Concurrent.STM.TBMQueue qualified as TBMQ
 import Control.Concurrent.STM.TBMQueue (TBMQueue)
 import Control.Concurrent.STM.TVar qualified as TVar
 import Control.Monad
+import Control.Concurrent.Async
 import Data.Function
 import Data.Functor
 import Data.Kind

hbs2-core/lib/HBS2/Actors/ChunkWriter.hs

@@ -30,6 +30,9 @@ import System.Directory
 import System.FilePath
 import System.IO.Error
 import System.IO
+import System.IO.Temp
+
+import Control.Concurrent.Async
 
 import Control.Concurrent.STM
 import Control.Concurrent.STM.TBQueue qualified as Q

hbs2-core/lib/HBS2/Data/Detect.hs

@@ -0,0 +1,26 @@
+module HBS2.Data.Detect where
+
+import HBS2.Prelude.Plated
+import HBS2.Hash
+import HBS2.Data.Types
+import HBS2.Merkle
+
+import Codec.Serialise (deserialiseOrFail)
+import Data.ByteString.Lazy (ByteString)
+import Data.Either
+import Data.Function
+
+data BlobType =  Merkle (Hash HbSync)
+               | AnnRef (Hash HbSync)
+               | Blob (Hash HbSync)
+               deriving (Show,Data)
+
+
+tryDetect :: Hash HbSync -> ByteString -> BlobType
+tryDetect hash obj = rights [mbLink, mbMerkle] & headDef orBlob
+
+  where
+    mbLink   = deserialiseOrFail @AnnotatedHashRef obj >> pure (AnnRef hash)
+    mbMerkle = deserialiseOrFail @(MTree [HashRef]) obj >> pure (Merkle hash)
+    orBlob   = Blob hash
+

hbs2-core/lib/HBS2/Defaults.hs

@@ -14,13 +14,13 @@ defStorePath :: IsString a => a
 defStorePath = "hbs2"
 
 defPipelineSize :: Int
-defPipelineSize = 1000
+defPipelineSize = 2000
 
 defChunkWriterQ :: Integral a => a
-defChunkWriterQ = 1000
+defChunkWriterQ = 2000
 
 defBlockDownloadQ :: Integral a => a
-defBlockDownloadQ = 65536*4
+defBlockDownloadQ = 65536*128
 
 defBlockDownloadThreshold :: Integral a => a
 defBlockDownloadThreshold = 2

hbs2-storage-simple/lib/HBS2/Storage/Simple.hs

@@ -80,7 +80,7 @@ storageRefs = to f
 simpleStorageInit :: (MonadIO m, Data opts) => opts -> m (SimpleStorage h)
 simpleStorageInit opts = liftIO $ do
   let prefix = uniLastDef "." opts :: StoragePrefix
-  let qSize  = uniLastDef 500 opts :: StorageQueueSize
+  let qSize  = uniLastDef 20000 opts :: StorageQueueSize
 
   pdir <- canonicalizePath (fromPrefix prefix)
 
@@ -88,7 +88,7 @@ simpleStorageInit opts = liftIO $ do
 
   tstop <- TV.newTVarIO False
 
-  hcache <- Cache.newCache (Just (toTimeSpec @'Seconds 1)) -- FIXME: real setting
+  hcache <- Cache.newCache (Just (toTimeSpec @'Seconds 30)) -- FIXME: real setting
 
   let stor = SimpleStorage
              { _storageDir = pdir

hbs2-tests/test/Peer2Main.hs

@@ -146,7 +146,7 @@ runTestPeer p zu = do
   stor <- simpleStorageInit opts
   cww  <- newChunkWriterIO  stor (Just chDir)
 
-  sw <- liftIO $ replicateM 1 $ async $ simpleStorageWorker stor
+  sw <- liftIO $ replicateM 8 $ async $ simpleStorageWorker stor
   cw <- liftIO $ replicateM 1 $ async $ runChunkWriter cww
 
   zu stor cww
@@ -196,7 +196,7 @@ blockDownloadLoop = do
   let blks = [ "5KP4vM6RuEX6RA1ywthBMqZV5UJDLANC17UrF6zuWdRt"
              , "81JeD7LNR6Q7RYfyWBxfjJn1RsWzvegkUXae6FUNgrMZ"
              , "81JeD7LNR6Q7RYfyWBxfjJn1RsWzvegkUXae6FUNgrMZ"
-             , "ECWYwWXiLgNvCkN1EFpSYqsPcWfnL4bAQADsyZgy1Cbr"
+             , "GTtQp6QjK7G9Sh5Aq4koGSpMX398WRWn3DV28NUAYARg"
              ]
 
   blq  <- liftIO $ Q.newTBQueueIO defBlockDownloadQ
@@ -260,11 +260,12 @@ blockDownloadLoop = do
 
       env <- ask
       pip <- asks (view envDeferred)
+      debug "process block!"
       liftIO $ addJob pip $ withPeerM env $ do
       -- void $ liftIO $ async $ withPeerM env $ do
 
         sto <- getStorage
-        debug $ "GOT BLOCK!" <+> pretty h
+        liftIO $ async $ debug $ "GOT BLOCK!" <+> pretty h
         bt <- liftIO $ getBlock sto h <&> fmap (tryDetect h)
         -- debug $ pretty (show bt)