diff options
Diffstat (limited to 'Remote')
| -rw-r--r-- | Remote/BitTorrent.hs | 4 | ||||
| -rw-r--r-- | Remote/Git.hs | 67 | ||||
| -rw-r--r-- | Remote/Helper/Special.hs | 6 | ||||
| -rw-r--r-- | Remote/Tahoe.hs | 4 | ||||
| -rw-r--r-- | Remote/Web.hs | 4 |
5 files changed, 42 insertions, 43 deletions
diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs index d3963a918..f9027ba61 100644 --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -76,8 +76,8 @@ gen r _ c gc = , checkUrl = Just checkTorrentUrl } -downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool -downloadKey key _file dest p = +downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) +downloadKey key _file dest p = unVerified $ get . map (torrentUrlNum . fst . getDownloader) =<< getBitTorrentUrls key where get [] = do diff --git a/Remote/Git.hs b/Remote/Git.hs index 841837113..f7a0b4a39 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -359,13 +359,13 @@ dropKey r key | otherwise = commitOnCleanup r $ Ssh.dropKey (repo r) key {- Tries to copy a key's content from a remote's annex to a file. -} -copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool +copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) copyFromRemote r key file dest p = parallelMetered (Just p) key file $ copyFromRemote' r key file dest -copyFromRemote' :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool +copyFromRemote' :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) copyFromRemote' r key file dest meterupdate - | not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $ do + | not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (unVerified (return False)) $ do params <- Ssh.rsyncParams r Download u <- getUUID hardlink <- wantHardLink @@ -374,18 +374,17 @@ copyFromRemote' r key file dest meterupdate ensureInitialized v <- Annex.Content.prepSendAnnex key case v of - Nothing -> return False + Nothing -> return (False, UnVerified) Just (object, checksuccess) -> do copier <- mkCopier hardlink params runTransfer (Transfer Download u key) file noRetry noObserver - (callCopier copier object dest) - <&&> checksuccess - | Git.repoIsSsh (repo r) = feedprogressback $ \feeder -> do + (\p -> copier object dest p checksuccess) + | Git.repoIsSsh (repo r) = unVerified $ feedprogressback $ \feeder -> do direct <- isDirect Ssh.rsyncHelper (Just feeder) =<< Ssh.rsyncParamsRemote direct r Download key dest file - | Git.repoIsHttp (repo r) = Annex.Content.downloadUrl (keyUrls r key) dest + | Git.repoIsHttp (repo r) = unVerified $ Annex.Content.downloadUrl (keyUrls r key) dest | otherwise = error "copying from non-ssh, non-http remote not supported" where {- Feed local rsync's progress info back to the remote, @@ -462,8 +461,8 @@ copyFromRemoteCheap r key af file ) | Git.repoIsSsh (repo r) = ifM (Annex.Content.preseedTmp key file) - ( parallelMetered Nothing key af $ - copyFromRemote' r key af file + ( fst <$> parallelMetered Nothing key af + (copyFromRemote' r key af file) , return False ) | otherwise = return False @@ -502,13 +501,11 @@ copyToRemote' r key file p , do ensureInitialized copier <- mkCopier hardlink params - let verify = if isHardLinker copier - then Annex.Content.NoVerify - else Annex.Content.RemoteVerify r + let verify = Annex.Content.RemoteVerify r runTransfer (Transfer Download u key) file noRetry noObserver $ const $ Annex.Content.saveState True `after` Annex.Content.getViaTmp verify key - (\dest -> callCopier copier object dest p <&&> liftIO checksuccessio) + (\dest -> copier object dest p (liftIO checksuccessio)) ) fsckOnRemote :: Git.Repo -> [CommandParam] -> Annex (IO Bool) @@ -620,32 +617,34 @@ commitOnCleanup r a = go `after` a wantHardLink :: Annex Bool wantHardLink = (annexHardLink <$> Annex.getGitConfig) <&&> (not <$> isDirect) -data Copier - = Copier (FilePath -> FilePath -> MeterUpdate -> Annex Bool) - | HardLinker (FilePath -> FilePath -> MeterUpdate -> Annex Bool) - -isHardLinker :: Copier -> Bool -isHardLinker (Copier _) = False -isHardLinker (HardLinker _) = True - -callCopier :: Copier -> FilePath -> FilePath -> MeterUpdate -> Annex Bool -callCopier (Copier a) = a -callCopier (HardLinker a) = a - +-- Copies from src to dest, updating a meter. If the copy finishes +-- successfully, calls a final check action, which must also success, or +-- returns false. +-- -- If either the remote or local repository wants to use hard links, --- the copier will do so, falling back to copying. +-- the copier will do so (falling back to copying if a hard link cannot be +-- made). +-- +-- When a hard link is created, returns Verified; the repo being linked +-- from is implicitly trusted, so no expensive verification needs to be +-- done. +type Copier = FilePath -> FilePath -> MeterUpdate -> Annex Bool -> Annex (Bool, Verification) + mkCopier :: Bool -> [CommandParam] -> Annex Copier mkCopier remotewanthardlink rsyncparams = do - let copier = rsyncOrCopyFile rsyncparams + let copier = \src dest p check -> unVerified $ + rsyncOrCopyFile rsyncparams src dest p <&&> check #ifndef mingw32_HOST_OS localwanthardlink <- wantHardLink - let linker = \object dest -> createLink object dest >> return True + let linker = \src dest -> createLink src dest >> return True ifM (pure (remotewanthardlink || localwanthardlink) <&&> not <$> isDirect) - ( return $ HardLinker $ \object dest p -> - liftIO (catchBoolIO (linker object dest)) - <||> copier object dest p - , return $ Copier copier + ( return $ \src dest p check -> + ifM (liftIO (catchBoolIO (linker src dest))) + ( return (True, Verified) + , copier src dest p check + ) + , return copier ) #else - return $ Copier copier + return copier #endif diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index 1acabcc91..7faf7a8a1 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -122,8 +122,8 @@ byteRetriever a k _m callback = a k (callback . ByteContent) -} storeKeyDummy :: Key -> AssociatedFile -> MeterUpdate -> Annex Bool storeKeyDummy _ _ _ = return False -retreiveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool -retreiveKeyFileDummy _ _ _ _ = return False +retreiveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) +retreiveKeyFileDummy _ _ _ _ = unVerified (return False) removeKeyDummy :: Key -> Annex Bool removeKeyDummy _ = return False checkPresentDummy :: Key -> Annex Bool @@ -156,7 +156,7 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp where encr = baser { storeKey = \k f p -> cip >>= storeKeyGen k f p - , retrieveKeyFile = \k f d p -> cip >>= retrieveKeyFileGen k f d p + , retrieveKeyFile = \k f d p -> cip >>= unVerified . retrieveKeyFileGen k f d p , retrieveKeyFileCheap = \k f d -> cip >>= maybe (retrieveKeyFileCheap baser k f d) -- retrieval of encrypted keys is never cheap diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs index 1357a0183..c04cdae58 100644 --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -116,8 +116,8 @@ store u hdl k _f _p = sendAnnex k noop $ \src -> (return False) (\cap -> storeCapability u k cap >> return True) -retrieve :: UUID -> TahoeHandle -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool -retrieve u hdl k _f d _p = go =<< getCapability u k +retrieve :: UUID -> TahoeHandle -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) +retrieve u hdl k _f d _p = unVerified $ go =<< getCapability u k where go Nothing = return False go (Just cap) = liftIO $ requestTahoe hdl "get" [Param cap, File d] diff --git a/Remote/Web.hs b/Remote/Web.hs index 700f40480..ae0281064 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -70,8 +70,8 @@ gen r _ c gc = , checkUrl = Nothing } -downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool -downloadKey key _file dest _p = get =<< getWebUrls key +downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) +downloadKey key _file dest _p = unVerified $ get =<< getWebUrls key where get [] = do warning "no known url" |