1{- Standard git remotes. 2 - 3 - Copyright 2011-2021 Joey Hess <id@joeyh.name> 4 - 5 - Licensed under the GNU AGPL version 3 or higher. 6 -} 7 8{-# LANGUAGE CPP #-} 9{-# LANGUAGE OverloadedStrings #-} 10 11module Remote.Git ( 12 remote, 13 configRead, 14 repoAvail, 15 onLocalRepo, 16) where 17 18import Annex.Common 19import Annex.Ssh 20import Types.Remote 21import Types.GitConfig 22import qualified Git 23import qualified Git.Config 24import qualified Git.Construct 25import qualified Git.Command 26import qualified Git.GCrypt 27import qualified Git.Types as Git 28import qualified Annex 29import Logs.Presence 30import Annex.Transfer 31import Annex.CopyFile 32import Annex.Verify 33import Annex.UUID 34import qualified Annex.Content 35import qualified Annex.BranchState 36import qualified Annex.Branch 37import qualified Annex.Url as Url 38import qualified Annex.SpecialRemote.Config as SpecialRemote 39import Utility.Tmp 40import Config 41import Config.Cost 42import Annex.SpecialRemote.Config 43import Config.DynamicConfig 44import Annex.Init 45import Types.CleanupActions 46import qualified CmdLine.GitAnnexShell.Fields as Fields 47import Logs.Location 48import Utility.Metered 49import Utility.Env 50import Utility.Batch 51import Utility.SimpleProtocol 52import Remote.Helper.Git 53import Remote.Helper.Messages 54import Remote.Helper.ExportImport 55import qualified Remote.Helper.Ssh as Ssh 56import qualified Remote.GCrypt 57import qualified Remote.GitLFS 58import qualified Remote.P2P 59import qualified Remote.Helper.P2P as P2PHelper 60import P2P.Address 61import Annex.Path 62import Creds 63import Types.NumCopies 64import Types.ProposedAccepted 65import Annex.Action 66import Messages.Progress 67 68#ifndef mingw32_HOST_OS 69import qualified Utility.RawFilePath as R 70#endif 71 72import Control.Concurrent 73import Control.Concurrent.MSampleVar 74import qualified Data.Map as M 75import qualified Data.ByteString as S 76import Network.URI 77 78remote :: RemoteType 79remote = RemoteType 80 { typename = "git" 81 , enumerate = list 82 , generate = gen 83 , configParser = mkRemoteConfigParser 84 [ optionalStringParser locationField 85 (FieldDesc "url of git remote to remember with special remote") 86 ] 87 , setup = gitSetup 88 , exportSupported = exportUnsupported 89 , importSupported = importUnsupported 90 , thirdPartyPopulated = False 91 } 92 93locationField :: RemoteConfigField 94locationField = Accepted "location" 95 96list :: Bool -> Annex [Git.Repo] 97list autoinit = do 98 c <- fromRepo Git.config 99 rs <- mapM (tweakurl c) =<< Annex.getGitRemotes 100 mapM (configRead autoinit) rs 101 where 102 annexurl r = remoteConfig r "annexurl" 103 tweakurl c r = do 104 let n = fromJust $ Git.remoteName r 105 case M.lookup (annexurl r) c of 106 Nothing -> return r 107 Just url -> inRepo $ \g -> 108 Git.Construct.remoteNamed n $ 109 Git.Construct.fromRemoteLocation (Git.fromConfigValue url) g 110 111{- Git remotes are normally set up using standard git command, not 112 - git-annex initremote and enableremote. 113 - 114 - For initremote, the git remote must already be set up, and have a uuid. 115 - Initremote simply remembers its location. 116 - 117 - enableremote simply sets up a git remote using the stored location. 118 - No attempt is made to make the remote be accessible via ssh key setup, 119 - etc. 120 -} 121gitSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) 122gitSetup Init mu _ c _ = do 123 let location = fromMaybe (giveup "Specify location=url") $ 124 Url.parseURIRelaxed . fromProposedAccepted 125 =<< M.lookup locationField c 126 rs <- Annex.getGitRemotes 127 u <- case filter (\r -> Git.location r == Git.Url location) rs of 128 [r] -> getRepoUUID r 129 [] -> giveup "could not find existing git remote with specified location" 130 _ -> giveup "found multiple git remotes with specified location" 131 if isNothing mu || mu == Just u 132 then return (c, u) 133 else error "git remote did not have specified uuid" 134gitSetup (Enable _) mu _ c _ = enableRemote mu c 135gitSetup (AutoEnable _) mu _ c _ = enableRemote mu c 136 137enableRemote :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID) 138enableRemote (Just u) c = do 139 inRepo $ Git.Command.run 140 [ Param "remote" 141 , Param "add" 142 , Param $ fromMaybe (giveup "no name") (SpecialRemote.lookupName c) 143 , Param $ maybe (giveup "no location") fromProposedAccepted (M.lookup locationField c) 144 ] 145 return (c, u) 146enableRemote Nothing _ = error "unable to enable git remote with no specified uuid" 147 148{- It's assumed to be cheap to read the config of non-URL remotes, so this is 149 - done each time git-annex is run in a way that uses remotes, unless 150 - annex-checkuuid is false. 151 - 152 - Conversely, the config of an URL remote is only read when there is no 153 - cached UUID value. -} 154configRead :: Bool -> Git.Repo -> Annex Git.Repo 155configRead autoinit r = do 156 gc <- Annex.getRemoteGitConfig r 157 hasuuid <- (/= NoUUID) <$> getRepoUUID r 158 annexignore <- liftIO $ getDynamicConfig (remoteAnnexIgnore gc) 159 case (repoCheap r, annexignore, hasuuid) of 160 (_, True, _) -> return r 161 (True, _, _) 162 | remoteAnnexCheckUUID gc -> tryGitConfigRead autoinit r hasuuid 163 | otherwise -> return r 164 (False, _, False) -> configSpecialGitRemotes r >>= \case 165 Nothing -> tryGitConfigRead autoinit r False 166 Just r' -> return r' 167 _ -> return r 168 169gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) 170gen r u rc gc rs 171 -- Remote.GitLFS may be used with a repo that is also encrypted 172 -- with gcrypt so is checked first. 173 | remoteAnnexGitLFS gc = Remote.GitLFS.gen r u rc gc rs 174 | Git.GCrypt.isEncrypted r = Remote.GCrypt.chainGen r u rc gc rs 175 | otherwise = case repoP2PAddress r of 176 Nothing -> do 177 st <- mkState r u gc 178 c <- parsedRemoteConfig remote rc 179 go st c <$> remoteCost gc defcst 180 Just addr -> Remote.P2P.chainGen addr r u rc gc rs 181 where 182 defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost 183 go st c cst = Just new 184 where 185 new = Remote 186 { uuid = u 187 , cost = cst 188 , name = Git.repoDescribe r 189 , storeKey = copyToRemote new st 190 , retrieveKeyFile = copyFromRemote new st 191 , retrieveKeyFileCheap = copyFromRemoteCheap st r 192 , retrievalSecurityPolicy = RetrievalAllKeysSecure 193 , removeKey = dropKey new st 194 , lockContent = Just (lockKey new st) 195 , checkPresent = inAnnex new st 196 , checkPresentCheap = repoCheap r 197 , exportActions = exportUnsupported 198 , importActions = importUnsupported 199 , whereisKey = Nothing 200 , remoteFsck = if Git.repoIsUrl r 201 then Nothing 202 else Just $ fsckOnRemote r 203 , repairRepo = if Git.repoIsUrl r 204 then Nothing 205 else Just $ repairRemote r 206 , config = c 207 , localpath = localpathCalc r 208 , getRepo = getRepoFromState st 209 , gitconfig = gc 210 , readonly = Git.repoIsHttp r 211 , appendonly = False 212 , untrustworthy = False 213 , availability = availabilityCalc r 214 , remotetype = remote 215 , mkUnavailable = unavailable r u rc gc rs 216 , getInfo = gitRepoInfo new 217 , claimUrl = Nothing 218 , checkUrl = Nothing 219 , remoteStateHandle = rs 220 } 221 222unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) 223unavailable r = gen r' 224 where 225 r' = case Git.location r of 226 Git.Local { Git.gitdir = d } -> 227 r { Git.location = Git.LocalUnknown d } 228 Git.Url url -> case uriAuthority url of 229 Just auth -> 230 let auth' = auth { uriRegName = "!dne!" } 231 in r { Git.location = Git.Url (url { uriAuthority = Just auth' })} 232 Nothing -> r { Git.location = Git.Unknown } 233 _ -> r -- already unavailable 234 235{- Checks relatively inexpensively if a repository is available for use. -} 236repoAvail :: Git.Repo -> Annex Bool 237repoAvail r 238 | Git.repoIsHttp r = return True 239 | Git.GCrypt.isEncrypted r = do 240 g <- gitRepo 241 liftIO $ do 242 er <- Git.GCrypt.encryptedRemote g r 243 if Git.repoIsLocal er || Git.repoIsLocalUnknown er 244 then catchBoolIO $ 245 void (Git.Config.read er) >> return True 246 else return True 247 | Git.repoIsUrl r = return True 248 | Git.repoIsLocalUnknown r = return False 249 | otherwise = liftIO $ isJust <$> catchMaybeIO (Git.Config.read r) 250 251{- Tries to read the config for a specified remote, updates state, and 252 - returns the updated repo. -} 253tryGitConfigRead :: Bool -> Git.Repo -> Bool -> Annex Git.Repo 254tryGitConfigRead autoinit r hasuuid 255 | haveconfig r = return r -- already read 256 | Git.repoIsSsh r = storeUpdatedRemote $ do 257 v <- Ssh.onRemote NoConsumeStdin r 258 ( pipedconfig Git.Config.ConfigList autoinit (Git.repoDescribe r) 259 , return (Left "configlist failed") 260 ) 261 "configlist" [] configlistfields 262 case v of 263 Right r' 264 | haveconfig r' -> return r' 265 | otherwise -> configlist_failed 266 Left _ -> configlist_failed 267 | Git.repoIsHttp r = storeUpdatedRemote geturlconfig 268 | Git.GCrypt.isEncrypted r = handlegcrypt =<< getConfigMaybe (remoteAnnexConfig r "uuid") 269 | Git.repoIsUrl r = do 270 set_ignore "uses a protocol not supported by git-annex" False 271 return r 272 | otherwise = storeUpdatedRemote $ 273 readlocalannexconfig 274 `catchNonAsync` const failedreadlocalconfig 275 where 276 haveconfig = not . M.null . Git.config 277 278 pipedconfig st mustincludeuuuid configloc cmd params = do 279 v <- liftIO $ Git.Config.fromPipe r cmd params st 280 case v of 281 Right (r', val, _err) -> do 282 unless (isUUIDConfigured r' || S.null val || not mustincludeuuuid) $ do 283 warning $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r 284 warning $ "Instead, got: " ++ show val 285 warning $ "This is unexpected; please check the network transport!" 286 return $ Right r' 287 Left l -> do 288 warning $ "Unable to parse git config from " ++ configloc 289 return $ Left (show l) 290 291 geturlconfig = Url.withUrlOptionsPromptingCreds $ \uo -> do 292 let url = Git.repoLocation r ++ "/config" 293 v <- withTmpFile "git-annex.tmp" $ \tmpfile h -> do 294 liftIO $ hClose h 295 Url.download' nullMeterUpdate Nothing url tmpfile uo >>= \case 296 Right () -> pipedconfig Git.Config.ConfigNullList 297 False url "git" 298 [ Param "config" 299 , Param "--null" 300 , Param "--list" 301 , Param "--file" 302 , File tmpfile 303 ] 304 Left err -> return (Left err) 305 case v of 306 Right r' -> do 307 -- Cache when http remote is not bare for 308 -- optimisation. 309 unless (Git.Config.isBare r') $ 310 setremote setRemoteBare False 311 return r' 312 Left err -> do 313 set_ignore "not usable by git-annex" False 314 warning $ url ++ " " ++ err 315 return r 316 317 {- Is this remote just not available, or does 318 - it not have git-annex-shell? 319 - Find out by trying to fetch from the remote. -} 320 configlist_failed = case Git.remoteName r of 321 Nothing -> return r 322 Just n -> do 323 whenM (inRepo $ Git.Command.runBool [Param "fetch", Param "--quiet", Param n]) $ do 324 set_ignore "does not have git-annex installed" True 325 return r 326 327 set_ignore msg longmessage = do 328 case Git.remoteName r of 329 Nothing -> noop 330 Just n -> do 331 warning $ "Remote " ++ n ++ " " ++ msg ++ "; setting annex-ignore" 332 when longmessage $ 333 warning $ "This could be a problem with the git-annex installation on the remote. Please make sure that git-annex-shell is available in PATH when you ssh into the remote. Once you have fixed the git-annex installation, run: git annex enableremote " ++ n 334 setremote setRemoteIgnore True 335 336 setremote setter v = case Git.remoteName r of 337 Nothing -> noop 338 Just _ -> setter r v 339 340 handlegcrypt Nothing = return r 341 handlegcrypt (Just _cacheduuid) = do 342 -- Generate UUID from the gcrypt-id 343 g <- gitRepo 344 case Git.GCrypt.remoteRepoId g (Git.remoteName r) of 345 Nothing -> return r 346 Just v -> storeUpdatedRemote $ liftIO $ setUUID r $ 347 genUUIDInNameSpace gCryptNameSpace v 348 349 {- The local repo may not yet be initialized, so try to initialize 350 - it if allowed. However, if that fails, still return the read 351 - git config. -} 352 readlocalannexconfig = do 353 let check = do 354 Annex.BranchState.disableUpdate 355 catchNonAsync autoInitialize $ \e -> 356 warning $ "remote " ++ Git.repoDescribe r ++ 357 ":" ++ show e 358 Annex.getState Annex.repo 359 s <- newLocal r 360 liftIO $ Annex.eval s $ check `finally` stopCoProcesses 361 362 failedreadlocalconfig = do 363 unless hasuuid $ case Git.remoteName r of 364 Nothing -> noop 365 Just n -> do 366 warning $ "Remote " ++ n ++ " cannot currently be accessed." 367 return r 368 369 configlistfields = if autoinit 370 then [(Fields.autoInit, "1")] 371 else [] 372 373{- Handles special remotes that can be enabled by the presence of 374 - regular git remotes. 375 - 376 - When a remote repo is found to be such a special remote, its 377 - UUID is cached in the git config, and the repo returned with 378 - the UUID set. 379 -} 380configSpecialGitRemotes :: Git.Repo -> Annex (Maybe Git.Repo) 381configSpecialGitRemotes r = Remote.GitLFS.configKnownUrl r >>= \case 382 Nothing -> return Nothing 383 Just r' -> Just <$> storeUpdatedRemote (return r') 384 385storeUpdatedRemote :: Annex Git.Repo -> Annex Git.Repo 386storeUpdatedRemote = observe $ \r' -> do 387 l <- Annex.getGitRemotes 388 let rs = exchange l r' 389 Annex.changeState $ \s -> s { Annex.gitremotes = Just rs } 390 where 391 exchange [] _ = [] 392 exchange (old:ls) new 393 | Git.remoteName old == Git.remoteName new = 394 new : exchange ls new 395 | otherwise = 396 old : exchange ls new 397 398{- Checks if a given remote has the content for a key in its annex. -} 399inAnnex :: Remote -> State -> Key -> Annex Bool 400inAnnex rmt st key = do 401 repo <- getRepo rmt 402 inAnnex' repo rmt st key 403 404inAnnex' :: Git.Repo -> Remote -> State -> Key -> Annex Bool 405inAnnex' repo rmt st@(State connpool duc _ _ _) key 406 | Git.repoIsHttp repo = checkhttp 407 | Git.repoIsUrl repo = checkremote 408 | otherwise = checklocal 409 where 410 checkhttp = do 411 gc <- Annex.getGitConfig 412 ifM (Url.withUrlOptionsPromptingCreds $ \uo -> anyM (\u -> Url.checkBoth u (fromKey keySize key) uo) (keyUrls gc repo rmt key)) 413 ( return True 414 , giveup "not found" 415 ) 416 checkremote = 417 let fallback = Ssh.inAnnex repo key 418 in P2PHelper.checkpresent (Ssh.runProto rmt connpool (cantCheck rmt) fallback) key 419 checklocal = ifM duc 420 ( guardUsable repo (cantCheck repo) $ 421 maybe (cantCheck repo) return 422 =<< onLocalFast st (Annex.Content.inAnnexSafe key) 423 , cantCheck repo 424 ) 425 426keyUrls :: GitConfig -> Git.Repo -> Remote -> Key -> [String] 427keyUrls gc repo r key = map tourl locs' 428 where 429 tourl l = Git.repoLocation repo ++ "/" ++ l 430 -- If the remote is known to not be bare, try the hash locations 431 -- used for non-bare repos first, as an optimisation. 432 locs 433 | remoteAnnexBare remoteconfig == Just False = annexLocationsNonBare gc key 434 | otherwise = annexLocationsBare gc key 435#ifndef mingw32_HOST_OS 436 locs' = map fromRawFilePath locs 437#else 438 locs' = map (replace "\\" "/" . fromRawFilePath) locs 439#endif 440 remoteconfig = gitconfig r 441 442dropKey :: Remote -> State -> Key -> Annex () 443dropKey r st key = do 444 repo <- getRepo r 445 dropKey' repo r st key 446 447dropKey' :: Git.Repo -> Remote -> State -> Key -> Annex () 448dropKey' repo r st@(State connpool duc _ _ _) key 449 | not $ Git.repoIsUrl repo = ifM duc 450 ( guardUsable repo (giveup "cannot access remote") $ 451 commitOnCleanup repo r st $ onLocalFast st $ do 452 whenM (Annex.Content.inAnnex key) $ do 453 let cleanup = logStatus key InfoMissing 454 Annex.Content.lockContentForRemoval key cleanup $ \lock -> do 455 Annex.Content.removeAnnex lock 456 cleanup 457 Annex.Content.saveState True 458 , giveup "remote does not have expected annex.uuid value" 459 ) 460 | Git.repoIsHttp repo = giveup "dropping from http remote not supported" 461 | otherwise = commitOnCleanup repo r st $ do 462 let fallback = Ssh.dropKey' repo key 463 P2PHelper.remove (Ssh.runProto r connpool (return False) fallback) key 464 465lockKey :: Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r 466lockKey r st key callback = do 467 repo <- getRepo r 468 lockKey' repo r st key callback 469 470lockKey' :: Git.Repo -> Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r 471lockKey' repo r st@(State connpool duc _ _ _) key callback 472 | not $ Git.repoIsUrl repo = ifM duc 473 ( guardUsable repo failedlock $ do 474 inorigrepo <- Annex.makeRunner 475 -- Lock content from perspective of remote, 476 -- and then run the callback in the original 477 -- annex monad, not the remote's. 478 onLocalFast st $ 479 Annex.Content.lockContentShared key $ 480 liftIO . inorigrepo . callback 481 , failedlock 482 ) 483 | Git.repoIsSsh repo = do 484 showLocking r 485 let withconn = Ssh.withP2PSshConnection r connpool fallback 486 P2PHelper.lock withconn Ssh.runProtoConn (uuid r) key callback 487 | otherwise = failedlock 488 where 489 fallback = withNullHandle $ \nullh -> do 490 Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin 491 repo "lockcontent" 492 [Param $ serializeKey key] [] 493 let p = (proc cmd (toCommand params)) 494 { std_in = CreatePipe 495 , std_out = CreatePipe 496 , std_err = UseHandle nullh 497 } 498 bracketIO (createProcess p) cleanupProcess fallback' 499 500 fallback' (Just hin, Just hout, Nothing, p) = do 501 v <- liftIO $ tryIO $ getProtocolLine hout 502 let signaldone = void $ tryNonAsync $ liftIO $ mapM_ tryNonAsync 503 [ hPutStrLn hout "" 504 , hFlush hout 505 , hClose hin 506 , hClose hout 507 , void $ waitForProcess p 508 ] 509 let checkexited = not . isJust <$> getProcessExitCode p 510 case v of 511 Left _exited -> do 512 showNote "lockcontent failed" 513 liftIO $ do 514 hClose hin 515 hClose hout 516 void $ waitForProcess p 517 failedlock 518 Right l 519 | l == Just Ssh.contentLockedMarker -> bracket_ 520 noop 521 signaldone 522 (withVerifiedCopy LockedCopy r checkexited callback) 523 | otherwise -> do 524 showNote "lockcontent failed" 525 signaldone 526 failedlock 527 fallback' _ = error "internal" 528 529 failedlock = giveup "can't lock content" 530 531{- Tries to copy a key's content from a remote's annex to a file. -} 532copyFromRemote :: Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification 533copyFromRemote = copyFromRemote' False 534 535copyFromRemote' :: Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification 536copyFromRemote' forcersync r st key file dest meterupdate vc = do 537 repo <- getRepo r 538 copyFromRemote'' repo forcersync r st key file dest meterupdate vc 539 540copyFromRemote'' :: Git.Repo -> Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification 541copyFromRemote'' repo forcersync r st@(State connpool _ _ _ _) key file dest meterupdate vc 542 | Git.repoIsHttp repo = do 543 iv <- startVerifyKeyContentIncrementally vc key 544 gc <- Annex.getGitConfig 545 ok <- Url.withUrlOptionsPromptingCreds $ 546 Annex.Content.downloadUrl False key meterupdate iv (keyUrls gc repo r key) dest 547 unless ok $ 548 giveup "failed to download content" 549 snd <$> finishVerifyKeyContentIncrementally iv 550 | not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $ do 551 u <- getUUID 552 hardlink <- wantHardLink 553 -- run copy from perspective of remote 554 onLocalFast st $ Annex.Content.prepSendAnnex' key >>= \case 555 Just (object, check) -> do 556 let checksuccess = check >>= \case 557 Just err -> giveup err 558 Nothing -> return True 559 copier <- mkFileCopier hardlink st 560 (ok, v) <- runTransfer (Transfer Download u (fromKey id key)) 561 file Nothing stdRetry $ \p -> 562 metered (Just (combineMeterUpdate p meterupdate)) key $ \_ p' -> 563 copier object dest key p' checksuccess vc 564 if ok 565 then return v 566 else giveup "failed to retrieve content from remote" 567 Nothing -> giveup "content is not present in remote" 568 | Git.repoIsSsh repo = if forcersync 569 then do 570 (ok, v) <- fallback meterupdate 571 if ok 572 then return v 573 else giveup "failed to retrieve content from remote" 574 else P2PHelper.retrieve 575 (\p -> Ssh.runProto r connpool (return (False, UnVerified)) (fallback p)) 576 key file dest meterupdate vc 577 | otherwise = giveup "copying from non-ssh, non-http remote not supported" 578 where 579 fallback p = unVerified $ feedprogressback $ \p' -> do 580 oh <- mkOutputHandlerQuiet 581 Ssh.rsyncHelper oh (Just (combineMeterUpdate p' p)) 582 =<< Ssh.rsyncParamsRemote False r Download key dest file 583 584 {- Feed local rsync's progress info back to the remote, 585 - by forking a feeder thread that runs 586 - git-annex-shell transferinfo at the same time 587 - git-annex-shell sendkey is running. 588 - 589 - To avoid extra password prompts, this is only done when ssh 590 - connection caching is supported. 591 - Note that it actually waits for rsync to indicate 592 - progress before starting transferinfo, in order 593 - to ensure ssh connection caching works and reuses 594 - the connection set up for the sendkey. 595 - 596 - Also note that older git-annex-shell does not support 597 - transferinfo, so stderr is dropped and failure ignored. 598 -} 599 feedprogressback a = ifM (isJust <$> sshCacheDir) 600 ( feedprogressback' a 601 , a $ const noop 602 ) 603 feedprogressback' a = do 604 u <- getUUID 605 let AssociatedFile afile = file 606 let fields = (Fields.remoteUUID, fromUUID u) 607 : maybe [] (\f -> [(Fields.associatedFile, fromRawFilePath f)]) afile 608 Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin 609 repo "transferinfo" 610 [Param $ serializeKey key] fields 611 v <- liftIO (newEmptySV :: IO (MSampleVar Integer)) 612 pv <- liftIO $ newEmptyMVar 613 tid <- liftIO $ forkIO $ void $ tryIO $ do 614 bytes <- readSV v 615 p <- createProcess $ 616 (proc cmd (toCommand params)) 617 { std_in = CreatePipe 618 , std_err = CreatePipe 619 } 620 putMVar pv p 621 hClose $ stderrHandle p 622 let h = stdinHandle p 623 let send b = do 624 hPrint h b 625 hFlush h 626 send bytes 627 forever $ 628 send =<< readSV v 629 let feeder = \n -> do 630 meterupdate n 631 writeSV v (fromBytesProcessed n) 632 633 -- It can easily take 0.3 seconds to clean up after 634 -- the transferinfo, and all that's involved is shutting 635 -- down the process and associated thread cleanly. So, 636 -- do it in the background. 637 let cleanup = forkIO $ do 638 void $ tryIO $ killThread tid 639 void $ tryNonAsync $ 640 maybe noop (void . waitForProcess . processHandle) 641 =<< tryTakeMVar pv 642 643 let forcestop = do 644 void $ tryIO $ killThread tid 645 void $ tryNonAsync $ 646 maybe noop cleanupProcess 647 =<< tryTakeMVar pv 648 649 bracketIO noop (const cleanup) (const $ a feeder) 650 `onException` liftIO forcestop 651 652copyFromRemoteCheap :: State -> Git.Repo -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ()) 653#ifndef mingw32_HOST_OS 654copyFromRemoteCheap st repo 655 | not $ Git.repoIsUrl repo = Just $ \key _af file -> guardUsable repo (giveup "cannot access remote") $ do 656 gc <- getGitConfigFromState st 657 loc <- liftIO $ gitAnnexLocation key repo gc 658 liftIO $ ifM (R.doesPathExist loc) 659 ( do 660 absloc <- absPath loc 661 R.createSymbolicLink absloc (toRawFilePath file) 662 , giveup "remote does not contain key" 663 ) 664 | otherwise = Nothing 665#else 666copyFromRemoteCheap _ _ = Nothing 667#endif 668 669{- Tries to copy a key's content to a remote's annex. -} 670copyToRemote :: Remote -> State -> Key -> AssociatedFile -> MeterUpdate -> Annex () 671copyToRemote r st key file meterupdate = do 672 repo <- getRepo r 673 copyToRemote' repo r st key file meterupdate 674 675copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> MeterUpdate -> Annex () 676copyToRemote' repo r st@(State connpool duc _ _ _) key file meterupdate 677 | not $ Git.repoIsUrl repo = ifM duc 678 ( guardUsable repo (giveup "cannot access remote") $ commitOnCleanup repo r st $ 679 copylocal =<< Annex.Content.prepSendAnnex' key 680 , giveup "remote does not have expected annex.uuid value" 681 ) 682 | Git.repoIsSsh repo = commitOnCleanup repo r st $ 683 P2PHelper.store 684 (Ssh.runProto r connpool (return False) . copyremotefallback) 685 key file meterupdate 686 687 | otherwise = giveup "copying to non-ssh repo not supported" 688 where 689 copylocal Nothing = giveup "content not available" 690 copylocal (Just (object, check)) = do 691 -- The check action is going to be run in 692 -- the remote's Annex, but it needs access to the local 693 -- Annex monad's state. 694 checkio <- Annex.withCurrentState check 695 u <- getUUID 696 hardlink <- wantHardLink 697 -- run copy from perspective of remote 698 res <- onLocalFast st $ ifM (Annex.Content.inAnnex key) 699 ( return True 700 , runTransfer (Transfer Download u (fromKey id key)) file Nothing stdRetry $ \p -> do 701 let verify = RemoteVerify r 702 copier <- mkFileCopier hardlink st 703 let rsp = RetrievalAllKeysSecure 704 let checksuccess = liftIO checkio >>= \case 705 Just err -> giveup err 706 Nothing -> return True 707 res <- logStatusAfter key $ Annex.Content.getViaTmp rsp verify key file $ \dest -> 708 metered (Just (combineMeterUpdate meterupdate p)) key $ \_ p' -> 709 copier object (fromRawFilePath dest) key p' checksuccess verify 710 Annex.Content.saveState True 711 return res 712 ) 713 unless res $ 714 giveup "failed to send content to remote" 715 copyremotefallback p = either (const False) id 716 <$> tryNonAsync (copyremotefallback' p) 717 copyremotefallback' p = Annex.Content.sendAnnex key noop $ \object -> do 718 -- This is too broad really, but recvkey normally 719 -- verifies content anyway, so avoid complicating 720 -- it with a local sendAnnex check and rollback. 721 let unlocked = True 722 oh <- mkOutputHandlerQuiet 723 Ssh.rsyncHelper oh (Just p) 724 =<< Ssh.rsyncParamsRemote unlocked r Upload key object file 725 726fsckOnRemote :: Git.Repo -> [CommandParam] -> Annex (IO Bool) 727fsckOnRemote r params 728 | Git.repoIsUrl r = do 729 s <- Ssh.git_annex_shell NoConsumeStdin r "fsck" params [] 730 return $ case s of 731 Nothing -> return False 732 Just (c, ps) -> batchCommand c ps 733 | otherwise = return $ do 734 program <- programPath 735 r' <- Git.Config.read r 736 environ <- getEnvironment 737 let environ' = addEntries 738 [ ("GIT_WORK_TREE", fromRawFilePath $ Git.repoPath r') 739 , ("GIT_DIR", fromRawFilePath $ Git.localGitDir r') 740 ] environ 741 batchCommandEnv program (Param "fsck" : params) (Just environ') 742 743{- The passed repair action is run in the Annex monad of the remote. -} 744repairRemote :: Git.Repo -> Annex Bool -> Annex (IO Bool) 745repairRemote r a = return $ do 746 s <- Annex.new r 747 Annex.eval s $ do 748 Annex.BranchState.disableUpdate 749 ensureInitialized 750 a `finally` stopCoProcesses 751 752data LocalRemoteAnnex = LocalRemoteAnnex Git.Repo (MVar (Maybe (Annex.AnnexState, Annex.AnnexRead))) 753 754{- This can safely be called on a Repo that is not local, but of course 755 - onLocal will not work if used with the result. -} 756mkLocalRemoteAnnex :: Git.Repo -> Annex (LocalRemoteAnnex) 757mkLocalRemoteAnnex repo = LocalRemoteAnnex repo <$> liftIO (newMVar Nothing) 758 759{- Runs an action from the perspective of a local remote. 760 - 761 - The AnnexState is cached for speed and to avoid resource leaks. 762 - However, coprocesses are stopped after each call to avoid git 763 - processes hanging around on removable media. 764 - 765 - The remote will be automatically initialized/upgraded first, 766 - when possible. 767 -} 768onLocal :: State -> Annex a -> Annex a 769onLocal (State _ _ _ _ lra) = onLocal' lra 770 771onLocalRepo :: Git.Repo -> Annex a -> Annex a 772onLocalRepo repo a = do 773 lra <- mkLocalRemoteAnnex repo 774 onLocal' lra a 775 776newLocal :: Git.Repo -> Annex (Annex.AnnexState, Annex.AnnexRead) 777newLocal repo = do 778 (st, rd) <- liftIO $ Annex.new repo 779 debugenabled <- Annex.getRead Annex.debugenabled 780 debugselector <- Annex.getRead Annex.debugselector 781 return (st, rd 782 { Annex.debugenabled = debugenabled 783 , Annex.debugselector = debugselector 784 }) 785 786onLocal' :: LocalRemoteAnnex -> Annex a -> Annex a 787onLocal' (LocalRemoteAnnex repo mv) a = liftIO (takeMVar mv) >>= \case 788 Nothing -> do 789 v <- newLocal repo 790 go (v, ensureInitialized >> a) 791 Just v -> go (v, a) 792 where 793 go ((st, rd), a') = do 794 curro <- Annex.getState Annex.output 795 let act = Annex.run (st { Annex.output = curro }, rd) $ 796 a' `finally` stopCoProcesses 797 (ret, (st', _rd)) <- liftIO $ act `onException` cache (st, rd) 798 liftIO $ cache (st', rd) 799 return ret 800 cache = putMVar mv . Just 801 802{- Faster variant of onLocal. 803 - 804 - The repository's git-annex branch is not updated, as an optimisation. 805 - No caller of onLocalFast can query data from the branch and be ensured 806 - it gets the most current value. Caller of onLocalFast can make changes 807 - to the branch, however. 808 -} 809onLocalFast :: State -> Annex a -> Annex a 810onLocalFast st a = onLocal st $ Annex.BranchState.disableUpdate >> a 811 812commitOnCleanup :: Git.Repo -> Remote -> State -> Annex a -> Annex a 813commitOnCleanup repo r st a = go `after` a 814 where 815 go = Annex.addCleanupAction (RemoteCleanup $ uuid r) cleanup 816 cleanup 817 | not $ Git.repoIsUrl repo = onLocalFast st $ 818 doQuietSideAction $ 819 Annex.Branch.commit =<< Annex.Branch.commitMessage 820 | otherwise = do 821 Just (shellcmd, shellparams) <- 822 Ssh.git_annex_shell NoConsumeStdin 823 repo "commit" [] [] 824 825 -- Throw away stderr, since the remote may not 826 -- have a new enough git-annex shell to 827 -- support committing. 828 liftIO $ void $ catchMaybeIO $ withNullHandle $ \nullh -> 829 let p = (proc shellcmd (toCommand shellparams)) 830 { std_out = UseHandle nullh 831 , std_err = UseHandle nullh 832 } 833 in withCreateProcess p $ \_ _ _ -> 834 forceSuccessProcess p 835 836wantHardLink :: Annex Bool 837wantHardLink = (annexHardLink <$> Annex.getGitConfig) 838 -- Not unlocked files that are hard linked in the work tree, 839 -- because they can be modified at any time. 840 <&&> (not <$> annexThin <$> Annex.getGitConfig) 841 842type FileCopier = FilePath -> FilePath -> Key -> MeterUpdate -> Annex Bool -> VerifyConfig -> Annex (Bool, Verification) 843 844-- If either the remote or local repository wants to use hard links, 845-- the copier will do so (falling back to copying if a hard link cannot be 846-- made). 847-- 848-- When a hard link is created, returns Verified; the repo being linked 849-- from is implicitly trusted, so no expensive verification needs to be 850-- done. Also returns Verified if the key's content is verified while 851-- copying it. 852mkFileCopier :: Bool -> State -> Annex FileCopier 853mkFileCopier remotewanthardlink (State _ _ copycowtried _ _) = do 854 localwanthardlink <- wantHardLink 855 let linker = \src dest -> createLink src dest >> return True 856 if remotewanthardlink || localwanthardlink 857 then return $ \src dest k p check verifyconfig -> 858 ifM (liftIO (catchBoolIO (linker src dest))) 859 ( ifM check 860 ( return (True, Verified) 861 , return (False, UnVerified) 862 ) 863 , copier src dest k p check verifyconfig 864 ) 865 else return copier 866 where 867 copier src dest k p check verifyconfig = do 868 iv <- startVerifyKeyContentIncrementally verifyconfig k 869 fileCopier copycowtried src dest p iv >>= \case 870 Copied -> ifM check 871 ( finishVerifyKeyContentIncrementally iv 872 , return (False, UnVerified) 873 ) 874 CopiedCoW -> unVerified check 875 876{- Normally the UUID of a local repository is checked at startup, 877 - but annex-checkuuid config can prevent that. To avoid getting 878 - confused, a deferred check is done just before the repository 879 - is used. 880 - This returns False when the repository UUID is not as expected. -} 881type DeferredUUIDCheck = Annex Bool 882 883data State = State Ssh.P2PSshConnectionPool DeferredUUIDCheck CopyCoWTried (Annex (Git.Repo, GitConfig)) LocalRemoteAnnex 884 885getRepoFromState :: State -> Annex Git.Repo 886getRepoFromState (State _ _ _ a _) = fst <$> a 887 888#ifndef mingw32_HOST_OS 889{- The config of the remote git repository, cached for speed. -} 890getGitConfigFromState :: State -> Annex GitConfig 891getGitConfigFromState (State _ _ _ a _) = snd <$> a 892#endif 893 894mkState :: Git.Repo -> UUID -> RemoteGitConfig -> Annex State 895mkState r u gc = do 896 pool <- Ssh.mkP2PSshConnectionPool 897 copycowtried <- liftIO newCopyCoWTried 898 lra <- mkLocalRemoteAnnex r 899 (duc, getrepo) <- go 900 return $ State pool duc copycowtried getrepo lra 901 where 902 go 903 | remoteAnnexCheckUUID gc = return 904 (return True, return (r, extractGitConfig FromGitConfig r)) 905 | otherwise = do 906 rv <- liftIO newEmptyMVar 907 let getrepo = ifM (liftIO $ isEmptyMVar rv) 908 ( do 909 r' <- tryGitConfigRead False r True 910 let t = (r', extractGitConfig FromGitConfig r') 911 void $ liftIO $ tryPutMVar rv t 912 return t 913 , liftIO $ readMVar rv 914 ) 915 916 cv <- liftIO newEmptyMVar 917 let duc = ifM (liftIO $ isEmptyMVar cv) 918 ( do 919 r' <- fst <$> getrepo 920 u' <- getRepoUUID r' 921 let ok = u' == u 922 void $ liftIO $ tryPutMVar cv ok 923 unless ok $ 924 warning $ Git.repoDescribe r ++ " is not the expected repository. The remote's annex-checkuuid configuration prevented noticing the change until now." 925 return ok 926 , liftIO $ readMVar cv 927 ) 928 929 return (duc, getrepo) 930