cleaned up AnnexState handling in transports
This commit is contained in:
parent
b3b07ab330
commit
fa0cf81b26
6 changed files with 95 additions and 42 deletions
|
@ -8,13 +8,11 @@
|
|||
module RemoteDaemon.Transport.Ssh (transport) where
|
||||
|
||||
import Common.Annex
|
||||
import qualified Annex
|
||||
import RemoteDaemon.Types
|
||||
import qualified RemoteDaemon.Transport.Ssh.Types as SshRemote
|
||||
import RemoteDaemon.Common
|
||||
import Remote.Helper.Ssh
|
||||
import qualified RemoteDaemon.Transport.Ssh.Types as SshRemote
|
||||
import Utility.SimpleProtocol
|
||||
import qualified Git
|
||||
import Annex.CatFile
|
||||
import Git.Command
|
||||
|
||||
import Control.Concurrent.Chan
|
||||
|
@ -22,13 +20,12 @@ import Control.Concurrent.Async
|
|||
import System.Process (std_in, std_out)
|
||||
|
||||
transport :: Transport
|
||||
transport r remotename annexstate ichan ochan = Annex.eval annexstate $ do
|
||||
v <- git_annex_shell r "notifychanges" [] []
|
||||
transport r remotename transporthandle ichan ochan = do
|
||||
v <- liftAnnex transporthandle $ git_annex_shell r "notifychanges" [] []
|
||||
case v of
|
||||
Nothing -> noop
|
||||
Just (cmd, params) -> liftIO $ go cmd (toCommand params)
|
||||
Just (cmd, params) -> go cmd (toCommand params)
|
||||
where
|
||||
send msg = writeChan ochan (msg remotename)
|
||||
go cmd params = do
|
||||
(Just toh, Just fromh, _, pid) <- createProcess (proc cmd params)
|
||||
{ std_in = CreatePipe
|
||||
|
@ -45,9 +42,9 @@ transport r remotename annexstate ichan ochan = Annex.eval annexstate $ do
|
|||
l <- hGetLine fromh
|
||||
case parseMessage l of
|
||||
Just SshRemote.READY -> send CONNECTED
|
||||
Just (SshRemote.CHANGED refs) ->
|
||||
Annex.eval annexstate $
|
||||
fetchNew remotename refs
|
||||
Just (SshRemote.CHANGED shas) ->
|
||||
whenM (checkNewShas transporthandle shas) $
|
||||
fetch
|
||||
Nothing -> shutdown
|
||||
|
||||
-- The only control message that matters is STOP.
|
||||
|
@ -66,10 +63,10 @@ transport r remotename annexstate ichan ochan = Annex.eval annexstate $ do
|
|||
void $ tryIO $ concurrently fromshell handlecontrol
|
||||
shutdown
|
||||
|
||||
-- Check if any of the shas are actally new, to avoid unnecessary fetching.
|
||||
fetchNew :: RemoteName -> [Git.Sha] -> Annex ()
|
||||
fetchNew remotename = check
|
||||
where
|
||||
check [] = void $ inRepo $ runBool [Param "fetch", Param remotename]
|
||||
check (r:rs) = maybe (check rs) (const noop)
|
||||
=<< catObjectDetails r
|
||||
send msg = writeChan ochan (msg remotename)
|
||||
|
||||
fetch = do
|
||||
send SYNCING
|
||||
ok <- inLocalRepo transporthandle $
|
||||
runBool [Param "fetch", Param remotename]
|
||||
send (DONESYNCING ok)
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue