mirror of https://github.com/voidlizard/hbs2
wip12
This commit is contained in:
voidlizard
parent
bd3395f775
commit
a7aae31cac
|
|
@ -10,6 +10,6 @@ constraints:
|
||||||
, http-client >=0.7.16 && <0.8
|
, http-client >=0.7.16 && <0.8
|
||||||
|
|
||||||
-- executable-static: True
|
-- executable-static: True
|
||||||
profiling: True
|
-- profiling: True
|
||||||
--library-profiling: False
|
--library-profiling: False
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -608,12 +608,10 @@ downloadDispatcher :: forall e m . ( e ~ L4Proto
|
||||||
-> SomeBrains e
|
-> SomeBrains e
|
||||||
-> PeerEnv e
|
-> PeerEnv e
|
||||||
-> m ()
|
-> m ()
|
||||||
downloadDispatcher probe brains env = forever $ flip runContT pure do
|
downloadDispatcher probe brains env = do
|
||||||
|
|
||||||
debug $ red "downloadDispatcher spawned!"
|
debug $ red "downloadDispatcher spawned!"
|
||||||
|
|
||||||
pts <- newTVarIO ( mempty :: HashMap (Peer e) (Async (), PeerNonce) )
|
sto <- withPeerM env getStorage
|
||||||
|
|
||||||
wip <- newTVarIO ( mempty :: HashMap HashRef DCB )
|
wip <- newTVarIO ( mempty :: HashMap HashRef DCB )
|
||||||
parseQ <- newTQueueIO
|
parseQ <- newTQueueIO
|
||||||
|
|
||||||
|
|
@ -634,13 +632,6 @@ downloadDispatcher probe brains env = forever $ flip runContT pure do
|
||||||
atomically $ insertNewDownloadSTM now ha
|
atomically $ insertNewDownloadSTM now ha
|
||||||
newDownload @e brains ha
|
newDownload @e brains ha
|
||||||
|
|
||||||
void $ ContT $ bracket none $ const do
|
|
||||||
readTVarIO pts <&> fmap fst . HM.elems >>= mapM_ cancel
|
|
||||||
|
|
||||||
void $ ContT $ withAsync $ manageThreads onBlockSTM wip pts
|
|
||||||
|
|
||||||
sto <- withPeerM env getStorage
|
|
||||||
|
|
||||||
liftIO $ withPeerM env do
|
liftIO $ withPeerM env do
|
||||||
subscribe @e DownloadReqKey $ \(DownloadReqData h) -> do
|
subscribe @e DownloadReqKey $ \(DownloadReqData h) -> do
|
||||||
here <- hasBlock sto h <&> isJust
|
here <- hasBlock sto h <&> isJust
|
||||||
|
|
@ -648,74 +639,83 @@ downloadDispatcher probe brains env = forever $ flip runContT pure do
|
||||||
debug $ green "New download request" <+> pretty h
|
debug $ green "New download request" <+> pretty h
|
||||||
insertNewDownload (HashRef h)
|
insertNewDownload (HashRef h)
|
||||||
|
|
||||||
dupes <- newTVarIO ( mempty :: HashMap HashRef Int )
|
forever $ flip runContT pure do
|
||||||
|
|
||||||
ContT $ withAsync $ forever $ pause @'Seconds 10 >> do
|
pts <- newTVarIO ( mempty :: HashMap (Peer e) (Async (), PeerNonce) )
|
||||||
acceptReport probe =<< S.toList_ do
|
|
||||||
wip <- readTVarIO wip <&> HM.size
|
|
||||||
pn <- readTVarIO pts <&> HM.size
|
|
||||||
S.yield ( "wip", fromIntegral wip )
|
|
||||||
S.yield ( "peerThreads", fromIntegral pn )
|
|
||||||
|
|
||||||
ContT $ withAsync do
|
void $ ContT $ bracket none $ const do
|
||||||
polling (Polling 10 10) (readTVarIO dupes <&> fmap (,60) . HM.keys) $ \h -> do
|
readTVarIO pts <&> fmap fst . HM.elems >>= mapM_ cancel
|
||||||
atomically $ modifyTVar dupes (HM.delete h)
|
|
||||||
|
|
||||||
ContT $ withAsync do
|
void $ ContT $ withAsync $ manageThreads onBlockSTM wip pts
|
||||||
pause @'Seconds 10
|
|
||||||
forever $ (>> pause @'Seconds 60) $ do
|
|
||||||
down <- listDownloads @e brains
|
|
||||||
for down \(h,_) -> do
|
|
||||||
already <- readTVarIO wip <&> HM.member h
|
|
||||||
checked <- readTVarIO dupes <&> HM.member h
|
|
||||||
unless checked do
|
|
||||||
here <- hasBlock sto (coerce h) <&> isJust
|
|
||||||
when here do
|
|
||||||
atomically $ modifyTVar dupes (HM.insertWith (+) h 1)
|
|
||||||
delDownload @e brains h
|
|
||||||
unless already do
|
|
||||||
missed <- findMissedBlocks sto h
|
|
||||||
for_ missed insertNewDownload
|
|
||||||
|
|
||||||
ContT $ withAsync $ forever $ (>> pause @'Seconds 30) do
|
dupes <- newTVarIO ( mempty :: HashMap HashRef Int )
|
||||||
debug "Sweep blocks"
|
|
||||||
atomically do
|
|
||||||
total <- readTVar wip <&> HM.toList
|
|
||||||
|
|
||||||
alive <- for total $ \e@(h,DCB{..}) -> do
|
ContT $ withAsync $ forever $ pause @'Seconds 10 >> do
|
||||||
down <- readTVar dcbDownloaded
|
acceptReport probe =<< S.toList_ do
|
||||||
if down then
|
wip <- readTVarIO wip <&> HM.size
|
||||||
pure Nothing
|
pn <- readTVarIO pts <&> HM.size
|
||||||
else
|
S.yield ( "wip", fromIntegral wip )
|
||||||
pure (Just e)
|
S.yield ( "peerThreads", fromIntegral pn )
|
||||||
|
|
||||||
writeTVar wip (HM.fromList (catMaybes alive))
|
ContT $ withAsync do
|
||||||
|
polling (Polling 10 10) (readTVarIO dupes <&> fmap (,60) . HM.keys) $ \h -> do
|
||||||
|
atomically $ modifyTVar dupes (HM.delete h)
|
||||||
|
|
||||||
ContT $ withAsync $ forever do
|
ContT $ withAsync do
|
||||||
what <- atomically $ readTQueue parseQ
|
pause @'Seconds 10
|
||||||
missed <- findMissedBlocks sto what
|
forever $ (>> pause @'Seconds 60) $ do
|
||||||
for_ missed insertNewDownload
|
down <- listDownloads @e brains
|
||||||
|
for down \(h,_) -> do
|
||||||
|
already <- readTVarIO wip <&> HM.member h
|
||||||
|
checked <- readTVarIO dupes <&> HM.member h
|
||||||
|
unless checked do
|
||||||
|
here <- hasBlock sto (coerce h) <&> isJust
|
||||||
|
when here do
|
||||||
|
atomically $ modifyTVar dupes (HM.insertWith (+) h 1)
|
||||||
|
delDownload @e brains h
|
||||||
|
unless already do
|
||||||
|
missed <- findMissedBlocks sto h
|
||||||
|
for_ missed insertNewDownload
|
||||||
|
|
||||||
idle <- ContT $ withAsync $ do
|
ContT $ withAsync $ forever $ (>> pause @'Seconds 30) do
|
||||||
t0 <- getTimeCoarse
|
debug "Sweep blocks"
|
||||||
flip fix t0 $ \next ti -> do
|
atomically do
|
||||||
num <- readTVarIO wip <&> HM.size
|
total <- readTVar wip <&> HM.toList
|
||||||
t1 <- getTimeCoarse
|
|
||||||
if num /= 0 then do
|
|
||||||
pause @Seconds 5 >> next t1
|
|
||||||
else do
|
|
||||||
let idle = expired (TimeoutSec 600) (t1 - ti)
|
|
||||||
-- debug $ blue "EXPIRED" <+> pretty (idle,t1,ti)
|
|
||||||
when idle $ throwIO DownloadSweepOnIdle
|
|
||||||
pause @Seconds 5
|
|
||||||
next t0
|
|
||||||
|
|
||||||
ContT $ withAsync $ forever $ (>> pause @'Seconds 10) do
|
alive <- for total $ \e@(h,DCB{..}) -> do
|
||||||
sw0 <- readTVarIO wip <&> HM.size
|
down <- readTVar dcbDownloaded
|
||||||
n <- countDownloads @e brains
|
if down then
|
||||||
debug $ yellow $ "wip" <+> pretty sw0 <+> parens (pretty n)
|
pure Nothing
|
||||||
|
else
|
||||||
|
pure (Just e)
|
||||||
|
|
||||||
void $ waitCatch idle
|
writeTVar wip (HM.fromList (catMaybes alive))
|
||||||
|
|
||||||
|
ContT $ withAsync $ forever do
|
||||||
|
what <- atomically $ readTQueue parseQ
|
||||||
|
missed <- findMissedBlocks sto what
|
||||||
|
for_ missed insertNewDownload
|
||||||
|
|
||||||
|
idle <- ContT $ withAsync $ do
|
||||||
|
t0 <- getTimeCoarse
|
||||||
|
flip fix t0 $ \next ti -> do
|
||||||
|
num <- readTVarIO wip <&> HM.size
|
||||||
|
t1 <- getTimeCoarse
|
||||||
|
if num /= 0 then do
|
||||||
|
pause @Seconds 5 >> next t1
|
||||||
|
else do
|
||||||
|
let idle = expired (TimeoutSec 600) (t1 - ti)
|
||||||
|
-- debug $ blue "EXPIRED" <+> pretty (idle,t1,ti)
|
||||||
|
when idle $ throwIO DownloadSweepOnIdle
|
||||||
|
pause @Seconds 5
|
||||||
|
next t0
|
||||||
|
|
||||||
|
ContT $ withAsync $ forever $ (>> pause @'Seconds 10) do
|
||||||
|
sw0 <- readTVarIO wip <&> HM.size
|
||||||
|
n <- countDownloads @e brains
|
||||||
|
debug $ yellow $ "wip" <+> pretty sw0 <+> parens (pretty n)
|
||||||
|
|
||||||
|
void $ waitCatch idle
|
||||||
|
|
||||||
where
|
where
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue