mirror of https://github.com/voidlizard/hbs2
86 lines
2.2 KiB
Haskell
86 lines
2.2 KiB
Haskell
module PokePostponed where
|
|
|
|
import HBS2.Prelude.Plated
|
|
import HBS2.Clock
|
|
import HBS2.Actors.Peer
|
|
import HBS2.Net.Proto.Peer
|
|
import HBS2.Events
|
|
|
|
import HBS2.System.Logger.Simple
|
|
|
|
import PeerTypes
|
|
|
|
import Data.Foldable (for_)
|
|
import Control.Concurrent.Async
|
|
import Control.Concurrent.STM
|
|
import Control.Monad.Reader
|
|
import Data.Cache qualified as Cache
|
|
import Lens.Micro.Platform
|
|
import Numeric ( showGFloat )
|
|
import Prettyprinter
|
|
|
|
pokePostponed :: forall e m . ( MonadIO m
|
|
, EventListener e (PeerHandshake e) m
|
|
, MyPeer e
|
|
)
|
|
=> PeerEnv e
|
|
-> BlockDownloadM e m ()
|
|
|
|
pokePostponed penv = do
|
|
|
|
env <- ask
|
|
|
|
waitQ <- liftIO $ newTBQueueIO 1
|
|
|
|
busy <- liftIO $ newTVarIO False
|
|
|
|
cache <- asks (view blockPostponed)
|
|
|
|
lift $ subscribe @e AnyKnownPeerEventKey $ \(KnownPeerEvent{}) -> do
|
|
cant <- liftIO $ readTVarIO busy
|
|
unless cant $ do
|
|
debug "AnyKnownPeerEventKey"
|
|
mt <- liftIO $ atomically $ isEmptyTBQueue waitQ
|
|
when mt do
|
|
liftIO $ atomically $ writeTBQueue waitQ ()
|
|
|
|
forever do
|
|
-- FIXME: to defaults!
|
|
r <- liftIO $ race ( pause @'Seconds 60 ) ( atomically $ readTBQueue waitQ )
|
|
|
|
void $ liftIO $ atomically $ flushTBQueue waitQ
|
|
|
|
liftIO $ atomically $ writeTVar busy True
|
|
|
|
void $ liftIO $ async $ do
|
|
pause @'Seconds 30
|
|
atomically $ writeTVar busy False
|
|
|
|
let allBack = either (const False) (const True) r
|
|
|
|
blks <- liftIO $ Cache.toList cache
|
|
|
|
w <- calcWaitTime
|
|
|
|
debug $ "tossPostponed" <+> pretty (showGFloat (Just 2) w "")
|
|
<+> pretty (length blks)
|
|
|
|
for_ blks $ \case
|
|
(k,_,Nothing) | not allBack -> pure ()
|
|
| otherwise -> pushBack cache k
|
|
(k,_,Just{}) -> pushBack cache k
|
|
|
|
where
|
|
pushBack cache k = do
|
|
w <- calcWaitTime
|
|
liftIO $ Cache.delete cache k
|
|
st <- getBlockState k
|
|
t0 <- liftIO $ getTime MonotonicCoarse
|
|
setBlockState k ( set bsStart t0
|
|
. set bsState Initial
|
|
. set bsWipTo w
|
|
$ st
|
|
)
|
|
debug $ "returning block to downloads" <+> pretty k
|
|
addDownload k
|