blob: b67b0e07f1e4d9eb98d7a7da8ad70cc02665eda6 (
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
73
74
75
76
77
78
79
80
|
{- git-annex assistant communication with remotedaemon
-
- Copyright 2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Threads.RemoteControl where
import Assistant.Common
import RemoteDaemon.Types
import Config.Files
import Utility.Batch
import Utility.SimpleProtocol
import Assistant.Alert
import Assistant.Alert.Utility
import Assistant.DaemonStatus
import Control.Concurrent
import Control.Concurrent.Async
import System.Process (std_in, std_out)
import qualified Data.Map as M
remoteControlThread :: NamedThread
remoteControlThread = namedThread "RemoteControl" $ do
program <- liftIO readProgramFile
(cmd, params) <- liftIO $ toBatchCommand
(program, [Param "remotedaemon"])
let p = proc cmd (toCommand params)
(Just toh, Just fromh, _, pid) <- liftIO $ createProcess p
{ std_in = CreatePipe
, std_out = CreatePipe
}
controller <- asIO $ remoteControllerThread toh
responder <- asIO $ remoteResponderThread fromh
-- run controller and responder until the remotedaemon dies
liftIO $ do
void $ controller `concurrently` responder
forceSuccessProcess p pid
-- feed from the remoteControl channel into the remotedaemon
remoteControllerThread :: Handle -> Assistant ()
remoteControllerThread toh = do
clicker <- getAssistant remoteControl
liftIO $ forever $ do
msg <- readChan clicker
hPutStrLn toh $ unwords $ formatMessage msg
hFlush toh
-- read status messages emitted by the remotedaemon and handle them
remoteResponderThread :: Handle -> Assistant ()
remoteResponderThread fromh = go M.empty
where
go syncalerts = do
l <- liftIO $ hGetLine fromh
case parseMessage l of
Just (CONNECTED _rn) -> do
go syncalerts
Just (DISCONNECTED _rn) -> do
go syncalerts
Just (SYNCING rn)
| M.member rn syncalerts -> go syncalerts
| otherwise -> do
i <- addAlert $ syncAlert' [rn]
go (M.insert rn i syncalerts)
Just (DONESYNCING status rn) ->
case M.lookup rn syncalerts of
Nothing -> go syncalerts
Just i -> do
let (succeeded, failed) = if status
then ([rn], [])
else ([], [rn])
updateAlertMap $ mergeAlert i $
syncResultAlert' succeeded failed
go (M.delete rn syncalerts)
Nothing -> do
debug ["protocol error from remotedaemon: ", l]
go syncalerts
|
