mirror of https://github.com/voidlizard/hbs2
fetch lwwref
This commit is contained in:
parent
97521d4577
commit
2addbeb72d
|
@ -134,9 +134,10 @@ runGitCLI o m = do
|
|||
|
||||
void $ ContT $ withAsync $ runMessagingUnix client
|
||||
|
||||
peerAPI <- makeServiceCaller @PeerAPI (fromString soname)
|
||||
refLogAPI <- makeServiceCaller @RefLogAPI (fromString soname)
|
||||
peerAPI <- makeServiceCaller @PeerAPI (fromString soname)
|
||||
refLogAPI <- makeServiceCaller @RefLogAPI (fromString soname)
|
||||
storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
|
||||
lwwAPI <- makeServiceCaller @LWWRefAPI (fromString soname)
|
||||
|
||||
let endpoints = [ Endpoint @UNIX peerAPI
|
||||
, Endpoint @UNIX refLogAPI
|
||||
|
@ -158,7 +159,7 @@ runGitCLI o m = do
|
|||
|
||||
progress <- ContT $ withAsync (drawProgress q)
|
||||
|
||||
env <- lift $ newGitEnv ip o git cpath conf peerAPI refLogAPI storageAPI
|
||||
env <- lift $ newGitEnv ip o git cpath conf peerAPI refLogAPI lwwAPI storageAPI
|
||||
lift $ runReaderT setupLogging env
|
||||
lift $ withGitEnv env (evolveDB >> m)
|
||||
`finally` do
|
||||
|
|
|
@ -60,10 +60,11 @@ newGitEnv :: GitPerks m
|
|||
-> Config
|
||||
-> ServiceCaller PeerAPI UNIX
|
||||
-> ServiceCaller RefLogAPI UNIX
|
||||
-> ServiceCaller LWWRefAPI UNIX
|
||||
-> ServiceCaller StorageAPI UNIX
|
||||
-> m GitEnv
|
||||
|
||||
newGitEnv p opts path cpath conf peer reflog sto = do
|
||||
newGitEnv p opts path cpath conf peer reflog lww sto = do
|
||||
let dbfile = cpath </> "state.db"
|
||||
let dOpt = dbPipeOptsDef { dbLogger = \x -> debug ("state:" <+> pretty x) }
|
||||
db <- newDBPipeEnv dOpt dbfile
|
||||
|
@ -79,6 +80,7 @@ newGitEnv p opts path cpath conf peer reflog sto = do
|
|||
conf
|
||||
peer
|
||||
reflog
|
||||
lww
|
||||
(AnyStorage (StorageClient sto))
|
||||
db
|
||||
p
|
||||
|
|
|
@ -35,6 +35,7 @@ data GitEnv =
|
|||
, _config :: Config
|
||||
, _peerAPI :: ServiceCaller PeerAPI UNIX
|
||||
, _refLogAPI :: ServiceCaller RefLogAPI UNIX
|
||||
, _lwwRefAPI :: ServiceCaller LWWRefAPI UNIX
|
||||
, _storage :: AnyStorage -- ServiceCaller StorageAPI UNIX
|
||||
, _db :: DBPipeEnv
|
||||
, _progress :: AnyProgress
|
||||
|
|
|
@ -74,6 +74,10 @@ importRepoWait lwwKey = do
|
|||
|
||||
subscribeLWWRef lwwKey
|
||||
|
||||
-- void $ try @_ @SomeException (getRefLogMerkl puk)
|
||||
|
||||
fetchLWWRef lwwKey
|
||||
|
||||
flip fix (IWaitLWWBlock 20) $ \next -> \case
|
||||
|
||||
IWaitLWWBlock w | w <= 0 -> do
|
||||
|
@ -85,10 +89,12 @@ importRepoWait lwwKey = do
|
|||
|
||||
case lww of
|
||||
Nothing -> do
|
||||
pause @'Seconds 2
|
||||
pause @'Seconds 5
|
||||
fetchLWWRef lwwKey
|
||||
next (IWaitLWWBlock (pred w))
|
||||
|
||||
Just (LWWBlockData{..}) -> do
|
||||
void $ try @_ @SomeException (getRefLogMerkle lwwRefLogPubKey)
|
||||
next (IWaitRefLog 20 lwwRefLogPubKey)
|
||||
|
||||
IWaitRefLog w puk | w <= 0 -> do
|
||||
|
|
|
@ -16,6 +16,7 @@ module HBS2.Git.Client.Prelude
|
|||
, module HBS2.Net.Proto.Service
|
||||
, module HBS2.Peer.RPC.API.Peer
|
||||
, module HBS2.Peer.RPC.API.RefLog
|
||||
, module HBS2.Peer.RPC.API.LWWRef
|
||||
, module HBS2.Peer.RPC.API.Storage
|
||||
, module HBS2.Peer.RPC.Client.StorageClient
|
||||
|
||||
|
@ -53,6 +54,7 @@ import HBS2.Net.Proto.Service
|
|||
|
||||
import HBS2.Peer.RPC.API.Peer
|
||||
import HBS2.Peer.RPC.API.RefLog
|
||||
import HBS2.Peer.RPC.API.LWWRef
|
||||
import HBS2.Peer.RPC.API.Storage
|
||||
import HBS2.Peer.RPC.Client.StorageClient
|
||||
|
||||
|
|
|
@ -26,6 +26,12 @@ subscribeLWWRef puk = do
|
|||
api <- asks _peerAPI
|
||||
void $ callService @RpcPollAdd api (fromLwwRefKey puk, "lwwref", 17)
|
||||
|
||||
fetchLWWRef :: (GitPerks m, MonadReader GitEnv m) => LWWRefKey HBS2Basic -> m ()
|
||||
fetchLWWRef key = do
|
||||
api <- asks _lwwRefAPI
|
||||
void $ race (pause @'Seconds 1) (callService @RpcLWWRefFetch api key)
|
||||
|
||||
|
||||
getRefLogMerkle :: (GitPerks m, MonadReader GitEnv m) => RefLogId -> m (Maybe HashRef)
|
||||
getRefLogMerkle puk = do
|
||||
|
||||
|
|
Loading…
Reference in New Issue