mirror of https://github.com/voidlizard/hbs2
fixed-block-download-control
This commit is contained in:
parent
44ada95e3f
commit
98e589fe6f
|
@ -179,7 +179,7 @@ walkMerkle' root flookup sink = go root
|
||||||
|
|
||||||
bs0 <- lift $ flookup hash
|
bs0 <- lift $ flookup hash
|
||||||
|
|
||||||
bs <- MaybeT $ maybe1 bs0 (sink (Left hash) >> pure Nothing) (pure . Just)
|
bs <- MaybeT $ maybe1 bs0 (sink (Left hash) >> pure mzero) (pure . Just)
|
||||||
|
|
||||||
let t1 = deserialiseOrFail @(MTree a) bs
|
let t1 = deserialiseOrFail @(MTree a) bs
|
||||||
|
|
||||||
|
@ -188,7 +188,7 @@ walkMerkle' root flookup sink = go root
|
||||||
runWithAnnTree hash bs = do
|
runWithAnnTree hash bs = do
|
||||||
let t = deserialiseOrFail @(MTreeAnn a) bs
|
let t = deserialiseOrFail @(MTreeAnn a) bs
|
||||||
case t of
|
case t of
|
||||||
Left{} -> lift (sink (Left hash)) >> mzero
|
Left{} -> pure ()
|
||||||
Right (MTreeAnn { _mtaTree = t1 }) -> runWithTree t1
|
Right (MTreeAnn { _mtaTree = t1 }) -> runWithTree t1
|
||||||
|
|
||||||
runWithTree t = lift do
|
runWithTree t = lift do
|
||||||
|
|
|
@ -40,6 +40,9 @@ import Data.Text qualified as Text
|
||||||
import Data.Hashable
|
import Data.Hashable
|
||||||
import Prettyprinter
|
import Prettyprinter
|
||||||
import Data.Word
|
import Data.Word
|
||||||
|
import GHC.Generics
|
||||||
|
import Data.Time.Clock (NominalDiffTime(..))
|
||||||
|
import Codec.Serialise
|
||||||
|
|
||||||
none :: forall m . Monad m => m ()
|
none :: forall m . Monad m => m ()
|
||||||
none = pure ()
|
none = pure ()
|
||||||
|
@ -50,8 +53,10 @@ maybe1 mb n j = maybe n j mb
|
||||||
eitherToMaybe :: Either a b -> Maybe b
|
eitherToMaybe :: Either a b -> Maybe b
|
||||||
eitherToMaybe = either (const Nothing) Just
|
eitherToMaybe = either (const Nothing) Just
|
||||||
|
|
||||||
newtype AsFileName a = AsFileName a
|
-- deriving instance Generic NominalDiffTime
|
||||||
|
-- instance Serialise NominalDiffTime
|
||||||
|
|
||||||
|
newtype AsFileName a = AsFileName a
|
||||||
|
|
||||||
instance Pretty a => Pretty (AsFileName a) where
|
instance Pretty a => Pretty (AsFileName a) where
|
||||||
pretty (AsFileName f) = pretty x <> "@" <> uniq
|
pretty (AsFileName f) = pretty x <> "@" <> uniq
|
||||||
|
|
|
@ -9,7 +9,7 @@ module HBS2.Prelude.Plated
|
||||||
import Data.Data
|
import Data.Data
|
||||||
import Data.Generics.Uniplate.Data()
|
import Data.Generics.Uniplate.Data()
|
||||||
import Data.Generics.Uniplate.Operations
|
import Data.Generics.Uniplate.Operations
|
||||||
import GHC.Generics(Generic)
|
import GHC.Generics()
|
||||||
import Safe
|
import Safe
|
||||||
|
|
||||||
import HBS2.Prelude
|
import HBS2.Prelude
|
||||||
|
@ -25,3 +25,5 @@ uniFirstMay = headMay . universeBi
|
||||||
|
|
||||||
uniFirstDef :: forall from to . (Data from, Data to) => to -> from -> to
|
uniFirstDef :: forall from to . (Data from, Data to) => to -> from -> to
|
||||||
uniFirstDef d = headDef d . universeBi
|
uniFirstDef d = headDef d . universeBi
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -20,6 +20,7 @@ import HBS2.Net.Proto.RefLog
|
||||||
import HBS2.Net.Proto.Sessions
|
import HBS2.Net.Proto.Sessions
|
||||||
import HBS2.Prelude.Plated
|
import HBS2.Prelude.Plated
|
||||||
import HBS2.Storage
|
import HBS2.Storage
|
||||||
|
import HBS2.Storage.Operations.Missed
|
||||||
import HBS2.System.Logger.Simple
|
import HBS2.System.Logger.Simple
|
||||||
|
|
||||||
import PeerTypes
|
import PeerTypes
|
||||||
|
@ -143,7 +144,7 @@ processBlock h = do
|
||||||
Just (SeqRef (SequentialRef n (AnnotatedHashRef a' b))) -> do
|
Just (SeqRef (SequentialRef n (AnnotatedHashRef a' b))) -> do
|
||||||
maybe1 a' none $ \a -> do
|
maybe1 a' none $ \a -> do
|
||||||
debug $ "GOT AnnotatedHashRef" <+> pretty a
|
debug $ "GOT AnnotatedHashRef" <+> pretty a
|
||||||
addDownload parent (fromHashRef a)
|
processBlock (fromHashRef a)
|
||||||
|
|
||||||
addDownload parent (fromHashRef b)
|
addDownload parent (fromHashRef b)
|
||||||
|
|
||||||
|
|
|
@ -1,3 +1,4 @@
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
{-# Language AllowAmbiguousTypes #-}
|
{-# Language AllowAmbiguousTypes #-}
|
||||||
{-# Language UndecidableInstances #-}
|
{-# Language UndecidableInstances #-}
|
||||||
{-# Language TemplateHaskell #-}
|
{-# Language TemplateHaskell #-}
|
||||||
|
@ -10,6 +11,7 @@ module Brains
|
||||||
import HBS2.Prelude.Plated
|
import HBS2.Prelude.Plated
|
||||||
import HBS2.Clock
|
import HBS2.Clock
|
||||||
import HBS2.Net.Proto.RefChan(ForRefChans)
|
import HBS2.Net.Proto.RefChan(ForRefChans)
|
||||||
|
import HBS2.Data.Types.Refs
|
||||||
import HBS2.Net.Proto
|
import HBS2.Net.Proto
|
||||||
import HBS2.Hash
|
import HBS2.Hash
|
||||||
import HBS2.Base58
|
import HBS2.Base58
|
||||||
|
@ -20,13 +22,14 @@ import HBS2.System.Logger.Simple
|
||||||
|
|
||||||
import PeerConfig
|
import PeerConfig
|
||||||
|
|
||||||
import Crypto.Saltine.Core.Box qualified as Encrypt
|
import Control.Concurrent.STM
|
||||||
|
import Control.Exception
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Control.Exception
|
import Crypto.Saltine.Core.Box qualified as Encrypt
|
||||||
import Control.Concurrent.STM
|
|
||||||
import Database.SQLite.Simple
|
import Database.SQLite.Simple
|
||||||
import Database.SQLite.Simple.FromField
|
import Database.SQLite.Simple.FromField
|
||||||
|
import Database.SQLite.Simple.ToField
|
||||||
import Data.Cache (Cache)
|
import Data.Cache (Cache)
|
||||||
import Data.Cache qualified as Cache
|
import Data.Cache qualified as Cache
|
||||||
import Data.Either
|
import Data.Either
|
||||||
|
@ -35,6 +38,7 @@ import Data.HashMap.Strict qualified as HashMap
|
||||||
import Data.List qualified as List
|
import Data.List qualified as List
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Text qualified as Text
|
import Data.Text qualified as Text
|
||||||
|
import Data.Time.Clock (UTCTime)
|
||||||
import Data.Word
|
import Data.Word
|
||||||
import Lens.Micro.Platform
|
import Lens.Micro.Platform
|
||||||
import System.Directory
|
import System.Directory
|
||||||
|
@ -45,6 +49,16 @@ import UnliftIO (MonadUnliftIO(..),async,race)
|
||||||
|
|
||||||
data PeerBrainsDb
|
data PeerBrainsDb
|
||||||
|
|
||||||
|
|
||||||
|
-- FIXME: move-that-orphans-somewhere
|
||||||
|
|
||||||
|
instance ToField HashRef where
|
||||||
|
toField h = toField (show $ pretty h)
|
||||||
|
|
||||||
|
instance FromField HashRef where
|
||||||
|
fromField = fmap fromString . fromField @String
|
||||||
|
|
||||||
|
|
||||||
instance Monad m => HasCfgKey PeerBrainsDb (Maybe String) m where
|
instance Monad m => HasCfgKey PeerBrainsDb (Maybe String) m where
|
||||||
key = "brains"
|
key = "brains"
|
||||||
|
|
||||||
|
@ -90,6 +104,10 @@ instance ( Hashable (Peer e)
|
||||||
|
|
||||||
listTCPPexCandidates = liftIO . selectTCPPexCandidates
|
listTCPPexCandidates = liftIO . selectTCPPexCandidates
|
||||||
|
|
||||||
|
listDownloads = liftIO . selectDownloads
|
||||||
|
|
||||||
|
delDownload br what = updateOP br (deleteDownload br what)
|
||||||
|
|
||||||
onKnownPeers br ps = do
|
onKnownPeers br ps = do
|
||||||
trace $ "BRAINS: onKnownPeers" <+> pretty ps
|
trace $ "BRAINS: onKnownPeers" <+> pretty ps
|
||||||
let tv = view brainsPeers br
|
let tv = view brainsPeers br
|
||||||
|
@ -118,19 +136,27 @@ instance ( Hashable (Peer e)
|
||||||
liftIO $ Cache.insert cache h ()
|
liftIO $ Cache.insert cache h ()
|
||||||
let doAlter = HashMap.alter (maybe (Just 0) (Just . succ)) (peer,h)
|
let doAlter = HashMap.alter (maybe (Just 0) (Just . succ)) (peer,h)
|
||||||
liftIO $ atomically $ modifyTVar (view brainsPostponeDown b) doAlter
|
liftIO $ atomically $ modifyTVar (view brainsPostponeDown b) doAlter
|
||||||
|
-- updateOP b $ insertDownload b
|
||||||
|
|
||||||
onBlockDownloaded b p h = do
|
onBlockDownloaded b p h = do
|
||||||
-- trace $ "BRAINS: onBlockDownloaded" <+> pretty p <+> pretty h
|
-- trace $ "BRAINS: onBlockDownloaded" <+> pretty p <+> pretty h
|
||||||
cleanupPostponed b h
|
cleanupPostponed b h
|
||||||
updateOP b $ insertPeer b h p
|
updateOP b do
|
||||||
|
insertPeer b h p
|
||||||
|
|
||||||
onBlockPostponed b h = do
|
onBlockPostponed b h = do
|
||||||
-- trace $ "BRAINS: onBlockPostponed" <+> pretty h
|
-- trace $ "BRAINS: onBlockPostponed" <+> pretty h
|
||||||
cleanupPostponed b h
|
cleanupPostponed b h
|
||||||
|
|
||||||
claimBlockCameFrom b f t = do
|
claimBlockCameFrom b (Just f) t = do
|
||||||
-- trace $ "BRAINS: claimBlockCameFrom" <+> pretty f <+> pretty t
|
-- trace $ "BRAINS: claimBlockCameFrom" <+> pretty f <+> pretty t
|
||||||
updateOP b $ insertAncestor b f t
|
updateOP b do
|
||||||
|
insertAncestor b f t
|
||||||
|
insertDownload b (Just $ HashRef f) (HashRef t)
|
||||||
|
|
||||||
|
claimBlockCameFrom b p h = do
|
||||||
|
updateOP b do
|
||||||
|
insertDownload b (HashRef <$> p) (HashRef h)
|
||||||
|
|
||||||
shouldPostponeBlock b h = do
|
shouldPostponeBlock b h = do
|
||||||
peers <- liftIO $ readTVarIO (view brainsPeers b)
|
peers <- liftIO $ readTVarIO (view brainsPeers b)
|
||||||
|
@ -587,6 +613,42 @@ deletePeerAsymmKey' br key =
|
||||||
WHERE peer = ?
|
WHERE peer = ?
|
||||||
|] (Only key)
|
|] (Only key)
|
||||||
|
|
||||||
|
|
||||||
|
insertDownload :: forall e . ( e ~ L4Proto)
|
||||||
|
=> BasicBrains e
|
||||||
|
-> Maybe HashRef
|
||||||
|
-> HashRef
|
||||||
|
-> IO ()
|
||||||
|
insertDownload br parent hash = do
|
||||||
|
let conn = view brainsDb br
|
||||||
|
liftIO $ execute conn [qc|
|
||||||
|
insert into statedb.download (hash, parent)
|
||||||
|
values (?, ?)
|
||||||
|
on conflict (hash) do update set parent = excluded.parent
|
||||||
|
|] (hash, parent)
|
||||||
|
|
||||||
|
|
||||||
|
deleteDownload :: forall e . (e ~ L4Proto)
|
||||||
|
=> BasicBrains e
|
||||||
|
-> HashRef
|
||||||
|
-> IO ()
|
||||||
|
deleteDownload br hash = do
|
||||||
|
let conn = view brainsDb br
|
||||||
|
liftIO $ execute conn [qc|
|
||||||
|
delete from statedb.download where hash = ?
|
||||||
|
|] (Only hash)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
selectDownloads :: forall e . (e ~ L4Proto)
|
||||||
|
=> BasicBrains e
|
||||||
|
-> IO [(HashRef, Integer)]
|
||||||
|
selectDownloads br = do
|
||||||
|
let conn = view brainsDb br
|
||||||
|
liftIO $ query_ conn [qc|
|
||||||
|
select hash, ts from statedb.download
|
||||||
|
|]
|
||||||
|
|
||||||
---
|
---
|
||||||
|
|
||||||
-- FIXME: eventually-close-db
|
-- FIXME: eventually-close-db
|
||||||
|
@ -619,6 +681,14 @@ newBasicBrains cfg = liftIO do
|
||||||
create table if not exists statedb.processed ( hash text not null primary key );
|
create table if not exists statedb.processed ( hash text not null primary key );
|
||||||
|]
|
|]
|
||||||
|
|
||||||
|
execute_ conn [qc|
|
||||||
|
create table if not exists statedb.download
|
||||||
|
( hash text not null primary key
|
||||||
|
, parent text null
|
||||||
|
, ts INTEGER DEFAULT (strftime('%s','now'))
|
||||||
|
);
|
||||||
|
|]
|
||||||
|
|
||||||
execute_ conn [qc|
|
execute_ conn [qc|
|
||||||
create table if not exists ancestors
|
create table if not exists ancestors
|
||||||
( child text not null
|
( child text not null
|
||||||
|
|
|
@ -111,7 +111,6 @@ checkBlockAnnounce conf denv nonce pa h = void $ runMaybeT do
|
||||||
guard accept
|
guard accept
|
||||||
|
|
||||||
lift do
|
lift do
|
||||||
downloadLogAppend @e h
|
|
||||||
withDownload denv $ do
|
withDownload denv $ do
|
||||||
processBlock h
|
processBlock h
|
||||||
|
|
||||||
|
|
|
@ -3,128 +3,53 @@ module DownloadQ where
|
||||||
|
|
||||||
import HBS2.Prelude
|
import HBS2.Prelude
|
||||||
import HBS2.Clock
|
import HBS2.Clock
|
||||||
import HBS2.Hash
|
|
||||||
import HBS2.Events
|
import HBS2.Events
|
||||||
import HBS2.Data.Types.Refs
|
import HBS2.Data.Types.Refs
|
||||||
import HBS2.Actors.Peer
|
|
||||||
import HBS2.Net.PeerLocator
|
import HBS2.Net.PeerLocator
|
||||||
|
import HBS2.Peer.Brains
|
||||||
import HBS2.Storage
|
import HBS2.Storage
|
||||||
import HBS2.Merkle
|
import HBS2.Storage.Operations.Missed
|
||||||
import HBS2.System.Logger.Simple
|
import HBS2.System.Logger.Simple
|
||||||
|
|
||||||
import PeerTypes
|
import PeerTypes
|
||||||
import PeerConfig
|
import PeerConfig
|
||||||
import BlockDownload (processBlock)
|
|
||||||
|
|
||||||
import Data.Map qualified as Map
|
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
import Control.Concurrent.STM
|
|
||||||
import Control.Concurrent.STM.TSem
|
|
||||||
import Data.ByteString.Char8 qualified as B8
|
|
||||||
import Data.List (nub)
|
|
||||||
import Data.Maybe
|
|
||||||
import Control.Exception
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Reader
|
import Lens.Micro.Platform
|
||||||
import Control.Concurrent.Async
|
|
||||||
|
|
||||||
|
|
||||||
downloadLogAppend :: forall e m . ( MonadIO m
|
|
||||||
, EventEmitter e (DownloadReq e) m
|
|
||||||
, DownloadFromPeerStuff e m
|
|
||||||
) => Hash HbSync -> m ()
|
|
||||||
downloadLogAppend h = do
|
|
||||||
emit @e DownloadReqKey (DownloadReqData h)
|
|
||||||
|
|
||||||
noLogFile :: MonadIO m => m ()
|
|
||||||
noLogFile = err "download log not defined"
|
|
||||||
|
|
||||||
downloadQueue :: forall e m . ( MyPeer e
|
downloadQueue :: forall e m . ( MyPeer e
|
||||||
, DownloadFromPeerStuff e m
|
, DownloadFromPeerStuff e m
|
||||||
, HasPeerLocator e (BlockDownloadM e m)
|
, HasPeerLocator e (BlockDownloadM e m)
|
||||||
, HasPeerLocator e m
|
, HasPeerLocator e m
|
||||||
, EventListener e (DownloadReq e) m
|
, EventListener e (DownloadReq e) m
|
||||||
) => PeerConfig -> DownloadEnv e -> m ()
|
, HasStorage m
|
||||||
|
) => PeerConfig
|
||||||
|
-> SomeBrains e
|
||||||
|
-> DownloadEnv e -> m ()
|
||||||
|
|
||||||
downloadQueue (PeerConfig syn) denv = do
|
downloadQueue _ brains denv = do
|
||||||
|
debug "DownloadQ started"
|
||||||
|
|
||||||
|
down <- listDownloads @e brains
|
||||||
sto <- getStorage
|
sto <- getStorage
|
||||||
hq <- liftIO newTQueueIO
|
|
||||||
fsem <- liftIO $ atomically $ newTSem 1
|
|
||||||
|
|
||||||
pause @'Seconds 2
|
withDownload denv do
|
||||||
|
forM_ down $ \(HashRef h,_) -> do
|
||||||
|
missed <- findMissedBlocks sto (HashRef h)
|
||||||
|
for_ missed $ \h -> do
|
||||||
|
debug $ "DownloadQ:" <+> pretty h
|
||||||
|
addDownload mzero (fromHashRef h)
|
||||||
|
|
||||||
let qfile' = runReader (cfgValue @PeerDownloadLogKey) syn
|
-- FIXME: timeout-hardcodes
|
||||||
|
let refs = listDownloads @e brains <&> fmap (set _2 10)
|
||||||
|
|
||||||
subscribe @e DownloadReqKey $ \(DownloadReqData h) -> do
|
polling (Polling 5 10) refs $ \ref -> do
|
||||||
liftIO $ atomically $ writeTQueue hq h
|
missed <- findMissedBlocks sto ref
|
||||||
|
|
||||||
maybe1 qfile' noLogFile $ \fn -> do
|
debug $ "DownloadQ. check" <+> pretty ref <+> pretty (length missed)
|
||||||
void $ liftIO $ async $ forever $ do
|
|
||||||
pause @'Seconds 10
|
|
||||||
fromq <- liftIO $ atomically $ flushTQueue hq
|
|
||||||
unless (null fromq) do
|
|
||||||
atomically $ waitTSem fsem
|
|
||||||
catchAny ( B8.appendFile fn ( B8.unlines (fmap (B8.pack.show.pretty) fromq) ) )
|
|
||||||
whimper
|
|
||||||
atomically $ signalTSem fsem
|
|
||||||
|
|
||||||
maybe1 qfile' noLogFile $ \fn -> forever do
|
when (null missed) do
|
||||||
|
delDownload @e brains ref
|
||||||
debug $ "downloadQueue" <+> pretty fn
|
|
||||||
|
|
||||||
lo <- liftIO do
|
|
||||||
|
|
||||||
-- FIXME: will-crash-on-big-logs
|
|
||||||
atomically $ waitTSem fsem
|
|
||||||
r <- catchAny (B8.readFile fn) (\e -> whimper e >> pure "")
|
|
||||||
atomically $ signalTSem fsem
|
|
||||||
|
|
||||||
let hashes = B8.lines r & mapMaybe (fromStringMay . B8.unpack) & nub :: [Hash HbSync]
|
|
||||||
|
|
||||||
fromq <- liftIO $ atomically $ flushTQueue hq
|
|
||||||
let hashesWip = nub ( hashes <> fromq )
|
|
||||||
|
|
||||||
errnum <- newTQueueIO
|
|
||||||
|
|
||||||
let walk h = walkMerkle h (getBlock sto) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do
|
|
||||||
case hr of
|
|
||||||
Left{} -> atomically $ writeTQueue errnum (h,True)
|
|
||||||
Right (hrr :: [HashRef]) -> do
|
|
||||||
forM_ hrr $ \(HashRef hx) -> do
|
|
||||||
mblk <- hasBlock sto hx
|
|
||||||
case mblk of
|
|
||||||
Nothing -> atomically $ writeTQueue errnum (h,True)
|
|
||||||
_ -> pure ()
|
|
||||||
|
|
||||||
for_ hashesWip walk
|
|
||||||
|
|
||||||
loosers <- atomically $ flushTQueue errnum <&> Map.fromListWith (||) <&> Map.filter id
|
|
||||||
|
|
||||||
-- debug $ vcat (fmap pretty (Map.toList loosers))
|
|
||||||
|
|
||||||
let leftovers = [ x | x <- hashesWip , Map.member x loosers ]
|
|
||||||
|
|
||||||
|
|
||||||
atomically $ waitTSem fsem
|
|
||||||
catchAny ( B8.writeFile fn ( B8.unlines (fmap (B8.pack.show.pretty) leftovers) ) )
|
|
||||||
whimper
|
|
||||||
atomically $ signalTSem fsem
|
|
||||||
|
|
||||||
pure leftovers
|
|
||||||
|
|
||||||
for_ lo $ withDownload denv . processBlock
|
|
||||||
|
|
||||||
debug "downloadQueue okay"
|
|
||||||
|
|
||||||
-- TODO: remove-downloadQueue-pause-hardcode
|
|
||||||
pause @'Seconds 150
|
|
||||||
-- FIXME: only-debug-20-sec
|
|
||||||
|
|
||||||
where
|
|
||||||
whimper e = err (pretty $ show e)
|
|
||||||
|
|
||||||
catchAny :: IO a -> (SomeException -> IO a) -> IO a
|
|
||||||
catchAny = Control.Exception.catch
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -3,14 +3,16 @@ module Fetch where
|
||||||
import HBS2.Prelude
|
import HBS2.Prelude
|
||||||
import HBS2.Actors.Peer
|
import HBS2.Actors.Peer
|
||||||
import HBS2.Data.Types.Refs
|
import HBS2.Data.Types.Refs
|
||||||
|
import HBS2.Storage.Operations.Missed
|
||||||
import HBS2.Net.Proto.Types
|
import HBS2.Net.Proto.Types
|
||||||
|
|
||||||
import HBS2.System.Logger.Simple
|
import HBS2.System.Logger.Simple
|
||||||
|
|
||||||
import PeerTypes
|
import PeerTypes
|
||||||
import DownloadQ
|
|
||||||
import BlockDownload
|
import BlockDownload
|
||||||
|
|
||||||
|
import Data.Foldable (for_)
|
||||||
|
|
||||||
fetchHash :: forall e m . (e ~ L4Proto, MonadIO m)
|
fetchHash :: forall e m . (e ~ L4Proto, MonadIO m)
|
||||||
=> PeerEnv e
|
=> PeerEnv e
|
||||||
-> DownloadEnv e
|
-> DownloadEnv e
|
||||||
|
@ -20,8 +22,11 @@ fetchHash :: forall e m . (e ~ L4Proto, MonadIO m)
|
||||||
fetchHash penv denv href = do
|
fetchHash penv denv href = do
|
||||||
debug $ "fetchAction" <+> pretty h
|
debug $ "fetchAction" <+> pretty h
|
||||||
liftIO $ withPeerM penv $ do
|
liftIO $ withPeerM penv $ do
|
||||||
downloadLogAppend @e h
|
sto <- getStorage
|
||||||
withDownload denv (processBlock h)
|
missed <- findMissedBlocks sto href
|
||||||
|
for_ missed $ \miss -> do
|
||||||
|
withDownload denv (processBlock (fromHashRef miss))
|
||||||
|
|
||||||
where
|
where
|
||||||
h = fromHashRef href
|
h = fromHashRef href
|
||||||
|
|
||||||
|
|
|
@ -87,24 +87,28 @@ import Crypto.Saltine (sodiumInit)
|
||||||
import Data.ByteString.Lazy qualified as LBS
|
import Data.ByteString.Lazy qualified as LBS
|
||||||
import Data.ByteString qualified as BS
|
import Data.ByteString qualified as BS
|
||||||
import Data.Cache qualified as Cache
|
import Data.Cache qualified as Cache
|
||||||
|
import Data.HashSet qualified as HashSet
|
||||||
import Data.List qualified as L
|
import Data.List qualified as L
|
||||||
import Data.Map (Map)
|
import Data.Map (Map)
|
||||||
import Data.Map qualified as Map
|
import Data.Map qualified as Map
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Set qualified as Set
|
import Data.Set qualified as Set
|
||||||
import Data.Set (Set)
|
import Data.Set (Set)
|
||||||
import Data.HashSet qualified as HashSet
|
import Data.Time.Clock (UTCTime, NominalDiffTime, diffUTCTime, getCurrentTime)
|
||||||
|
import Data.Time.Clock.POSIX
|
||||||
|
import Data.Time.LocalTime
|
||||||
|
import Data.Time.Format
|
||||||
import Lens.Micro.Platform as Lens
|
import Lens.Micro.Platform as Lens
|
||||||
import Network.Socket
|
import Network.Socket
|
||||||
import Options.Applicative
|
import Options.Applicative
|
||||||
|
import Prettyprinter.Render.Terminal
|
||||||
import System.Directory
|
import System.Directory
|
||||||
|
import System.Environment
|
||||||
import System.Exit
|
import System.Exit
|
||||||
import System.IO
|
import System.IO
|
||||||
import System.Mem
|
import System.Mem
|
||||||
import System.Metrics
|
import System.Metrics
|
||||||
import System.Posix.Process
|
import System.Posix.Process
|
||||||
import System.Environment
|
|
||||||
import Prettyprinter.Render.Terminal
|
|
||||||
|
|
||||||
import UnliftIO.Exception qualified as U
|
import UnliftIO.Exception qualified as U
|
||||||
-- import UnliftIO.STM
|
-- import UnliftIO.STM
|
||||||
|
@ -226,6 +230,7 @@ runCLI = do
|
||||||
<> command "refchan" (info pRefChan (progDesc "refchan commands"))
|
<> command "refchan" (info pRefChan (progDesc "refchan commands"))
|
||||||
<> command "peers" (info pPeers (progDesc "show known peers"))
|
<> command "peers" (info pPeers (progDesc "show known peers"))
|
||||||
<> command "pexinfo" (info pPexInfo (progDesc "show pex"))
|
<> command "pexinfo" (info pPexInfo (progDesc "show pex"))
|
||||||
|
<> command "download" (info pDownload (progDesc "download management"))
|
||||||
<> command "poll" (info pPoll (progDesc "polling management"))
|
<> command "poll" (info pPoll (progDesc "polling management"))
|
||||||
<> command "log" (info pLog (progDesc "set logging level"))
|
<> command "log" (info pLog (progDesc "set logging level"))
|
||||||
-- FIXME: bring-back-dialogue-over-separate-socket
|
-- FIXME: bring-back-dialogue-over-separate-socket
|
||||||
|
@ -435,9 +440,39 @@ runCLI = do
|
||||||
<+> pretty what
|
<+> pretty what
|
||||||
<> line
|
<> line
|
||||||
|
|
||||||
|
|
||||||
|
pDownload = hsubparser ( command "list" (info pDownList (progDesc "list current downloads" ))
|
||||||
|
<> command "del" (info pDownDel (progDesc "delete download" ))
|
||||||
|
)
|
||||||
|
|
||||||
|
pDownDel = do
|
||||||
|
rpc <- pRpcCommon
|
||||||
|
href <- argument hashP ( metavar "HASH-REF")
|
||||||
|
pure $ withMyRPC @PeerAPI rpc $ \caller -> do
|
||||||
|
void $ runMaybeT do
|
||||||
|
toMPlus =<< callService @RpcDownloadDel caller href
|
||||||
|
|
||||||
|
pDownList = do
|
||||||
|
rpc <- pRpcCommon
|
||||||
|
pure $ withMyRPC @PeerAPI rpc $ \caller -> do
|
||||||
|
void $ runMaybeT do
|
||||||
|
-- now <- getU
|
||||||
|
d <- toMPlus =<< callService @RpcDownloadList caller ()
|
||||||
|
now <- liftIO getPOSIXTime
|
||||||
|
liftIO $ print $ vcat (fmap (fmt now) d)
|
||||||
|
pure ()
|
||||||
|
|
||||||
|
where
|
||||||
|
fmt now (h,u) = pretty (AsBase58 h) <+> pretty diff
|
||||||
|
where
|
||||||
|
delta = now - fromIntegral u
|
||||||
|
diff = formatTime defaultTimeLocale "%d:%H:%M:%S" delta
|
||||||
|
|
||||||
refP :: ReadM (PubKey 'Sign HBS2Basic)
|
refP :: ReadM (PubKey 'Sign HBS2Basic)
|
||||||
refP = maybeReader fromStringMay
|
refP = maybeReader fromStringMay
|
||||||
|
|
||||||
|
hashP :: ReadM HashRef
|
||||||
|
hashP = maybeReader fromStringMay
|
||||||
|
|
||||||
myException :: SomeException -> IO ()
|
myException :: SomeException -> IO ()
|
||||||
myException e = err ( show e )
|
myException e = err ( show e )
|
||||||
|
@ -924,10 +959,11 @@ runPeer opts = U.handle (\e -> myException e
|
||||||
|
|
||||||
peerThread "blockDownloadLoop" (blockDownloadLoop denv)
|
peerThread "blockDownloadLoop" (blockDownloadLoop denv)
|
||||||
|
|
||||||
|
peerThread "blockDownloadQ" (downloadQueue conf (SomeBrains brains) denv)
|
||||||
|
|
||||||
peerThread "encryptionHandshakeWorker"
|
peerThread "encryptionHandshakeWorker"
|
||||||
(EncryptionKeys.encryptionHandshakeWorker @e conf pc encryptionHshakeAdapter)
|
(EncryptionKeys.encryptionHandshakeWorker @e conf pc encryptionHshakeAdapter)
|
||||||
|
|
||||||
|
|
||||||
peerThread "fillPeerMeta" (fillPeerMeta tcp tcpProbeWait)
|
peerThread "fillPeerMeta" (fillPeerMeta tcp tcpProbeWait)
|
||||||
|
|
||||||
-- FIXME: clumsy-code
|
-- FIXME: clumsy-code
|
||||||
|
@ -937,7 +973,6 @@ runPeer opts = U.handle (\e -> myException e
|
||||||
|
|
||||||
peerThread "postponedLoop" (postponedLoop denv)
|
peerThread "postponedLoop" (postponedLoop denv)
|
||||||
|
|
||||||
peerThread "downloadQueue" (downloadQueue conf denv)
|
|
||||||
|
|
||||||
peerThread "reflogWorker" (reflogWorker @e conf (SomeBrains brains) rwa)
|
peerThread "reflogWorker" (reflogWorker @e conf (SomeBrains brains) rwa)
|
||||||
|
|
||||||
|
|
|
@ -309,7 +309,7 @@ addDownload mbh h = do
|
||||||
if here then do
|
if here then do
|
||||||
removeFromWip h
|
removeFromWip h
|
||||||
else do
|
else do
|
||||||
maybe1 mbh none $ \hp -> claimBlockCameFrom @e brains hp h
|
claimBlockCameFrom @e brains mbh h
|
||||||
liftIO $ atomically $ modifyTVar tinq $ HashMap.insert h ()
|
liftIO $ atomically $ modifyTVar tinq $ HashMap.insert h ()
|
||||||
|
|
||||||
postponedNum :: forall e m . (MyPeer e, MonadIO m) => BlockDownloadM e m Int
|
postponedNum :: forall e m . (MyPeer e, MonadIO m) => BlockDownloadM e m Int
|
||||||
|
|
|
@ -0,0 +1,27 @@
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
{-# Language UndecidableInstances #-}
|
||||||
|
module RPC2.Downloads where
|
||||||
|
|
||||||
|
import HBS2.Prelude.Plated
|
||||||
|
import HBS2.Net.Proto.Service
|
||||||
|
import HBS2.Peer.Brains
|
||||||
|
import HBS2.System.Logger.Simple
|
||||||
|
import HBS2.Net.Proto.Definition()
|
||||||
|
|
||||||
|
import HBS2.Peer.RPC.API.Peer
|
||||||
|
import HBS2.Peer.RPC.Internal.Types
|
||||||
|
|
||||||
|
instance (MonadIO m, HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcDownloadList where
|
||||||
|
|
||||||
|
handleMethod _ = do
|
||||||
|
brains <- getRpcContext @PeerAPI <&> rpcBrains
|
||||||
|
debug $ "rpc.downloadList"
|
||||||
|
listDownloads @L4Proto brains
|
||||||
|
|
||||||
|
instance (MonadIO m, HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcDownloadDel where
|
||||||
|
|
||||||
|
handleMethod href = do
|
||||||
|
brains <- getRpcContext @PeerAPI <&> rpcBrains
|
||||||
|
debug $ "rpc.downloadDel" <+> pretty href
|
||||||
|
delDownload @L4Proto brains href
|
||||||
|
|
|
@ -16,4 +16,5 @@ import RPC2.RefChan()
|
||||||
import RPC2.Die()
|
import RPC2.Die()
|
||||||
import RPC2.LogLevel()
|
import RPC2.LogLevel()
|
||||||
import RPC2.Poll()
|
import RPC2.Poll()
|
||||||
|
import RPC2.Downloads()
|
||||||
|
|
||||||
|
|
|
@ -180,6 +180,7 @@ executable hbs2-peer
|
||||||
, RPC2.PexInfo
|
, RPC2.PexInfo
|
||||||
, RPC2.Ping
|
, RPC2.Ping
|
||||||
, RPC2.Poll
|
, RPC2.Poll
|
||||||
|
, RPC2.Downloads
|
||||||
, RPC2.RefLog
|
, RPC2.RefLog
|
||||||
, RPC2.RefChan
|
, RPC2.RefChan
|
||||||
, PeerTypes
|
, PeerTypes
|
||||||
|
|
|
@ -8,6 +8,7 @@ import HBS2.Net.Proto
|
||||||
import HBS2.Hash
|
import HBS2.Hash
|
||||||
|
|
||||||
import Data.Word
|
import Data.Word
|
||||||
|
import HBS2.Data.Types.Refs (HashRef(..))
|
||||||
|
|
||||||
-- TODO: rename
|
-- TODO: rename
|
||||||
class HasBrains e a where
|
class HasBrains e a where
|
||||||
|
@ -42,6 +43,12 @@ class HasBrains e a where
|
||||||
listTCPPexCandidates :: MonadIO m => a -> m [PeerAddr e]
|
listTCPPexCandidates :: MonadIO m => a -> m [PeerAddr e]
|
||||||
listTCPPexCandidates _ = pure mempty
|
listTCPPexCandidates _ = pure mempty
|
||||||
|
|
||||||
|
listDownloads :: MonadIO m => a -> m [(HashRef, Integer)]
|
||||||
|
listDownloads _ = pure mempty
|
||||||
|
|
||||||
|
delDownload :: MonadIO m => a -> HashRef -> m ()
|
||||||
|
delDownload _ _ = pure ()
|
||||||
|
|
||||||
onKnownPeers :: MonadIO m => a -> [Peer e] -> m ()
|
onKnownPeers :: MonadIO m => a -> [Peer e] -> m ()
|
||||||
onKnownPeers _ _ = none
|
onKnownPeers _ _ = none
|
||||||
|
|
||||||
|
@ -82,7 +89,7 @@ class HasBrains e a where
|
||||||
|
|
||||||
claimBlockCameFrom :: MonadIO m
|
claimBlockCameFrom :: MonadIO m
|
||||||
=> a
|
=> a
|
||||||
-> Hash HbSync
|
-> Maybe (Hash HbSync)
|
||||||
-> Hash HbSync
|
-> Hash HbSync
|
||||||
-> m ()
|
-> m ()
|
||||||
|
|
||||||
|
@ -146,6 +153,10 @@ instance HasBrains e (SomeBrains e) where
|
||||||
getClientTCP (SomeBrains a) = getClientTCP @e a
|
getClientTCP (SomeBrains a) = getClientTCP @e a
|
||||||
setActiveTCPSessions (SomeBrains a) = setActiveTCPSessions @e a
|
setActiveTCPSessions (SomeBrains a) = setActiveTCPSessions @e a
|
||||||
listTCPPexCandidates (SomeBrains a) = listTCPPexCandidates @e a
|
listTCPPexCandidates (SomeBrains a) = listTCPPexCandidates @e a
|
||||||
|
|
||||||
|
listDownloads (SomeBrains a) = listDownloads @e a
|
||||||
|
delDownload (SomeBrains a) = delDownload @e a
|
||||||
|
|
||||||
onKnownPeers (SomeBrains a) = onKnownPeers a
|
onKnownPeers (SomeBrains a) = onKnownPeers a
|
||||||
onBlockSize (SomeBrains a) = onBlockSize a
|
onBlockSize (SomeBrains a) = onBlockSize a
|
||||||
onBlockDownloadAttempt (SomeBrains a) = onBlockDownloadAttempt a
|
onBlockDownloadAttempt (SomeBrains a) = onBlockDownloadAttempt a
|
||||||
|
|
|
@ -9,6 +9,7 @@ import HBS2.Actors.Peer
|
||||||
|
|
||||||
import HBS2.Peer.RPC.Internal.Types
|
import HBS2.Peer.RPC.Internal.Types
|
||||||
|
|
||||||
|
import Data.Time.Clock.POSIX (POSIXTime)
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Data.ByteString.Lazy (ByteString)
|
import Data.ByteString.Lazy (ByteString)
|
||||||
import Codec.Serialise
|
import Codec.Serialise
|
||||||
|
@ -26,6 +27,9 @@ data RpcPollList
|
||||||
data RpcPollAdd
|
data RpcPollAdd
|
||||||
data RpcPollDel
|
data RpcPollDel
|
||||||
|
|
||||||
|
data RpcDownloadList
|
||||||
|
data RpcDownloadDel
|
||||||
|
|
||||||
type PeerAPI = '[ RpcPoke
|
type PeerAPI = '[ RpcPoke
|
||||||
, RpcPing
|
, RpcPing
|
||||||
, RpcAnnounce
|
, RpcAnnounce
|
||||||
|
@ -37,6 +41,8 @@ type PeerAPI = '[ RpcPoke
|
||||||
, RpcPollList
|
, RpcPollList
|
||||||
, RpcPollAdd
|
, RpcPollAdd
|
||||||
, RpcPollDel
|
, RpcPollDel
|
||||||
|
, RpcDownloadList
|
||||||
|
, RpcDownloadDel
|
||||||
]
|
]
|
||||||
|
|
||||||
instance HasProtocol UNIX (ServiceProto PeerAPI UNIX) where
|
instance HasProtocol UNIX (ServiceProto PeerAPI UNIX) where
|
||||||
|
@ -74,6 +80,12 @@ type instance Output RpcFetch = ()
|
||||||
type instance Input RpcPollList= ()
|
type instance Input RpcPollList= ()
|
||||||
type instance Output RpcPollList = [(PubKey 'Sign HBS2Basic, String, Int)]
|
type instance Output RpcPollList = [(PubKey 'Sign HBS2Basic, String, Int)]
|
||||||
|
|
||||||
|
type instance Input RpcDownloadList = ()
|
||||||
|
type instance Output RpcDownloadList = [(HashRef, Integer)]
|
||||||
|
|
||||||
|
type instance Input RpcDownloadDel = HashRef
|
||||||
|
type instance Output RpcDownloadDel = ()
|
||||||
|
|
||||||
type instance Input RpcPollAdd = (PubKey 'Sign HBS2Basic, String, Int)
|
type instance Input RpcPollAdd = (PubKey 'Sign HBS2Basic, String, Int)
|
||||||
type instance Output RpcPollAdd = ()
|
type instance Output RpcPollAdd = ()
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue