diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index dc0cbe2f..c26b6549 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/hbs2-core/lib/HBS2/Actors/Peer.hs @@ -34,6 +34,8 @@ import Control.Concurrent.STM.TVar import Control.Concurrent.STM import Data.Hashable (hash) +import Codec.Serialise (serialise, deserialiseOrFail) + import Prettyprinter hiding (pipe) data AnyStorage = forall zu . (Block ByteString ~ ByteString, Storage zu HbSync ByteString IO) => AnyStorage zu @@ -46,7 +48,7 @@ instance (IsKey HbSync, Key HbSync ~ Hash HbSync, Block ByteString ~ ByteString) getChunk (AnyStorage s) = getChunk s hasBlock (AnyStorage s) = hasBlock s -data AnyMessage enc e = AnyMessage Integer (Encoded e) +data AnyMessage enc e = AnyMessage !Integer !(Encoded e) deriving stock (Generic) class Monad m => HasOwnPeer e m where @@ -70,9 +72,16 @@ instance Messaging (Fabriq e) e (AnyMessage (Encoded e) e) => PeerMessaging e instance (HasPeer e, Encoded e ~ ByteString) => Messaging (Fabriq e) e (AnyMessage ByteString e) where - sendTo (Fabriq bus) = undefined -- sendTo bus - receive (Fabriq bus) = undefined -- receive bus + sendTo (Fabriq bus) t f (AnyMessage n bs) = sendTo bus t f (serialise (n, bs)) + receive (Fabriq bus) t = do + recv <- receive @_ @e @ByteString bus t + r <- forM recv $ \(f, msg) -> + case deserialiseOrFail msg of + Right (n,bs) -> pure $ Just (f, AnyMessage n bs) + Left _ -> liftIO (print "FUCK!") >> pure Nothing -- FIXME what to do with undecoded messages? + + pure $ catMaybes r data AnyProtocol e m = forall p . ( HasProtocol e p , Response e p m diff --git a/hbs2-core/lib/HBS2/Defaults.hs b/hbs2-core/lib/HBS2/Defaults.hs index 64ed873b..0d4e4f37 100644 --- a/hbs2-core/lib/HBS2/Defaults.hs +++ b/hbs2-core/lib/HBS2/Defaults.hs @@ -30,14 +30,14 @@ defProtoPipelineSize :: Int defProtoPipelineSize = 2000 defCookieTimeout :: TimeSpec -defCookieTimeout = toTimeSpec ( 120 :: Timeout 'Minutes) +defCookieTimeout = toTimeSpec ( 300 :: Timeout 'Minutes) defBlockInfoTimeout :: TimeSpec -defBlockInfoTimeout = toTimeSpec ( 120 :: Timeout 'Minutes) +defBlockInfoTimeout = toTimeSpec ( 300 :: Timeout 'Minutes) -- how much time wait for block from peer? defBlockWaitMax :: Timeout 'Seconds -defBlockWaitMax = 60 :: Timeout 'Seconds +defBlockWaitMax = 300 :: Timeout 'Seconds defSweepTimeout :: Timeout 'Seconds defSweepTimeout = 5 -- FIXME: only for debug! diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs index 80d4fc9d..3980a242 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 ( 20 :: Timeout 'Seconds ) -- FIXME: setting + pause ( 30 :: Timeout 'Seconds ) -- FIXME: setting atomically $ do @@ -232,7 +232,7 @@ simpleGetChunkLazy s key off size = do let action = do let fn = simpleBlockFileName s key - bs <- (Just <$> touchForRead s key) `catchAny` const (pure Nothing) -- FIXME: log this situation (file not found) + bs <- (Just <$> touchForRead s key) `catchAny` \e -> liftIO (print "CANT MMAP") >> (pure Nothing) -- FIXME: log this situation (file not found) let result = BS.take (fromIntegral size) . BS.drop (fromIntegral off) <$> bs