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