blob: 557a3dce909625d7b2ef4f3f8d6a97cbb8c0d4cd (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
|
{- git-remote-daemon, git-annex-shell over ssh transport
-
- Copyright 2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module RemoteDaemon.Transport.Ssh (transport) where
import Common.Annex
import RemoteDaemon.Types
import RemoteDaemon.Common
import Remote.Helper.Ssh
import qualified RemoteDaemon.Transport.Ssh.Types as SshRemote
import Utility.SimpleProtocol
import Git.Command
import Control.Concurrent.Chan
import Control.Concurrent.Async
import System.Process (std_in, std_out)
transport :: Transport
transport r remotename transporthandle ichan ochan = do
v <- liftAnnex transporthandle $ git_annex_shell r "notifychanges" [] []
case v of
Nothing -> noop
Just (cmd, params) -> go cmd (toCommand params)
where
go cmd params = do
(Just toh, Just fromh, _, pid) <- createProcess (proc cmd params)
{ std_in = CreatePipe
, std_out = CreatePipe
}
let shutdown = do
hClose toh
hClose fromh
void $ waitForProcess pid
send DISCONNECTED
let fromshell = forever $ do
l <- hGetLine fromh
case parseMessage l of
Just SshRemote.READY -> send CONNECTED
Just (SshRemote.CHANGED shas) ->
whenM (checkNewShas transporthandle shas) $
fetch
Nothing -> shutdown
-- The only control message that matters is STOP.
--
-- Note that a CHANGED control message is not handled;
-- we don't push to the ssh remote. The assistant
-- and git-annex sync both handle pushes, so there's no
-- need to do it here.
let handlecontrol = forever $ do
msg <- readChan ichan
case msg of
STOP -> ioError (userError "done")
_ -> noop
-- Run both threads until one finishes.
void $ tryIO $ concurrently fromshell handlecontrol
shutdown
send msg = writeChan ochan (msg remotename)
fetch = do
send SYNCING
ok <- inLocalRepo transporthandle $
runBool [Param "fetch", Param remotename]
send (DONESYNCING ok)
|
