1{- git-annex remote access with ssh and git-annex-shell
2 -
3 - Copyright 2011-2018 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8module Remote.Helper.Ssh where
9
10import Annex.Common
11import qualified Annex
12import qualified Git
13import qualified Git.Url
14import Annex.UUID
15import Annex.Ssh
16import CmdLine.GitAnnexShell.Fields (Field, fieldName)
17import qualified CmdLine.GitAnnexShell.Fields as Fields
18import Remote.Helper.Messages
19import Utility.Metered
20import Utility.Rsync
21import Utility.SshHost
22import Types.Remote
23import Types.Transfer
24import Config
25import qualified P2P.Protocol as P2P
26import qualified P2P.IO as P2P
27import qualified P2P.Annex as P2P
28
29import Control.Concurrent.STM
30import Control.Concurrent.Async
31
32toRepo :: ConsumeStdin -> Git.Repo -> RemoteGitConfig -> SshCommand -> Annex (FilePath, [CommandParam])
33toRepo cs r gc remotecmd = do
34	let host = maybe
35		(giveup "bad ssh url")
36		(either error id . mkSshHost)
37		(Git.Url.hostuser r)
38	sshCommand cs (host, Git.Url.port r) gc remotecmd
39
40{- Generates parameters to run a git-annex-shell command on a remote
41 - repository. -}
42git_annex_shell :: ConsumeStdin -> Git.Repo -> String -> [CommandParam] -> [(Field, String)] -> Annex (Maybe (FilePath, [CommandParam]))
43git_annex_shell cs r command params fields
44	| not $ Git.repoIsUrl r = do
45		shellopts <- getshellopts
46		return $ Just (shellcmd, shellopts ++ fieldopts)
47	| Git.repoIsSsh r = do
48		gc <- Annex.getRemoteGitConfig r
49		u <- getRepoUUID r
50		shellopts <- getshellopts
51		let sshcmd = unwords $
52			fromMaybe shellcmd (remoteAnnexShell gc)
53				: map shellEscape (toCommand shellopts) ++
54			uuidcheck u ++
55			map shellEscape (toCommand fieldopts)
56		Just <$> toRepo cs r gc sshcmd
57	| otherwise = return Nothing
58  where
59	dir = Git.repoPath r
60	shellcmd = "git-annex-shell"
61	getshellopts = do
62		debugenabled <- Annex.getRead Annex.debugenabled
63		let params' = if debugenabled
64			then Param "--debug" : params
65			else params
66		return (Param command : File (fromRawFilePath dir) : params')
67	uuidcheck NoUUID = []
68	uuidcheck u@(UUID _) = ["--uuid", fromUUID u]
69	fieldopts
70		| null fields = []
71		| otherwise = fieldsep : map fieldopt fields ++ [fieldsep]
72	fieldsep = Param "--"
73	fieldopt (field, value) = Param $
74		fieldName field ++ "=" ++ value
75
76{- Uses a supplied function (such as boolSystem) to run a git-annex-shell
77 - command on a remote.
78 -
79 - Or, if the remote does not support running remote commands, returns
80 - a specified error value. -}
81onRemote
82	:: ConsumeStdin
83	-> Git.Repo
84	-> (FilePath -> [CommandParam] -> Annex a, Annex a)
85	-> String
86	-> [CommandParam]
87	-> [(Field, String)]
88	-> Annex a
89onRemote cs r (with, errorval) command params fields = do
90	s <- git_annex_shell cs r command params fields
91	case s of
92		Just (c, ps) -> with c ps
93		Nothing -> errorval
94
95{- Checks if a remote contains a key. -}
96inAnnex :: Git.Repo -> Key -> Annex Bool
97inAnnex r k = onRemote NoConsumeStdin r (runcheck, cantCheck r) "inannex"
98	[Param $ serializeKey k] []
99  where
100	runcheck c p = liftIO $ dispatch =<< safeSystem c p
101	dispatch ExitSuccess = return True
102	dispatch (ExitFailure 1) = return False
103	dispatch _ = cantCheck r
104
105{- Removes a key from a remote. -}
106dropKey :: Git.Repo -> Key -> Annex ()
107dropKey r key = unlessM (dropKey' r key) $
108	giveup "unable to remove key from remote"
109
110dropKey' :: Git.Repo -> Key -> Annex Bool
111dropKey' r key = onRemote NoConsumeStdin r (\f p -> liftIO (boolSystem f p), return False) "dropkey"
112	[ Param "--quiet", Param "--force"
113	, Param $ serializeKey key
114	]
115	[]
116
117rsyncHelper :: OutputHandler -> Maybe MeterUpdate -> [CommandParam] -> Annex Bool
118rsyncHelper oh m params = do
119	unless (quietMode oh) $
120		showOutput -- make way for progress bar
121	a <- case m of
122		Nothing -> return $ rsync params
123		Just meter -> return $ rsyncProgress oh meter params
124	ifM (liftIO a)
125		( return True
126		, do
127			showLongNote "rsync failed -- run git annex again to resume file transfer"
128			return False
129		)
130
131{- Generates rsync parameters that ssh to the remote and asks it
132 - to either receive or send the key's content. -}
133rsyncParamsRemote :: Bool -> Remote -> Direction -> Key -> FilePath -> AssociatedFile -> Annex [CommandParam]
134rsyncParamsRemote unlocked r direction key file (AssociatedFile afile) = do
135	u <- getUUID
136	let fields = (Fields.remoteUUID, fromUUID u)
137		: (Fields.unlocked, if unlocked then "1" else "")
138		-- Send direct field for unlocked content, for backwards
139		-- compatability.
140		: (Fields.direct, if unlocked then "1" else "")
141		: maybe [] (\f -> [(Fields.associatedFile, fromRawFilePath f)]) afile
142	repo <- getRepo r
143	Just (shellcmd, shellparams) <- git_annex_shell ConsumeStdin repo
144		(if direction == Download then "sendkey" else "recvkey")
145		[ Param $ serializeKey key ]
146		fields
147	-- Convert the ssh command into rsync command line.
148	let eparam = rsyncShell (Param shellcmd:shellparams)
149	o <- rsyncParams r direction
150	return $ if direction == Download
151		then o ++ rsyncopts eparam dummy (File file)
152		else o ++ rsyncopts eparam (File file) dummy
153  where
154	rsyncopts ps source dest
155		| end ps == [dashdash] = ps ++ [source, dest]
156		| otherwise = ps ++ [dashdash, source, dest]
157	dashdash = Param "--"
158	{- The rsync shell parameter controls where rsync
159	 - goes, so the source/dest parameter can be a dummy value,
160	 - that just enables remote rsync mode.
161	 - For maximum compatability with some patched rsyncs,
162	 - the dummy value needs to still contain a hostname,
163	 - even though this hostname will never be used. -}
164	dummy = Param "dummy:"
165
166-- --inplace to resume partial files
167--
168-- Only use --perms when not on a crippled file system, as rsync
169-- will fail trying to restore file perms onto a filesystem that does not
170-- support them.
171rsyncParams :: Remote -> Direction -> Annex [CommandParam]
172rsyncParams r direction = do
173	crippled <- crippledFileSystem
174	return $ map Param $ catMaybes
175		[ Just "--progress"
176		, Just "--inplace"
177		, if crippled then Nothing else Just "--perms"
178		]
179		++ remoteAnnexRsyncOptions gc ++ dps
180  where
181	dps
182		| direction == Download = remoteAnnexRsyncDownloadOptions gc
183		| otherwise = remoteAnnexRsyncUploadOptions gc
184	gc = gitconfig r
185
186-- Used by git-annex-shell lockcontent to indicate the content is
187-- successfully locked.
188contentLockedMarker :: String
189contentLockedMarker = "OK"
190
191-- A connection over ssh to git-annex shell speaking the P2P protocol.
192type P2PSshConnection = P2P.ClosableConnection
193	(P2P.RunState, P2P.P2PConnection, ProcessHandle, TVar StderrHandlerState)
194
195data StderrHandlerState = DiscardStderr | DisplayStderr | EndStderrHandler
196
197closeP2PSshConnection :: P2PSshConnection -> IO (P2PSshConnection, Maybe ExitCode)
198closeP2PSshConnection P2P.ClosedConnection = return (P2P.ClosedConnection, Nothing)
199closeP2PSshConnection (P2P.OpenConnection (_st, conn, pid, stderrhandlerst)) =
200	-- mask async exceptions, avoid cleanup being interrupted
201	uninterruptibleMask_ $ do
202		P2P.closeConnection conn
203		atomically $ writeTVar stderrhandlerst EndStderrHandler
204		exitcode <- waitForProcess pid
205		return (P2P.ClosedConnection, Just exitcode)
206
207-- Pool of connections over ssh to git-annex-shell p2pstdio.
208type P2PSshConnectionPool = TVar (Maybe P2PSshConnectionPoolState)
209
210data P2PSshConnectionPoolState
211	= P2PSshConnections [P2PSshConnection]
212	-- Remotes using an old version of git-annex-shell don't support P2P
213	| P2PSshUnsupported
214
215mkP2PSshConnectionPool :: Annex P2PSshConnectionPool
216mkP2PSshConnectionPool = liftIO $ newTVarIO Nothing
217
218-- Takes a connection from the pool, if any are available, otherwise
219-- tries to open a new one.
220getP2PSshConnection :: Remote -> P2PSshConnectionPool -> Annex (Maybe P2PSshConnection)
221getP2PSshConnection r connpool = getexistingconn >>= \case
222	Nothing -> return Nothing
223	Just Nothing -> openP2PSshConnection r connpool
224	Just (Just c) -> return (Just c)
225  where
226	getexistingconn = liftIO $ atomically $ readTVar connpool >>= \case
227		Just P2PSshUnsupported -> return Nothing
228		Just (P2PSshConnections (c:cs)) -> do
229			writeTVar connpool (Just (P2PSshConnections cs))
230			return (Just (Just c))
231		Just (P2PSshConnections []) -> return (Just Nothing)
232		Nothing -> return (Just Nothing)
233
234-- Add a connection to the pool, unless it's closed.
235storeP2PSshConnection :: P2PSshConnectionPool -> P2PSshConnection -> IO ()
236storeP2PSshConnection _ P2P.ClosedConnection = return ()
237storeP2PSshConnection connpool conn = atomically $ modifyTVar' connpool $ \case
238	Just (P2PSshConnections cs) -> Just (P2PSshConnections (conn:cs))
239	_ -> Just (P2PSshConnections [conn])
240
241-- Try to open a P2PSshConnection.
242-- The new connection is not added to the pool, so it's available
243-- for the caller to use.
244-- If the remote does not support the P2P protocol, that's remembered in
245-- the connection pool.
246openP2PSshConnection :: Remote -> P2PSshConnectionPool -> Annex (Maybe P2PSshConnection)
247openP2PSshConnection r connpool = do
248	u <- getUUID
249	let ps = [Param (fromUUID u)]
250	repo <- getRepo r
251	git_annex_shell ConsumeStdin repo "p2pstdio" ps [] >>= \case
252		Nothing -> do
253			liftIO $ rememberunsupported
254			return Nothing
255		Just (cmd, params) -> start cmd params =<< getRepo r
256  where
257	start cmd params repo = liftIO $ do
258		(Just from, Just to, Just err, pid) <- createProcess $
259			(proc cmd (toCommand params))
260				{ std_in = CreatePipe
261				, std_out = CreatePipe
262				, std_err = CreatePipe
263				}
264		pidnum <- getPid pid
265		let conn = P2P.P2PConnection
266			{ P2P.connRepo = repo
267			, P2P.connCheckAuth = const False
268			, P2P.connIhdl = to
269			, P2P.connOhdl = from
270			, P2P.connIdent = P2P.ConnIdent $
271				Just $ "ssh connection " ++ show pidnum
272			}
273		stderrhandlerst <- newStderrHandler err pid
274		runst <- P2P.mkRunState P2P.Client
275		let c = P2P.OpenConnection (runst, conn, pid, stderrhandlerst)
276		-- When the connection is successful, the remote
277		-- will send an AUTH_SUCCESS with its uuid.
278		let proto = P2P.postAuth $
279			P2P.negotiateProtocolVersion P2P.maxProtocolVersion
280		tryNonAsync (P2P.runNetProto runst conn proto) >>= \case
281			Right (Right (Just theiruuid)) | theiruuid == uuid r -> do
282				atomically $
283					writeTVar stderrhandlerst DisplayStderr
284				return $ Just c
285			_ -> do
286				(cclosed, exitcode) <- closeP2PSshConnection c
287				-- ssh exits 255 when unable to connect to
288				-- server. Return a closed connection in
289				-- this case, to avoid the fallback action
290				-- being run instead, which would mean a
291				-- second connection attempt to this server
292				-- that is down.
293				if exitcode == Just (ExitFailure 255)
294					then return (Just cclosed)
295					else do
296						rememberunsupported
297						return Nothing
298	rememberunsupported = atomically $
299		modifyTVar' connpool $
300			maybe (Just P2PSshUnsupported) Just
301
302newStderrHandler :: Handle -> ProcessHandle -> IO (TVar StderrHandlerState)
303newStderrHandler errh ph = do
304	-- stderr from git-annex-shell p2pstdio is initially discarded
305	-- because old versions don't support the command. Once it's known
306	-- to be running, this is changed to DisplayStderr.
307	v <- newTVarIO DiscardStderr
308	void $ async $ go v
309	return v
310  where
311	go v = do
312		hGetLineUntilExitOrEOF ph errh >>= \case
313			Nothing -> hClose errh
314			Just l -> atomically (readTVar v) >>= \case
315				DiscardStderr -> go v
316				DisplayStderr -> do
317					hPutStrLn stderr l
318					go v
319				EndStderrHandler -> hClose errh
320
321-- Runs a P2P Proto action on a remote when it supports that,
322-- otherwise the fallback action.
323runProto :: Remote -> P2PSshConnectionPool -> Annex a -> Annex a -> P2P.Proto a -> Annex (Maybe a)
324runProto r connpool badproto fallback proto = Just <$>
325	(getP2PSshConnection r connpool >>= maybe fallback go)
326  where
327	go c = do
328		(c', v) <- runProtoConn proto c
329		case v of
330			Just res -> do
331				liftIO $ storeP2PSshConnection connpool c'
332				return res
333			-- Running the proto failed, either due to a protocol
334			-- error or a network error.
335			Nothing -> badproto
336
337runProtoConn :: P2P.Proto a -> P2PSshConnection -> Annex (P2PSshConnection, Maybe a)
338runProtoConn _ P2P.ClosedConnection = return (P2P.ClosedConnection, Nothing)
339runProtoConn a conn@(P2P.OpenConnection (runst, c, _, _)) = do
340	P2P.runFullProto runst c a >>= \case
341		Right r -> return (conn, Just r)
342		-- When runFullProto fails, the connection is no longer
343		-- usable, so close it.
344		Left e -> do
345			warning $ "Lost connection (" ++ P2P.describeProtoFailure e ++ ")"
346			conn' <- fst <$> liftIO (closeP2PSshConnection conn)
347			return (conn', Nothing)
348
349-- Allocates a P2P ssh connection from the pool, and runs the action with it,
350-- returning the connection to the pool once the action is done.
351--
352-- If the remote does not support the P2P protocol, runs the fallback
353-- action instead.
354withP2PSshConnection
355	:: Remote
356	-> P2PSshConnectionPool
357	-> Annex a
358	-> (P2PSshConnection -> Annex (P2PSshConnection, a))
359	-> Annex a
360withP2PSshConnection r connpool fallback a = bracketOnError get cache go
361  where
362	get = getP2PSshConnection r connpool
363	cache (Just conn) = liftIO $ storeP2PSshConnection connpool conn
364	cache Nothing = return ()
365	go (Just conn) = do
366		(conn', res) <- a conn
367		cache (Just conn')
368		return res
369	go Nothing = fallback
370