diff --git a/hbs2-core/lib/HBS2/Defaults.hs b/hbs2-core/lib/HBS2/Defaults.hs index 8b0d56bf..64ed873b 100644 --- a/hbs2-core/lib/HBS2/Defaults.hs +++ b/hbs2-core/lib/HBS2/Defaults.hs @@ -37,10 +37,7 @@ defBlockInfoTimeout = toTimeSpec ( 120 :: Timeout 'Minutes) -- how much time wait for block from peer? defBlockWaitMax :: Timeout 'Seconds -defBlockWaitMax = 300 :: Timeout 'Seconds - -defBlockWaitSleep :: Timeout 'Seconds -defBlockWaitSleep = 1 :: Timeout 'Seconds +defBlockWaitMax = 60 :: Timeout 'Seconds defSweepTimeout :: Timeout 'Seconds defSweepTimeout = 5 -- FIXME: only for debug! diff --git a/hbs2-core/lib/HBS2/Net/Messaging/Fake.hs b/hbs2-core/lib/HBS2/Net/Messaging/Fake.hs index a25f5ba9..5048ad3a 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging/Fake.hs +++ b/hbs2-core/lib/HBS2/Net/Messaging/Fake.hs @@ -12,13 +12,11 @@ import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TChan qualified as Chan import Control.Concurrent.STM.TChan (TChan,newTChanIO) import Control.Monad.IO.Class -import Data.Cache (Cache) -import Data.Cache qualified as Cache import Data.List qualified as List import Data.Maybe import Data.Hashable import Data.HashMap.Strict (HashMap) -import Data.HashMap.Strict as HashMap +import Data.HashMap.Strict qualified as HashMap diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs index 2416df46..80d4fc9d 100644 --- a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs +++ b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs @@ -153,7 +153,7 @@ simpleStorageWorker ss = do Just a -> a >> next killer <- async $ forever $ do - pause ( 10 :: Timeout 'Seconds ) -- FIXME: setting + pause ( 20 :: Timeout 'Seconds ) -- FIXME: setting atomically $ do @@ -165,7 +165,7 @@ simpleStorageWorker ss = do writeTVar ( ss ^. storageMMaped ) survived killerLRU <- async $ forever $ do - pause ( 2 :: Timeout 'Seconds ) -- FIXME: setting + pause ( 5 :: Timeout 'Seconds ) -- FIXME: setting atomically $ writeTVar ( ss ^. storageMMapedLRU ) mempty (_, e) <- waitAnyCatchCancel [ops,killer, killerLRU] diff --git a/hbs2-tests/test/Peer2Main.hs b/hbs2-tests/test/Peer2Main.hs index caf474bb..c09a895d 100644 --- a/hbs2-tests/test/Peer2Main.hs +++ b/hbs2-tests/test/Peer2Main.hs @@ -13,7 +13,6 @@ import HBS2.Data.Detect import HBS2.Data.Types import HBS2.Defaults import HBS2.Events -import HBS2.Hash import HBS2.Merkle import HBS2.Net.Messaging.Fake import HBS2.Net.PeerLocator @@ -25,7 +24,6 @@ import HBS2.Net.Proto.Sessions import HBS2.Prelude.Plated import HBS2.Storage import HBS2.Storage.Simple -import HBS2.Storage.Simple.Extra import Test.Tasty.HUnit @@ -49,17 +47,12 @@ import System.Directory import System.Exit import System.FilePath.Posix import System.IO -import System.Clock -import Safe import Data.Hashable import Type.Reflection import Data.Fixed import Data.Dynamic -import System.Random.MWC -import qualified Data.Vector.Unboxed as U - debug :: (MonadIO m) => Doc ann -> m () debug p = liftIO $ hPrint stderr p @@ -95,9 +88,9 @@ instance Pretty (Peer Fake) where instance HasProtocol Fake (BlockInfo Fake) where type instance ProtocolId (BlockInfo Fake) = 1 - type instance Encoded Fake = Dynamic - decode = fromDynamic - encode = toDyn + type instance Encoded Fake = ByteString + decode = either (const Nothing) Just . deserialiseOrFail + encode = serialise -- FIXME: 3 is for debug only! instance Expires (EventKey Fake (BlockInfo Fake)) where @@ -111,15 +104,15 @@ instance Expires (EventKey Fake (BlockAnnounce Fake)) where instance HasProtocol Fake (BlockChunks Fake) where type instance ProtocolId (BlockChunks Fake) = 2 - type instance Encoded Fake = Dynamic - decode = fromDynamic - encode = toDyn + type instance Encoded Fake = ByteString + decode = either (const Nothing) Just . deserialiseOrFail + encode = serialise instance HasProtocol Fake (BlockAnnounce Fake) where type instance ProtocolId (BlockAnnounce Fake) = 3 - type instance Encoded Fake = Dynamic - decode = fromDynamic - encode = toDyn + type instance Encoded Fake = ByteString + decode = either (const Nothing) Just . deserialiseOrFail + encode = serialise type instance SessionData e (BlockInfo e) = BlockSizeSession e type instance SessionData e (BlockChunks e) = BlockDownload @@ -224,9 +217,9 @@ instance Typeable (SessionKey e (Stats e)) => Hashable (SessionKey e (Stats e)) instance HasProtocol Fake (Stats Fake) where type instance ProtocolId (Stats Fake) = 0xFFFFFFFE - type instance Encoded Fake = Dynamic - decode = fromDynamic - encode = toDyn + type instance Encoded Fake = ByteString + decode = either (const Nothing) Just . deserialiseOrFail + encode = serialise newtype Speed = Speed (Fixed E1) deriving newtype (Ord, Eq, Num, Real, Fractional, Show) @@ -388,36 +381,19 @@ blockDownloadLoop cw = do subscribe @e (BlockChunksEventKey (coo,h)) $ \(BlockReady _) -> do processBlock q h - let blockWtf = do - debug $ "WTF!" <+> pretty (p,coo) <+> pretty h - liftIO $ atomically $ Q.writeTBQueue q (DownloadTask h Nothing) - -- initDownload True q p h thisBkSiz - liftIO $ async $ do - -- FIXME: block is not downloaded, return it to the Q - void $ race (pause defBlockWaitMax >> blockWtf) - $ withPeerM env $ fix \next -> do - w <- find @e key (view sBlockWrittenT) - - maybe1 w (pure ()) $ \z -> do - wrt <- liftIO $ readTVarIO z - - if fromIntegral wrt >= thisBkSize then do - h1 <- liftIO $ getHash cw key h - if | h1 == Just h -> do - pure () - -- liftIO $ commitBlock cw key h - -- expire @e key - - | h1 /= Just h -> do - debug "block fucked" - pause defBlockWaitMax -- - - | otherwise -> pure () - - else do - pause defBlockWaitSleep - next + -- -- FIXME: block is not downloaded, return it to the Q + void $ withPeerM env $ do + pause defBlockWaitMax + w <- find @e key (view sBlockWrittenT) + maybe1 w (pure ()) \_ -> do + h1 <- liftIO $ getHash cw key h + if h1 == Just h then do + liftIO $ commitBlock cw key h + expire @e key + else do + debug $ "Block lost" <+> pretty (p,coo) <+> pretty h + liftIO $ atomically $ Q.writeTBQueue q (DownloadTask h Nothing) request @e p (BlockChunks @e coo (BlockGetAllChunks @e h chusz)) -- FIXME: nicer construction