voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
Dmitry Zuikov 2023-01-18 06:21:00 +03:00
parent d76aef7eca
commit 85ad732cfc
1 changed files with 30 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
hbs2-tests/test/Main.hs
View File

@ -12,7 +12,7 @@ import HBS2.Storage.Simple.Extra
import HBS2.Actors import HBS2.Actors
-- import Test.Tasty hiding (Timeout) -- import Test.Tasty hiding (Timeout)
-- import Test.Tasty.HUnit hiding (Timeout) import Test.Tasty.HUnit hiding (Timeout)
import Lens.Micro.Platform import Lens.Micro.Platform
import Data.Traversable import Data.Traversable
@ -26,6 +26,7 @@ import System.IO
import Data.ByteString.Lazy.Char8 qualified as B8 import Data.ByteString.Lazy.Char8 qualified as B8
import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy (ByteString)
import Codec.Serialise import Codec.Serialise
import System.Exit
data Fake data Fake
@ -57,17 +58,23 @@ instance HasProtocol Fake (BlockSize Fake) where
decode = either (const Nothing) Just . deserialiseOrFail decode = either (const Nothing) Just . deserialiseOrFail
encode = serialise encode = serialise
type HasBlockEvent h e m = (Peer e, Hash h, Maybe Integer) -> m ()
type GetBlockSize h m = Hash h -> m (Maybe Integer)
blockSizeHandler :: forall e m s . ( MonadIO m dontHandle :: Applicative f => a -> f ()
dontHandle = const $ pure ()
blockSizeProto :: forall e m . ( MonadIO m
, Response e (BlockSize e) m , Response e (BlockSize e) m
, s ~ SimpleStorage HbSync
) )
=> s => GetBlockSize HbSync m
-> HasBlockEvent HbSync e m
-> BlockSize e -> BlockSize e
-> m () -> m ()
blockSizeHandler s = blockSizeProto getBlockSize evHasBlock =
\case \case
GetBlockSize h -> do GetBlockSize h -> do
debug $ "GetBlockSize" <+> pretty h debug $ "GetBlockSize" <+> pretty h
@ -76,14 +83,18 @@ blockSizeHandler s =
-- TODO: defer answer (?) -- TODO: defer answer (?)
-- TODO: does it really work? -- TODO: does it really work?
deferred (Proxy @(BlockSize e))$ do deferred (Proxy @(BlockSize e))$ do
hasBlock s h >>= \case getBlockSize h >>= \case
Just size -> response (BlockSize @e h size) Just size -> response (BlockSize @e h size)
Nothing -> response (NoBlock @e h) Nothing -> response (NoBlock @e h)
-- deferred (Proxy @(BlockSize e)) $ do -- deferred (Proxy @(BlockSize e)) $ do
NoBlock h -> debug $ "NoBlock" <+> pretty h NoBlock h -> do
evHasBlock ( undefined, h, Nothing )
debug $ "NoBlock" <+> pretty h
BlockSize h sz -> debug $ "BlockSize" <+> pretty h <+> pretty sz BlockSize h sz -> do
evHasBlock ( undefined, h, Just sz )
debug $ "BlockSize" <+> pretty h <+> pretty sz
main :: IO () main :: IO ()
main = do main = do
@ -126,7 +137,7 @@ runFakePeer env = do
simpleStorageStop storage simpleStorageStop storage
runPeer env runPeer env
[ makeResponse (blockSizeHandler storage) [ makeResponse (blockSizeProto (hasBlock storage) dontHandle)
] ]
cancel w cancel w
@ -153,14 +164,16 @@ test1 = do
request p1 (GetBlockSize @Fake (fromString "81JeD7LNR6Q7RYfyWBxfjJn1RsWzvegkUXae6FUNgrMZ")) request p1 (GetBlockSize @Fake (fromString "81JeD7LNR6Q7RYfyWBxfjJn1RsWzvegkUXae6FUNgrMZ"))
request p1 (GetBlockSize @Fake (fromString "5KP4vM6RuEX6RA1ywthBMqZV5UJDLANC17UrF6zuWdRt")) request p1 (GetBlockSize @Fake (fromString "5KP4vM6RuEX6RA1ywthBMqZV5UJDLANC17UrF6zuWdRt"))
pause ( 0.1 :: Timeout 'Seconds) pause ( 0.5 :: Timeout 'Seconds)
mapM_ wait peerz mapM_ cancel peerz
(_, e) <- waitAnyCatchCancel peerz (_, e) <- waitAnyCatchCancel peerz
debug (pretty $ show e) debug (pretty $ show e)
debug "we're done" debug "we're done"
assertBool "sucess" True
exitSuccess
assertBool "failed" False