mirror of https://github.com/voidlizard/hbs2
wip8
This commit is contained in:
voidlizard
parent
4941c5442c
commit
1012368cb5
|
|
@ -52,8 +52,13 @@ import Numeric
|
||||||
import UnliftIO
|
import UnliftIO
|
||||||
import Control.Concurrent.STM.TSem (TSem)
|
import Control.Concurrent.STM.TSem (TSem)
|
||||||
import Control.Concurrent.STM.TSem qualified as TSem
|
import Control.Concurrent.STM.TSem qualified as TSem
|
||||||
|
|
||||||
import UnliftIO.Concurrent
|
import UnliftIO.Concurrent
|
||||||
import UnliftIO.STM
|
import UnliftIO.STM
|
||||||
|
import UnliftIO.Exception as U
|
||||||
|
|
||||||
|
import Control.Exception qualified as E
|
||||||
|
|
||||||
import Lens.Micro.Platform
|
import Lens.Micro.Platform
|
||||||
import System.Random
|
import System.Random
|
||||||
import System.Random.Shuffle (shuffleM,shuffle')
|
import System.Random.Shuffle (shuffleM,shuffle')
|
||||||
|
|
@ -582,6 +587,13 @@ data DCB =
|
||||||
newDcbSTM :: TimeSpec -> Maybe HashRef -> STM DCB
|
newDcbSTM :: TimeSpec -> Maybe HashRef -> STM DCB
|
||||||
newDcbSTM ts parent = DCB ts parent <$> newTVar 0 <*> newTVar False
|
newDcbSTM ts parent = DCB ts parent <$> newTVar 0 <*> newTVar False
|
||||||
|
|
||||||
|
|
||||||
|
data DownloadSweepOnIdle =
|
||||||
|
DownloadSweepOnIdle
|
||||||
|
deriving stock (Show,Typeable)
|
||||||
|
|
||||||
|
instance Exception DownloadSweepOnIdle
|
||||||
|
|
||||||
data PSt =
|
data PSt =
|
||||||
PChoose
|
PChoose
|
||||||
| PInit HashRef DCB
|
| PInit HashRef DCB
|
||||||
|
|
@ -596,101 +608,121 @@ downloadDispatcher :: forall e m . ( e ~ L4Proto
|
||||||
-> SomeBrains e
|
-> SomeBrains e
|
||||||
-> PeerEnv e
|
-> PeerEnv e
|
||||||
-> m ()
|
-> m ()
|
||||||
downloadDispatcher probe brains env = flip runContT pure do
|
downloadDispatcher probe brains env = forever $ flip runContT pure do
|
||||||
|
|
||||||
|
debug $ red "downloadDispatcher spawned!"
|
||||||
|
|
||||||
pts <- newTVarIO ( mempty :: HashMap (Peer e) (Async (), PeerNonce) )
|
pts <- newTVarIO ( mempty :: HashMap (Peer e) (Async (), PeerNonce) )
|
||||||
|
|
||||||
wip <- newTVarIO ( mempty :: HashMap HashRef DCB )
|
wip <- newTVarIO ( mempty :: HashMap HashRef DCB )
|
||||||
parseQ <- newTQueueIO
|
parseQ <- newTQueueIO
|
||||||
|
|
||||||
let
|
let
|
||||||
onBlockSTM :: HashRef -> STM ()
|
onBlockSTM :: HashRef -> STM ()
|
||||||
onBlockSTM = writeTQueue parseQ
|
onBlockSTM = writeTQueue parseQ
|
||||||
|
|
||||||
insertNewDownloadSTM :: TimeSpec -> HashRef -> STM ()
|
insertNewDownloadSTM :: TimeSpec -> HashRef -> STM ()
|
||||||
insertNewDownloadSTM now ha = do
|
insertNewDownloadSTM now ha = do
|
||||||
already <- readTVar wip <&> HM.member ha
|
already <- readTVar wip <&> HM.member ha
|
||||||
unless already do
|
unless already do
|
||||||
dcb <- newDcbSTM now mzero
|
dcb <- newDcbSTM now mzero
|
||||||
modifyTVar wip (HM.insert ha dcb)
|
modifyTVar wip (HM.insert ha dcb)
|
||||||
|
|
||||||
insertNewDownload :: forall m1 . MonadIO m1 => HashRef -> m1 ()
|
insertNewDownload :: forall m1 . MonadIO m1 => HashRef -> m1 ()
|
||||||
insertNewDownload ha = do
|
insertNewDownload ha = do
|
||||||
now <- getTimeCoarse
|
now <- getTimeCoarse
|
||||||
atomically $ insertNewDownloadSTM now ha
|
atomically $ insertNewDownloadSTM now ha
|
||||||
newDownload @e brains ha
|
newDownload @e brains ha
|
||||||
|
|
||||||
void $ ContT $ withAsync $ manageThreads onBlockSTM wip pts
|
void $ ContT $ bracket none $ const do
|
||||||
|
readTVarIO pts <&> fmap fst . HM.elems >>= mapM_ cancel
|
||||||
|
|
||||||
sto <- withPeerM env getStorage
|
void $ ContT $ withAsync $ manageThreads onBlockSTM wip pts
|
||||||
|
|
||||||
liftIO $ withPeerM env do
|
sto <- withPeerM env getStorage
|
||||||
subscribe @e DownloadReqKey $ \(DownloadReqData h) -> do
|
|
||||||
here <- hasBlock sto h <&> isJust
|
|
||||||
unless here do
|
|
||||||
debug $ green "New download request" <+> pretty h
|
|
||||||
insertNewDownload (HashRef h)
|
|
||||||
|
|
||||||
dupes <- newTVarIO ( mempty :: HashMap HashRef Int )
|
liftIO $ withPeerM env do
|
||||||
|
subscribe @e DownloadReqKey $ \(DownloadReqData h) -> do
|
||||||
|
here <- hasBlock sto h <&> isJust
|
||||||
|
unless here do
|
||||||
|
debug $ green "New download request" <+> pretty h
|
||||||
|
insertNewDownload (HashRef h)
|
||||||
|
|
||||||
ContT $ withAsync $ forever $ pause @'Seconds 10 >> do
|
dupes <- newTVarIO ( mempty :: HashMap HashRef Int )
|
||||||
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
|
ContT $ withAsync $ forever $ pause @'Seconds 10 >> do
|
||||||
polling (Polling 10 10) (readTVarIO dupes <&> fmap (,60) . HM.keys) $ \h -> do
|
acceptReport probe =<< S.toList_ do
|
||||||
atomically $ modifyTVar dupes (HM.delete h)
|
wip <- readTVarIO wip <&> HM.size
|
||||||
|
pn <- readTVarIO pts <&> HM.size
|
||||||
|
S.yield ( "wip", fromIntegral wip )
|
||||||
|
S.yield ( "peerThreads", fromIntegral pn )
|
||||||
|
|
||||||
ContT $ withAsync do
|
ContT $ withAsync do
|
||||||
pause @'Seconds 10
|
polling (Polling 10 10) (readTVarIO dupes <&> fmap (,60) . HM.keys) $ \h -> do
|
||||||
forever $ (>> pause @'Seconds 60) $ do
|
atomically $ modifyTVar dupes (HM.delete h)
|
||||||
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
|
ContT $ withAsync do
|
||||||
debug "Sweep blocks"
|
pause @'Seconds 10
|
||||||
atomically do
|
forever $ (>> pause @'Seconds 60) $ do
|
||||||
total <- readTVar wip <&> HM.toList
|
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
|
||||||
|
|
||||||
alive <- for total $ \e@(h,DCB{..}) -> do
|
ContT $ withAsync $ forever $ (>> pause @'Seconds 30) do
|
||||||
down <- readTVar dcbDownloaded
|
debug "Sweep blocks"
|
||||||
if down then
|
atomically do
|
||||||
pure Nothing
|
total <- readTVar wip <&> HM.toList
|
||||||
else
|
|
||||||
pure (Just e)
|
|
||||||
|
|
||||||
writeTVar wip (HM.fromList (catMaybes alive))
|
alive <- for total $ \e@(h,DCB{..}) -> do
|
||||||
|
down <- readTVar dcbDownloaded
|
||||||
|
if down then
|
||||||
|
pure Nothing
|
||||||
|
else
|
||||||
|
pure (Just e)
|
||||||
|
|
||||||
ContT $ withAsync $ forever do
|
writeTVar wip (HM.fromList (catMaybes alive))
|
||||||
what <- atomically $ readTQueue parseQ
|
|
||||||
missed <- findMissedBlocks sto what
|
|
||||||
for_ missed insertNewDownload
|
|
||||||
|
|
||||||
forever $ (>> pause @'Seconds 10) do
|
ContT $ withAsync $ forever do
|
||||||
sw0 <- readTVarIO wip <&> HM.size
|
what <- atomically $ readTQueue parseQ
|
||||||
n <- countDownloads @e brains
|
missed <- findMissedBlocks sto what
|
||||||
debug $ yellow $ "wip" <+> pretty sw0 <+> parens (pretty n)
|
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
|
||||||
|
|
||||||
manageThreads :: (HashRef -> STM ())
|
-- manageThreads :: (HashRef -> STM ())
|
||||||
-> TVar (HashMap HashRef DCB)
|
-- -> TVar (HashMap HashRef DCB)
|
||||||
-> TVar (HashMap (Peer e) (Async (), PeerNonce))
|
-- -> TVar (HashMap (Peer e) (Async (), PeerNonce))
|
||||||
-> m ()
|
-- -> m ()
|
||||||
|
|
||||||
manageThreads onBlock wip pts = do
|
manageThreads onBlock wip pts = do
|
||||||
_pnum <- newTVarIO 1
|
_pnum <- newTVarIO 1
|
||||||
|
|
@ -711,7 +743,6 @@ downloadDispatcher probe brains env = flip runContT pure do
|
||||||
maybe1 mpd (pure ()) $
|
maybe1 mpd (pure ()) $
|
||||||
\PeerData{..} -> S.yield (p, _peerOwnNonce)
|
\PeerData{..} -> S.yield (p, _peerOwnNonce)
|
||||||
|
|
||||||
|
|
||||||
for_ (HM.toList peers) $ \(p,nonce) -> do
|
for_ (HM.toList peers) $ \(p,nonce) -> do
|
||||||
here <- readTVarIO pts <&> HM.member p
|
here <- readTVarIO pts <&> HM.member p
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue