limits lowered

hbs2-core/lib/HBS2/Defaults.hs

@@ -14,26 +14,26 @@ defStorePath :: IsString a => a
 defStorePath = "hbs2"
 
 defPipelineSize :: Int
-defPipelineSize = 16000*4
+defPipelineSize = 16000
 
 defChunkWriterQ :: Integral a => a
-defChunkWriterQ = 32000
+defChunkWriterQ = 16000
 
 defBlockDownloadQ :: Integral a => a
-defBlockDownloadQ = 65536*128
+defBlockDownloadQ = 2000
 
 defBlockDownloadThreshold :: Integral a => a
 defBlockDownloadThreshold = 2
 
 -- typical block hash 530+ chunks * parallel wip blocks amount
 defProtoPipelineSize :: Int
-defProtoPipelineSize = 65536*4
+defProtoPipelineSize = 2000
 
 defCookieTimeout :: TimeSpec
-defCookieTimeout = toTimeSpec ( 300  :: Timeout 'Minutes)
+defCookieTimeout = toTimeSpec ( 120  :: Timeout 'Minutes)
 
 defBlockInfoTimeout :: TimeSpec
-defBlockInfoTimeout = toTimeSpec ( 300  :: Timeout 'Minutes)
+defBlockInfoTimeout = toTimeSpec ( 120  :: Timeout 'Minutes)
 
 -- how much time wait for block from peer?
 defBlockWaitMax :: Timeout 'Seconds

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

@@ -85,22 +85,19 @@ storageRefs = to f
 touchForRead :: (MonadIO m, IsSimpleStorageKey h) => SimpleStorage h -> Key h -> m ByteString
 touchForRead ss k  = liftIO $ do
 
+  mbs <- readTVarIO mmaped <&> HashMap.lookup k
+
+  case mbs of
+    Just bs -> pure bs
+    Nothing -> do
+
       bsmm <- unsafeMMapFile (simpleBlockFileName ss k)
       tick <- getTime MonotonicCoarse
 
       atomically $ do
-
-    mbs <- readTVar mmaped <&> HashMap.lookup k
-
-    r <- case mbs of
-           Just bs -> pure bs
-           Nothing -> do
         modifyTVar' mmaped (HashMap.insert k bsmm)
-            pure bsmm
-
         modifyTVar' (ss ^. storageMMapedLRU) (HashMap.insert k tick)
-
+        pure bsmm
-    pure r
 
   where
     mmaped = ss ^. storageMMaped
@@ -109,7 +106,7 @@ touchForRead ss k  = liftIO $ do
 simpleStorageInit :: (MonadIO m, Data opts, IsSimpleStorageKey h) => opts -> m (SimpleStorage h)
 simpleStorageInit opts = liftIO $ do
   let prefix = uniLastDef "." opts :: StoragePrefix
-  let qSize  = uniLastDef 20000 opts :: StorageQueueSize
+  let qSize  = uniLastDef 2000 opts :: StorageQueueSize
 
   stor <- SimpleStorage
                 <$> canonicalizePath (fromPrefix prefix)
@@ -155,8 +152,8 @@ simpleStorageWorker ss = do
       Nothing -> pure ()
       Just a  -> a >> next
 
-  killer30 <- async $ forever $ do
+  killer <- async $ forever $ do
-    pause ( 30 :: Timeout 'Seconds ) -- FIXME: setting
+    pause ( 10 :: Timeout 'Seconds ) -- FIXME: setting
 
     atomically $ do
 
@@ -167,11 +164,11 @@ simpleStorageWorker ss = do
 
       writeTVar ( ss ^. storageMMaped ) survived
 
-  killer5 <- async $ forever $ do
+  killerLRU <- async $ forever $ do
-    pause ( 5 :: Timeout 'Seconds ) -- FIXME: setting
+    pause ( 2 :: Timeout 'Seconds ) -- FIXME: setting
     atomically $ writeTVar ( ss ^. storageMMapedLRU ) mempty
 
-  (_, e) <- waitAnyCatchCancel [ops,killer30, killer5]
+  (_, e) <- waitAnyCatchCancel [ops,killer, killerLRU]
 
   pure ()
 

hbs2-tests/test/Peer2Main.hs

@@ -597,29 +597,28 @@ main = do
                 let findBlk = hasBlock s
 
                 -- let size = 1024*1024*1
-                let size = 1024*1024*30
+                -- let size = 1024*1024*30
-                g <- initialize $ U.fromList [fromIntegral p, fromIntegral size]
+                -- g <- initialize $ U.fromList [fromIntegral p, fromIntegral size]
 
-                bytes <- replicateM size $ uniformM g :: IO [Char]
+                -- bytes <- replicateM size $ uniformM g :: IO [Char]
 
-                let blk = B8.pack bytes
+                -- let blk = B8.pack bytes
 
-                root <- putAsMerkle s blk
+                -- root <- putAsMerkle s blk
 
-                rootSz <- hasBlock s (fromMerkleHash root)
+                -- rootSz <- hasBlock s (fromMerkleHash root)
 
-                debug $ "I'm" <+> pretty p <+> pretty root
+                -- debug $ "I'm" <+> pretty p <+> pretty root
 
                 runPeerM (AnyStorage s) fake p $ do
                   adapter <- mkAdapter cw
-
+                  -- env <- ask
-                  env <- ask
+                  -- liftIO $ async $ withPeerM env $ do
-                  liftIO $ async $ withPeerM env $ do
+                      -- maybe1 rootSz (pure ()) $ \rsz -> do
-                      maybe1 rootSz (pure ()) $ \rsz -> do
+                      --   pause ( 0.001 :: Timeout 'Seconds )
-                        pause ( 0.001 :: Timeout 'Seconds )
+                      --   let info = BlockAnnounceInfo 0 NoBlockInfoMeta rsz (fromMerkleHash root)
-                        let info = BlockAnnounceInfo 0 NoBlockInfoMeta rsz (fromMerkleHash root)
+                      --   let ann = BlockAnnounce @Fake info
-                        let ann = BlockAnnounce @Fake info
+                      --   request @Fake p0 ann
-                        request @Fake p0 ann
 
                   runProto @Fake
                     [ makeResponse (blockSizeProto findBlk dontHandle)