mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

cleaned up AnnexState handling in transports

Browse source
This commit is contained in:
Joey Hess 2014-04-08 13:41:36 -04:00
parent b3b07ab330
commit fa0cf81b26
6 changed files with 95 additions and 42 deletions
Download patch file Download diff file Expand all files Collapse all files

33
RemoteDaemon/Transport/Ssh.hs
View file

@ -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)