diff --git a/CHANGELOG b/CHANGELOG index 121016cc54..a2b3eea9ee 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -26,7 +26,7 @@ git-annex (8.20200502) UNRELEASED; urgency=medium the current directory. * Display a warning message when asked to operate on a file inside a directory that's a symbolic link to elsewhere. - * When storing content on remote fails, always display a reason why. + * When accessing a remote fails, always display a reason why. -- Joey Hess Mon, 04 May 2020 12:46:11 -0400 diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index ede22bebbe..b7f1b71e56 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -189,15 +189,19 @@ downloadRemoteFile addunlockedmatcher r o uri file sz = checkCanAdd file $ do -- so that the remote knows what url it -- should use to download it. setTempUrl urlkey loguri - let downloader = \dest p -> fst - <$> Remote.retrieveKeyFile r urlkey - (AssociatedFile (Just (toRawFilePath file))) dest p + let downloader = \dest p -> + tryNonAsync (Remote.retrieveKeyFile r urlkey af dest p) >>= \case + Right _ -> return True + Left e -> do + warning (show e) + return False ret <- downloadWith addunlockedmatcher downloader urlkey (Remote.uuid r) loguri file removeTempUrl urlkey return ret ) where loguri = setDownloader uri OtherDownloader + af = AssociatedFile (Just (toRawFilePath file)) startWeb :: AddUnlockedMatcher -> AddUrlOptions -> URLString -> CommandStart startWeb addunlockedmatcher o urlstring = go $ fromMaybe bad $ parseURI urlstring diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 434e8b92cd..e67735b32c 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -41,6 +41,7 @@ import Data.Time.Clock.POSIX import System.Posix.Types (EpochTime) import qualified Data.Set as S import qualified Data.Map as M +import Data.Either cmd :: Command cmd = withGlobalOptions [jobsOption, jsonOptions, annexedMatchingOptions] $ @@ -174,17 +175,20 @@ performRemote key afile backend numcopies remote = cleanup cleanup `after` a tmp getfile tmp = ifM (checkDiskSpace (Just (takeDirectory tmp)) key 0 True) - ( ifM (Remote.retrieveKeyFileCheap remote key afile tmp) + ( ifM (getcheap tmp) ( return (Just True) , ifM (Annex.getState Annex.fast) ( return Nothing - , Just . fst <$> - Remote.retrieveKeyFile remote key (AssociatedFile Nothing) tmp dummymeter + , Just . isRight <$> tryNonAsync (getfile' tmp) ) ) , return (Just False) ) + getfile' tmp = Remote.retrieveKeyFile remote key (AssociatedFile Nothing) tmp dummymeter dummymeter _ = noop + getcheap tmp = case Remote.retrieveKeyFileCheap remote of + Just a -> isRight <$> tryNonAsync (a key afile tmp) + Nothing -> return False startKey :: Maybe Remote -> Incremental -> (Key, ActionItem) -> NumCopies -> CommandStart startKey from inc (key, ai) numcopies = diff --git a/Command/Get.hs b/Command/Get.hs index e3bf47cb59..7c9e8cfe2e 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -112,5 +112,9 @@ getKey' key afile = dispatch download (Remote.uuid r) key afile stdRetry (\p -> do showAction $ "from " ++ Remote.name r - Remote.retrieveKeyFile r key afile dest p + tryNonAsync (Remote.retrieveKeyFile r key afile dest p) >>= \case + Right v -> return (True, v) + Left e -> do + warning (show e) + return (False, UnVerified) ) witness diff --git a/Command/Move.hs b/Command/Move.hs index 8aee3eb624..19400c358b 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -207,7 +207,11 @@ fromPerform src removewhen key afile = do go = notifyTransfer Download afile $ download (Remote.uuid src) key afile stdRetry $ \p -> getViaTmp (Remote.retrievalSecurityPolicy src) (RemoteVerify src) key $ \t -> - Remote.retrieveKeyFile src key afile t p + tryNonAsync (Remote.retrieveKeyFile src key afile t p) >>= \case + Right v -> return (True, v) + Left e -> do + warning (show e) + return (False, UnVerified) dispatch _ _ False = stop -- failed dispatch RemoveNever _ True = next $ return True -- copy complete dispatch RemoveSafe deststartedwithcopy True = lockContentShared key $ \_lck -> do diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index 042837cf23..9aeb8b53c2 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -274,8 +274,9 @@ test runannex mkr mkk = Nothing -> return True Just verifier -> verifier k (serializeKey k) get r k = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> - Remote.retrieveKeyFile r k (AssociatedFile Nothing) - dest nullMeterUpdate + tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) dest nullMeterUpdate) >>= \case + Right v -> return (True, v) + Left _ -> return (False, UnVerified) store r k = Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate remove r k = Remote.removeKey r k @@ -348,10 +349,14 @@ testUnavailable runannex mkr mkk = Remote.checkPresent r k , check (== Right False) "retrieveKeyFile" $ \r k -> getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> - Remote.retrieveKeyFile r k (AssociatedFile Nothing) dest nullMeterUpdate - , check (== Right False) "retrieveKeyFileCheap" $ \r k -> - getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> unVerified $ - Remote.retrieveKeyFileCheap r k (AssociatedFile Nothing) dest + tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) dest nullMeterUpdate) >>= \case + Right v -> return (True, v) + Left _ -> return (False, UnVerified) + , check (== Right False) "retrieveKeyFileCheap" $ \r k -> case Remote.retrieveKeyFileCheap r of + Nothing -> return False + Just a -> getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> + unVerified $ isRight + <$> tryNonAsync (a k (AssociatedFile Nothing) dest) ] where check checkval desc a = testCase desc $ diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs index ee2d6b185a..01e292c21b 100644 --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -53,18 +53,22 @@ toPerform :: Key -> AssociatedFile -> Remote -> CommandPerform toPerform key file remote = go Upload file $ upload (uuid remote) key file stdRetry $ \p -> do tryNonAsync (Remote.storeKey remote key file p) >>= \case - Left e -> do - warning (show e) - return False Right () -> do Remote.logStatus remote key InfoPresent return True + Left e -> do + warning (show e) + return False fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform fromPerform key file remote = go Upload file $ download (uuid remote) key file stdRetry $ \p -> - getViaTmp (retrievalSecurityPolicy remote) (RemoteVerify remote) key $ - \t -> Remote.retrieveKeyFile remote key file t p + getViaTmp (retrievalSecurityPolicy remote) (RemoteVerify remote) key $ \t -> + tryNonAsync (Remote.retrieveKeyFile remote key file t p) >>= \case + Right v -> return (True, v) + Left e -> do + warning (show e) + return (False, UnVerified) go :: Direction -> AssociatedFile -> (NotifyWitness -> Annex Bool) -> CommandPerform go direction file a = notifyTransfer direction file a >>= liftIO . exitBool diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index 1cc1fe1d3d..cc41dc2d4c 100644 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -48,7 +48,11 @@ start = do | otherwise = notifyTransfer direction file $ download (Remote.uuid remote) key file stdRetry $ \p -> getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key $ \t -> do - r <- Remote.retrieveKeyFile remote key file t p + r <- tryNonAsync (Remote.retrieveKeyFile remote key file t p) >>= \case + Left e -> do + warning (show e) + return (False, UnVerified) + Right v -> return (True, v) -- Make sure we get the current -- associated files data for the key, -- not old cached data. diff --git a/Remote/Adb.hs b/Remote/Adb.hs index cab25705c7..a6ec17d7b9 100644 --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -64,8 +64,8 @@ gen r u rc gc rs = do , cost = semiExpensiveRemoteCost , name = Git.repoDescribe r , storeKey = storeKeyDummy - , retrieveKeyFile = retreiveKeyFileDummy - , retrieveKeyFileCheap = \_ _ _ -> return False + , retrieveKeyFile = retrieveKeyFileDummy + , retrieveKeyFileCheap = Nothing , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = removeKeyDummy , lockContent = Nothing diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs index 3cf426c197..600e033a4f 100644 --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -64,7 +64,7 @@ gen r _ rc gc rs = do , name = Git.repoDescribe r , storeKey = uploadKey , retrieveKeyFile = downloadKey - , retrieveKeyFileCheap = downloadKeyCheap + , retrieveKeyFileCheap = Nothing -- Bittorrent does its own hash checks. , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = dropKey @@ -91,25 +91,23 @@ gen r _ rc gc rs = do , remoteStateHandle = rs } -downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) -downloadKey key _file dest p = unVerified $ +downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification +downloadKey key _file dest p = do get . map (torrentUrlNum . fst . getDownloader) =<< getBitTorrentUrls key + return UnVerified where - get [] = do - warning "could not download torrent" - return False + get [] = giveup "could not download torrent" get urls = do showOutput -- make way for download progress bar - untilTrue urls $ \(u, filenum) -> do + ok <- untilTrue urls $ \(u, filenum) -> do registerTorrentCleanup u checkDependencies ifM (downloadTorrentFile u) ( downloadTorrentContent key u dest filenum p , return False ) - -downloadKeyCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool -downloadKeyCheap _ _ _ = return False + unless ok $ + get [] uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex () uploadKey _ _ _ = giveup "upload to bittorrent not supported" diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 9ea3755c9d..7d9b06cf7f 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -70,8 +70,8 @@ gen r u rc gc rs = do , cost = cst , name = Git.repoDescribe r , storeKey = storeKeyDummy - , retrieveKeyFile = retreiveKeyFileDummy - , retrieveKeyFileCheap = retrieveCheap buprepo + , retrieveKeyFile = retrieveKeyFileDummy + , retrieveKeyFileCheap = Nothing -- Bup uses git, which cryptographically verifies content -- (with SHA1, but sufficiently for this). , retrievalSecurityPolicy = RetrievalAllKeysSecure @@ -169,9 +169,6 @@ retrieve buprepo = byteRetriever $ \k sink -> do liftIO (hClose h >> forceSuccessProcess p pid) `after` (sink =<< liftIO (L.hGetContents h)) -retrieveCheap :: BupRepo -> Key -> AssociatedFile -> FilePath -> Annex Bool -retrieveCheap _ _ _ _ = return False - {- Cannot revert having stored a key in bup, but at least the data for the - key will be used for deltaing data of other keys stored later. - diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs index 0a803f1be0..50f14ca721 100644 --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -71,8 +71,8 @@ gen r u rc gc rs = do , cost = cst , name = Git.repoDescribe r , storeKey = storeKeyDummy - , retrieveKeyFile = retreiveKeyFileDummy - , retrieveKeyFileCheap = retrieveCheap + , retrieveKeyFile = retrieveKeyFileDummy + , retrieveKeyFileCheap = Nothing -- ddar communicates over ssh, not subject to http redirect -- type attacks , retrievalSecurityPolicy = RetrievalAllKeysSecure @@ -162,9 +162,6 @@ retrieve ddarrepo = byteRetriever $ \k sink -> do liftIO (hClose h >> forceSuccessProcess p pid) `after` (sink =<< liftIO (L.hGetContents h)) -retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool -retrieveCheap _ _ _ = return False - remove :: DdarRepo -> Remover remove ddarrepo key = do (cmd, params) <- ddarRemoteCall NoConsumeStdin ddarrepo 'd' diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 4b8e21bd97..718417cccb 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -69,7 +69,7 @@ gen r u rc gc rs = do , cost = cst , name = Git.repoDescribe r , storeKey = storeKeyDummy - , retrieveKeyFile = retreiveKeyFileDummy + , retrieveKeyFile = retrieveKeyFileDummy , retrieveKeyFileCheap = retrieveKeyFileCheapM dir chunkconfig , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = removeKeyDummy @@ -205,21 +205,19 @@ retrieveKeyFileM d (LegacyChunks _) = Legacy.retrieve locations d retrieveKeyFileM d _ = byteRetriever $ \k sink -> sink =<< liftIO (L.readFile =<< getLocation d k) -retrieveKeyFileCheapM :: FilePath -> ChunkConfig -> Key -> AssociatedFile -> FilePath -> Annex Bool +retrieveKeyFileCheapM :: FilePath -> ChunkConfig -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ()) -- no cheap retrieval possible for chunks -retrieveKeyFileCheapM _ (UnpaddedChunks _) _ _ _ = return False -retrieveKeyFileCheapM _ (LegacyChunks _) _ _ _ = return False +retrieveKeyFileCheapM _ (UnpaddedChunks _) = Nothing +retrieveKeyFileCheapM _ (LegacyChunks _) = Nothing #ifndef mingw32_HOST_OS -retrieveKeyFileCheapM d NoChunks k _af f = liftIO $ catchBoolIO $ do +retrieveKeyFileCheapM d NoChunks = Just $ \k _af f -> liftIO $ do file <- absPath =<< getLocation d k ifM (doesFileExist file) - ( do - createSymbolicLink file f - return True - , return False + ( createSymbolicLink file f + , giveup "content file not present in remote" ) #else -retrieveKeyFileCheapM _ _ _ _ _ = return False +retrieveKeyFileCheapM _ _ = Nothing #endif removeKeyM :: FilePath -> Remover diff --git a/Remote/External.hs b/Remote/External.hs index 00ff204ba0..1a9b7162ad 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -121,8 +121,8 @@ gen r u rc gc rs , cost = cst , name = Git.repoDescribe r , storeKey = storeKeyDummy - , retrieveKeyFile = retreiveKeyFileDummy - , retrieveKeyFileCheap = \_ _ _ -> return False + , retrieveKeyFile = retrieveKeyFileDummy + , retrieveKeyFileCheap = Nothing -- External special remotes use many http libraries -- and have no protection against redirects to -- local private web servers, or in some cases diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index cf4756033b..a8c58a8990 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -132,8 +132,8 @@ gen' r u c gc rs = do , cost = cst , name = Git.repoDescribe r , storeKey = storeKeyDummy - , retrieveKeyFile = retreiveKeyFileDummy - , retrieveKeyFileCheap = \_ _ _ -> return False + , retrieveKeyFile = retrieveKeyFileDummy + , retrieveKeyFileCheap = Nothing , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = removeKeyDummy , lockContent = Nothing @@ -393,7 +393,7 @@ retrieve r rsyncopts k p sink = do retrieve' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> Retriever retrieve' repo r rsyncopts | not $ Git.repoIsUrl repo = byteRetriever $ \k sink -> - guardUsable repo (return False) $ + guardUsable repo (giveup "cannot access remote") $ sink =<< liftIO (L.readFile $ gCryptLocation repo k) | Git.repoIsSsh repo = if accessShell r then fileRetriever $ \f k p -> do diff --git a/Remote/Git.hs b/Remote/Git.hs index 42522ceae7..41cb2c1870 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -183,7 +183,7 @@ gen r u rc gc rs , name = Git.repoDescribe r , storeKey = copyToRemote new st , retrieveKeyFile = copyFromRemote new st - , retrieveKeyFileCheap = copyFromRemoteCheap new st + , retrieveKeyFileCheap = copyFromRemoteCheap new st r , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = dropKey new st , lockContent = Just (lockKey new st) @@ -515,50 +515,55 @@ lockKey' repo r st@(State connpool duc _ _ _) key callback failedlock = giveup "can't lock content" {- Tries to copy a key's content from a remote's annex to a file. -} -copyFromRemote :: Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) +copyFromRemote :: Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification copyFromRemote = copyFromRemote' False -copyFromRemote' :: Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) +copyFromRemote' :: Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification copyFromRemote' forcersync r st key file dest meterupdate = do repo <- getRepo r copyFromRemote'' repo forcersync r st key file dest meterupdate -copyFromRemote'' :: Git.Repo -> Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) +copyFromRemote'' :: Git.Repo -> Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification copyFromRemote'' repo forcersync r st@(State connpool _ _ _ _) key file dest meterupdate - | Git.repoIsHttp repo = unVerified $ do + | Git.repoIsHttp repo = do gc <- Annex.getGitConfig - Url.withUrlOptionsPromptingCreds $ + ok <- Url.withUrlOptionsPromptingCreds $ Annex.Content.downloadUrl key meterupdate (keyUrls gc repo r key) dest - | not $ Git.repoIsUrl repo = guardUsable repo (unVerified (return False)) $ do + unless ok $ + giveup "failed to download content" + return UnVerified + | not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $ do params <- Ssh.rsyncParams r Download u <- getUUID hardlink <- wantHardLink -- run copy from perspective of remote - onLocalFast st $ do - v <- Annex.Content.prepSendAnnex key - case v of - Nothing -> do - warning "content is not present in remote" - return (False, UnVerified) - Just (object, checksuccess) -> do - copier <- mkCopier hardlink st params - runTransfer (Transfer Download u (fromKey id key)) - file stdRetry $ \p -> - metered (Just (combineMeterUpdate p meterupdate)) key $ \_ p' -> - copier object dest p' checksuccess + onLocalFast st $ Annex.Content.prepSendAnnex key >>= \case + Just (object, checksuccess) -> do + copier <- mkCopier hardlink st params + (ok, v) <- runTransfer (Transfer Download u (fromKey id key)) + file stdRetry $ \p -> + metered (Just (combineMeterUpdate p meterupdate)) key $ \_ p' -> + copier object dest p' checksuccess + if ok + then return v + else giveup "failed to retrieve content from remote" + Nothing -> giveup "content is not present in remote" | Git.repoIsSsh repo = if forcersync - then fallback meterupdate + then do + (ok, v) <- fallback meterupdate + if ok + then return v + else giveup "failed to retrieve content from remote" else P2PHelper.retrieve (\p -> Ssh.runProto r connpool (return (False, UnVerified)) (fallback p)) key file dest meterupdate - | otherwise = do - warning "copying from non-ssh, non-http remote not supported" - unVerified (return False) + | otherwise = giveup "copying from non-ssh, non-http remote not supported" where fallback p = unVerified $ feedprogressback $ \p' -> do oh <- mkOutputHandlerQuiet Ssh.rsyncHelper oh (Just (combineMeterUpdate p' p)) =<< Ssh.rsyncParamsRemote False r Download key dest file + {- Feed local rsync's progress info back to the remote, - by forking a feeder thread that runs - git-annex-shell transferinfo at the same time @@ -619,33 +624,26 @@ copyFromRemote'' repo forcersync r st@(State connpool _ _ _ _) key file dest met =<< tryTakeMVar pidv bracketIO noop (const cleanup) (const $ a feeder) -copyFromRemoteCheap :: Remote -> State -> Key -> AssociatedFile -> FilePath -> Annex Bool -copyFromRemoteCheap r st key af file = do - repo <- getRepo r - copyFromRemoteCheap' repo r st key af file - -copyFromRemoteCheap' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> FilePath -> Annex Bool +copyFromRemoteCheap :: Remote -> State -> Git.Repo -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ()) +copyFromRemoteCheap r st repo #ifndef mingw32_HOST_OS -copyFromRemoteCheap' repo r st key af file - | not $ Git.repoIsUrl repo = guardUsable repo (return False) $ do + | not $ Git.repoIsUrl repo = Just $ \key _af file -> guardUsable repo (giveup "cannot access remote") $ do gc <- getGitConfigFromState st loc <- liftIO $ gitAnnexLocation key repo gc liftIO $ ifM (R.doesPathExist loc) ( do absloc <- absPath (fromRawFilePath loc) - catchBoolIO $ do - createSymbolicLink absloc file - return True - , return False + createSymbolicLink absloc file + , giveup "remote does not contain key" ) - | Git.repoIsSsh repo = + | Git.repoIsSsh repo = Just $ \key af file -> ifM (Annex.Content.preseedTmp key file) - ( fst <$> copyFromRemote' True r st key af file nullMeterUpdate - , return False + ( void $ copyFromRemote' True r st key af file nullMeterUpdate + , giveup "cannot preseed rsync with existing content" ) - | otherwise = return False + | otherwise = Nothing #else -copyFromRemoteCheap' _ _ _ _ _ _ = return False +copyFromRemoteCheap' _ _ _ = Nothing #endif {- Tries to copy a key's content to a remote's annex. -} diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs index f1d6080de5..85acbe67ec 100644 --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -102,8 +102,8 @@ gen r u rc gc rs = do , cost = cst , name = Git.repoDescribe r , storeKey = storeKeyDummy - , retrieveKeyFile = retreiveKeyFileDummy - , retrieveKeyFileCheap = retrieveCheap + , retrieveKeyFile = retrieveKeyFileDummy + , retrieveKeyFileCheap = Nothing -- content stored on git-lfs is hashed with SHA256 -- no matter what git-annex key it's for, and the hash -- is checked on download @@ -525,9 +525,6 @@ checkKey rs h key = getLFSEndpoint LFS.RequestDownload h >>= \case giveup "git-lfs server replied with other object than the one we requested" | otherwise -> return True -retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool -retrieveCheap _ _ _ = return False - remove :: TVar LFSHandle -> Remover remove _h _key = do warning "git-lfs does not support removing content" diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index f2ec67143e..bb54e5506e 100644 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -76,8 +76,8 @@ gen r u rc gc rs = new , cost = cst , name = Git.repoDescribe r , storeKey = storeKeyDummy - , retrieveKeyFile = retreiveKeyFileDummy - , retrieveKeyFileCheap = retrieveCheap this + , retrieveKeyFile = retrieveKeyFileDummy + , retrieveKeyFileCheap = Nothing -- glacier-cli does not follow redirects and does -- not support file://, as far as we know, but -- there's no guarantee that will continue to be @@ -169,7 +169,7 @@ store' r k b p = go =<< glacierEnv c gc u retrieve :: Remote -> Retriever retrieve = byteRetriever . retrieve' -retrieve' :: Remote -> Key -> (L.ByteString -> Annex Bool) -> Annex Bool +retrieve' :: Remote -> Key -> (L.ByteString -> Annex ()) -> Annex () retrieve' r k sink = go =<< glacierEnv c gc u where c = config r @@ -183,26 +183,22 @@ retrieve' r k sink = go =<< glacierEnv c gc u , Param $ archive r k ] go Nothing = giveup "cannot retrieve from glacier" - go (Just e) = do + go (Just environ) = do let cmd = (proc "glacier" (toCommand params)) - { env = Just e + { env = Just environ , std_out = CreatePipe } (_, Just h, _, pid) <- liftIO $ createProcess cmd - -- Glacier cannot store empty files, so if the output is - -- empty, the content is not available yet. - ok <- ifM (liftIO $ hIsEOF h) - ( return False - , sink =<< liftIO (L.hGetContents h) - ) - liftIO $ hClose h - liftIO $ forceSuccessProcess cmd pid - unless ok $ do - showLongNote "Recommend you wait up to 4 hours, and then run this command again." - return ok - -retrieveCheap :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool -retrieveCheap _ _ _ _ = return False + let cleanup = liftIO $ do + hClose h + forceSuccessProcess cmd pid + flip finally cleanup $ do + -- Glacier cannot store empty files, so if + -- the output is empty, the content is not + -- available yet. + whenM (liftIO $ hIsEOF h) $ + giveup "Content is not available from glacier yet. Recommend you wait up to 4 hours, and then run this command again." + sink =<< liftIO (L.hGetContents h) remove :: Remote -> Remover remove r k = glacierAction r diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs index 99ef8aa1f1..f6b947006b 100644 --- a/Remote/Helper/Chunked.hs +++ b/Remote/Helper/Chunked.hs @@ -221,8 +221,8 @@ removeChunks remover u chunkconfig encryptor k = do - other chunks in the list is fed to the sink. - - If retrival of one of the subsequent chunks throws an exception, - - gives up and returns False. Note that partial data may have been - - written to the sink in this case. + - gives up. Note that partial data may have been written to the sink + - in this case. - - Resuming is supported when using chunks. When the destination file - already exists, it skips to the next chunked key that would be needed @@ -236,8 +236,8 @@ retrieveChunks -> Key -> FilePath -> MeterUpdate - -> (Maybe Handle -> Maybe MeterUpdate -> ContentSource -> Annex Bool) - -> Annex Bool + -> (Maybe Handle -> Maybe MeterUpdate -> ContentSource -> Annex ()) + -> Annex () retrieveChunks retriever u chunkconfig encryptor basek dest basep sink | noChunks chunkconfig = -- Optimisation: Try the unchunked key first, to avoid @@ -251,14 +251,10 @@ retrieveChunks retriever u chunkconfig encryptor basek dest basep sink currsize <- liftIO $ catchMaybeIO $ getFileSize dest let ls' = maybe ls (setupResume ls) currsize if any null ls' - then return True -- dest is already complete - else firstavail currsize ls' `catchNonAsync` unable + then noop -- dest is already complete + else firstavail currsize ls' - unable e = do - warning (show e) - return False - - firstavail _ [] = return False + firstavail _ [] = giveup "chunk retrieval failed" firstavail currsize ([]:ls) = firstavail currsize ls firstavail currsize ((k:ks):ls) | k == basek = getunchunked @@ -271,25 +267,22 @@ retrieveChunks retriever u chunkconfig encryptor basek dest basep sink v <- tryNonAsync $ retriever (encryptor k) p $ \content -> bracketIO (maybe opennew openresume offset) hClose $ \h -> do - void $ tosink (Just h) p content + tosink (Just h) p content let sz = toBytesProcessed $ fromMaybe 0 $ fromKey keyChunkSize k getrest p h sz sz ks - `catchNonAsync` unable case v of Left e - | null ls -> unable e + | null ls -> throwM e | otherwise -> firstavail currsize ls Right r -> return r - getrest _ _ _ _ [] = return True + getrest _ _ _ _ [] = noop getrest p h sz bytesprocessed (k:ks) = do let p' = offsetMeterUpdate p bytesprocessed liftIO $ p' zeroBytesProcessed - ifM (retriever (encryptor k) p' $ tosink (Just h) p') - ( getrest p h sz (addBytesProcessed bytesprocessed sz) ks - , unable "chunk retrieval failed" - ) + retriever (encryptor k) p' $ tosink (Just h) p' + getrest p h sz (addBytesProcessed bytesprocessed sz) ks getunchunked = retriever (encryptor basek) basep $ tosink Nothing basep diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs index 387dc34639..4292e4b9b5 100644 --- a/Remote/Helper/ExportImport.hs +++ b/Remote/Helper/ExportImport.hs @@ -202,15 +202,12 @@ adjustExportImport r rs = case getRemoteConfigValue exportTreeField (config r) o , retrieveKeyFile = \k af dest p -> let retrieveexport = retrieveKeyFileFromExport dbv k af dest p in if appendonly r - then do - ret@(ok, _v) <- retrieveKeyFile r k af dest p - if ok - then return ret - else retrieveexport + then retrieveKeyFile r k af dest p + `catchNonAsync` const retrieveexport else retrieveexport , retrieveKeyFileCheap = if appendonly r then retrieveKeyFileCheap r - else \_ _ _ -> return False + else Nothing -- Removing a key from an export would need to -- change the tree in the export log to not include -- the file. Otherwise, conflicts when removing @@ -318,18 +315,16 @@ adjustExportImport r rs = case getRemoteConfigValue exportTreeField (config r) o db <- getexportdb dbv liftIO $ Export.getExportTree db k - retrieveKeyFileFromExport dbv k _af dest p = unVerified $ - if maybe False (isJust . verifyKeyContent) (maybeLookupBackendVariety (fromKey keyVariety k)) - then do - locs <- getexportlocs dbv k - case locs of - [] -> do - ifM (liftIO $ atomically $ readTVar $ getexportinconflict dbv) - ( warning "unknown export location, likely due to the export conflict" - , warning "unknown export location" - ) - return False - (l:_) -> retrieveExport (exportActions r) k l dest p - else do - warning $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (fromKey keyVariety k)) ++ " backend" - return False + retrieveKeyFileFromExport dbv k _af dest p + | maybe False (isJust . verifyKeyContent) (maybeLookupBackendVariety (fromKey keyVariety k)) = do + locs <- getexportlocs dbv k + case locs of + [] -> ifM (liftIO $ atomically $ readTVar $ getexportinconflict dbv) + ( giveup "unknown export location, likely due to the export conflict" + , giveup "unknown export location" + ) + (l:_) -> do + unlessM (retrieveExport (exportActions r) k l dest p) $ + giveup "retrieving from export failed" + return UnVerified + | otherwise = giveup $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (fromKey keyVariety k)) ++ " backend" diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs index 2b455f15bb..e6b061e5cc 100644 --- a/Remote/Helper/Hooks.hs +++ b/Remote/Helper/Hooks.hs @@ -34,7 +34,9 @@ addHooks' r starthook stophook = r' r' = r { storeKey = \k f p -> wrapper $ storeKey r k f p , retrieveKeyFile = \k f d p -> wrapper $ retrieveKeyFile r k f d p - , retrieveKeyFileCheap = \k af f -> wrapper $ retrieveKeyFileCheap r k af f + , retrieveKeyFileCheap = case retrieveKeyFileCheap r of + Just a -> Just $ \k af f -> wrapper $ a k af f + Nothing -> Nothing , removeKey = wrapper . removeKey r , checkPresent = wrapper . checkPresent r } diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs index be92ca169f..ab4235c045 100644 --- a/Remote/Helper/P2P.hs +++ b/Remote/Helper/P2P.hs @@ -39,11 +39,13 @@ store runner k af p = do Just False -> giveup "transfer failed" Nothing -> giveup "can't connect to remote" -retrieve :: (MeterUpdate -> ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) +retrieve :: (MeterUpdate -> ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification retrieve runner k af dest p = metered (Just p) k $ \m p' -> - fromMaybe (False, UnVerified) - <$> runner p' (P2P.get dest k af m p') + runner p' (P2P.get dest k af m p') >>= \case + Just (True, v) -> return v + Just (False, _) -> giveup "transfer failed" + Nothing -> giveup "can't connec to remote" remove :: ProtoRunner Bool -> Key -> Annex Bool remove runner k = fromMaybe False <$> runner (P2P.remove k) diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index e8b408b870..8cb62a32f1 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -21,7 +21,7 @@ module Remote.Helper.Special ( fileRetriever, byteRetriever, storeKeyDummy, - retreiveKeyFileDummy, + retrieveKeyFileDummy, removeKeyDummy, checkPresentDummy, SpecialRemoteCfg(..), @@ -112,7 +112,7 @@ fileRetriever a k m callback = do -- A Retriever that generates a lazy ByteString containing the Key's -- content, and passes it to a callback action which will fully consume it -- before returning. -byteRetriever :: (Key -> (L.ByteString -> Annex Bool) -> Annex Bool) -> Retriever +byteRetriever :: (Key -> (L.ByteString -> Annex ()) -> Annex ()) -> Retriever byteRetriever a k _m callback = a k (callback . ByteContent) {- The base Remote that is provided to specialRemote needs to have @@ -122,8 +122,8 @@ byteRetriever a k _m callback = a k (callback . ByteContent) -} storeKeyDummy :: Key -> AssociatedFile -> MeterUpdate -> Annex () storeKeyDummy _ _ _ = error "missing storeKey implementation" -retreiveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) -retreiveKeyFileDummy _ _ _ _ = unVerified (return False) +retrieveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification +retrieveKeyFileDummy _ _ _ _ = error "missing retrieveKeyFile implementation" removeKeyDummy :: Key -> Annex Bool removeKeyDummy _ = return False checkPresentDummy :: Key -> Annex Bool @@ -168,11 +168,13 @@ specialRemote' cfg c storer retriever remover checkpresent baser = encr where encr = baser { storeKey = \k _f p -> cip >>= storeKeyGen k p - , retrieveKeyFile = \k _f d p -> cip >>= unVerified . retrieveKeyFileGen k d p - , retrieveKeyFileCheap = \k f d -> cip >>= maybe - (retrieveKeyFileCheap baser k f d) - -- retrieval of encrypted keys is never cheap - (\_ -> return False) + , retrieveKeyFile = \k _f d p -> cip >>= retrieveKeyFileGen k d p + , retrieveKeyFileCheap = case retrieveKeyFileCheap baser of + Nothing -> Nothing + Just a + -- retrieval of encrypted keys is never cheap + | isencrypted -> Nothing + | otherwise -> Just $ \k f d -> a k f d -- When encryption is used, the remote could provide -- some other content encrypted by the user, and trick -- git-annex into decrypting it, leaking the decryption @@ -226,10 +228,11 @@ specialRemote' cfg c storer retriever remover checkpresent baser = encr storer (enck k) (ByteContent encb) p -- call retriever to get chunks; decrypt them; stream to dest file - retrieveKeyFileGen k dest p enc = safely $ + retrieveKeyFileGen k dest p enc = do displayprogress p k Nothing $ \p' -> retrieveChunks retriever (uuid baser) chunkconfig enck k dest p' (sink dest enc encr) + return UnVerified where enck = maybe id snd enc @@ -268,27 +271,25 @@ sink -> Maybe Handle -> Maybe MeterUpdate -> ContentSource - -> Annex Bool -sink dest enc c mh mp content = do - case (enc, mh, content) of - (Nothing, Nothing, FileContent f) - | f == dest -> noop - | otherwise -> liftIO $ moveFile f dest - (Just (cipher, _), _, ByteContent b) -> do - cmd <- gpgCmd <$> Annex.getGitConfig + -> Annex () +sink dest enc c mh mp content = case (enc, mh, content) of + (Nothing, Nothing, FileContent f) + | f == dest -> noop + | otherwise -> liftIO $ moveFile f dest + (Just (cipher, _), _, ByteContent b) -> do + cmd <- gpgCmd <$> Annex.getGitConfig + decrypt cmd c cipher (feedBytes b) $ + readBytes write + (Just (cipher, _), _, FileContent f) -> do + cmd <- gpgCmd <$> Annex.getGitConfig + withBytes content $ \b -> decrypt cmd c cipher (feedBytes b) $ readBytes write - (Just (cipher, _), _, FileContent f) -> do - cmd <- gpgCmd <$> Annex.getGitConfig - withBytes content $ \b -> - decrypt cmd c cipher (feedBytes b) $ - readBytes write - liftIO $ nukeFile f - (Nothing, _, FileContent f) -> do - withBytes content write - liftIO $ nukeFile f - (Nothing, _, ByteContent b) -> write b - return True + liftIO $ nukeFile f + (Nothing, _, FileContent f) -> do + withBytes content write + liftIO $ nukeFile f + (Nothing, _, ByteContent b) -> write b where write b = case mh of Just h -> liftIO $ b `streamto` h diff --git a/Remote/Hook.hs b/Remote/Hook.hs index dcca98d155..c8f0ffaca5 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -59,8 +59,8 @@ gen r u rc gc rs = do , cost = cst , name = Git.repoDescribe r , storeKey = storeKeyDummy - , retrieveKeyFile = retreiveKeyFileDummy - , retrieveKeyFileCheap = retrieveCheap hooktype + , retrieveKeyFile = retrieveKeyFileDummy + , retrieveKeyFileCheap = Nothing -- A hook could use http and be vulnerable to -- redirect to file:// attacks, etc. , retrievalSecurityPolicy = mkRetrievalVerifiableKeysSecure gc @@ -162,9 +162,6 @@ retrieve h = fileRetriever $ \d k _p -> unlessM (runHook' h "retrieve" k (Just d) $ return True) $ giveup "failed to retrieve content" -retrieveCheap :: HookName -> Key -> AssociatedFile -> FilePath -> Annex Bool -retrieveCheap _ _ _ _ = return False - remove :: HookName -> Remover remove h k = runHook' h "remove" k Nothing $ return True diff --git a/Remote/P2P.hs b/Remote/P2P.hs index 009bca6e77..5016c9f059 100644 --- a/Remote/P2P.hs +++ b/Remote/P2P.hs @@ -56,7 +56,7 @@ chainGen addr r u rc gc rs = do , name = Git.repoDescribe r , storeKey = store (const protorunner) , retrieveKeyFile = retrieve (const protorunner) - , retrieveKeyFileCheap = \_ _ _ -> return False + , retrieveKeyFileCheap = Nothing , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = remove protorunner , lockContent = Just $ lock withconn runProtoConn u diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 0fe3adfda1..fdc3021a60 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -89,8 +89,8 @@ gen r u rc gc rs = do , cost = cst , name = Git.repoDescribe r , storeKey = storeKeyDummy - , retrieveKeyFile = retreiveKeyFileDummy - , retrieveKeyFileCheap = retrieveCheap o + , retrieveKeyFile = retrieveKeyFileDummy + , retrieveKeyFileCheap = Just (retrieveCheap o) , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = removeKeyDummy , lockContent = Nothing @@ -237,12 +237,13 @@ storeGeneric' o meterupdate basedest populatedest = withRsyncScratchDir $ \tmp - else return False retrieve :: RsyncOpts -> FilePath -> Key -> MeterUpdate -> Annex () -retrieve o f k p = - unlessM (rsyncRetrieveKey o k f (Just p)) $ - giveup "rsync failed" +retrieve o f k p = rsyncRetrieveKey o k f (Just p) -retrieveCheap :: RsyncOpts -> Key -> AssociatedFile -> FilePath -> Annex Bool -retrieveCheap o k _af f = ifM (preseedTmp k f) ( rsyncRetrieveKey o k f Nothing , return False ) +retrieveCheap :: RsyncOpts -> Key -> AssociatedFile -> FilePath -> Annex () +retrieveCheap o k _af f = ifM (preseedTmp k f) + ( rsyncRetrieveKey o k f Nothing + , giveup "cannot preseed rsync with existing content" + ) remove :: RsyncOpts -> Remover remove o k = removeGeneric o includes @@ -358,8 +359,10 @@ rsyncRetrieve o rsyncurls dest meterupdate = , File dest ] -rsyncRetrieveKey :: RsyncOpts -> Key -> FilePath -> Maybe MeterUpdate -> Annex Bool -rsyncRetrieveKey o k dest meterupdate = rsyncRetrieve o (rsyncUrls o k) dest meterupdate +rsyncRetrieveKey :: RsyncOpts -> Key -> FilePath -> Maybe MeterUpdate -> Annex () +rsyncRetrieveKey o k dest meterupdate = + unlessM (rsyncRetrieve o (rsyncUrls o k) dest meterupdate) $ + giveup "rsync failed" showResumable :: Annex Bool -> Annex Bool showResumable a = ifM a diff --git a/Remote/S3.hs b/Remote/S3.hs index 574fa5da11..1e0a7ca343 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -193,8 +193,8 @@ gen r u rc gc rs = do , cost = cst , name = Git.repoDescribe r , storeKey = storeKeyDummy - , retrieveKeyFile = retreiveKeyFileDummy - , retrieveKeyFileCheap = retrieveCheap + , retrieveKeyFile = retrieveKeyFileDummy + , retrieveKeyFileCheap = Nothing -- HttpManagerRestricted is used here, so this is -- secure. , retrievalSecurityPolicy = RetrievalAllKeysSecure @@ -418,9 +418,6 @@ retrieveHelper' h f p req = liftIO $ runResourceT $ do S3.GetObjectResponse { S3.gorResponse = rsp } <- sendS3Handle h req Url.sinkResponseFile p zeroBytesProcessed f WriteMode rsp -retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool -retrieveCheap _ _ _ = return False - remove :: S3HandleVar -> Remote -> S3Info -> Remover remove hv r info k = withS3HandleOrFail (uuid r) hv $ \h -> liftIO $ runResourceT $ do res <- tryNonAsync $ sendS3Handle h $ diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs index 2755815569..59dc400dca 100644 --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -87,7 +87,7 @@ gen r u rc gc rs = do , name = Git.repoDescribe r , storeKey = store rs hdl , retrieveKeyFile = retrieve rs hdl - , retrieveKeyFileCheap = \_ _ _ -> return False + , retrieveKeyFileCheap = Nothing -- Tahoe cryptographically verifies content. , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = remove @@ -141,11 +141,14 @@ store rs hdl k _f _p = sendAnnex k noop $ \src -> (giveup "tahoe failed to store content") (\cap -> storeCapability rs k cap) -retrieve :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) -retrieve rs hdl k _f d _p = unVerified $ go =<< getCapability rs k +retrieve :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification +retrieve rs hdl k _f d _p = do + go =<< getCapability rs k + return UnVerified where - go Nothing = return False - go (Just cap) = liftIO $ requestTahoe hdl "get" [Param cap, File d] + go Nothing = giveup "tahoe capability is not known" + go (Just cap) = unlessM (liftIO $ requestTahoe hdl "get" [Param cap, File d]) $ + giveup "tahoe failed to reteieve content" remove :: Key -> Annex Bool remove _k = do diff --git a/Remote/Web.hs b/Remote/Web.hs index 93f0bd2397..01439d5b8d 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -52,7 +52,7 @@ gen r _ rc gc rs = do , name = Git.repoDescribe r , storeKey = uploadKey , retrieveKeyFile = downloadKey - , retrieveKeyFileCheap = downloadKeyCheap + , retrieveKeyFileCheap = Nothing -- HttpManagerRestricted is used here, so this is -- secure. , retrievalSecurityPolicy = RetrievalAllKeysSecure @@ -80,22 +80,22 @@ gen r _ rc gc rs = do , remoteStateHandle = rs } -downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) -downloadKey key _af dest p = unVerified $ get =<< getWebUrls key +downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification +downloadKey key _af dest p = do + get =<< getWebUrls key + return UnVerified where - get [] = do - warning "no known url" - return False - get urls = untilTrue urls $ \u -> do - let (u', downloader) = getDownloader u - case downloader of - YoutubeDownloader -> do - showOutput - youtubeDlTo key u' dest - _ -> Url.withUrlOptions $ downloadUrl key p [u'] dest - -downloadKeyCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool -downloadKeyCheap _ _ _ = return False + get [] = giveup "no known url" + get urls = do + r <- untilTrue urls $ \u -> do + let (u', downloader) = getDownloader u + case downloader of + YoutubeDownloader -> do + showOutput + youtubeDlTo key u' dest + _ -> Url.withUrlOptions $ downloadUrl key p [u'] dest + unless r $ + giveup "download failed" uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex () uploadKey _ _ _ = giveup "upload to web not supported" diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 876ce5e41c..b1c3c2004d 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -84,8 +84,8 @@ gen r u rc gc rs = do , cost = cst , name = Git.repoDescribe r , storeKey = storeKeyDummy - , retrieveKeyFile = retreiveKeyFileDummy - , retrieveKeyFileCheap = retrieveCheap + , retrieveKeyFile = retrieveKeyFileDummy + , retrieveKeyFileCheap = Nothing -- HttpManagerRestricted is used here, so this is -- secure. , retrievalSecurityPolicy = RetrievalAllKeysSecure @@ -162,9 +162,6 @@ finalizeStore dav tmp dest = do maybe noop (void . mkColRecursive) (locationParent dest) moveDAV (baseURL dav) tmp dest -retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool -retrieveCheap _ _ _ = return False - retrieve :: DavHandleVar -> ChunkConfig -> Retriever retrieve hv cc = fileRetriever $ \d k p -> withDavHandle hv $ \dav -> case cc of diff --git a/Types/Remote.hs b/Types/Remote.hs index d1ba9b4e8b..f4cfe83da3 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -89,10 +89,12 @@ data RemoteA a = Remote -- Retrieves a key's contents to a file. -- (The MeterUpdate does not need to be used if it writes -- sequentially to the file.) - , retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> a (Bool, Verification) + -- Throws exception on failure. + , retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> a Verification -- Retrieves a key's contents to a tmp file, if it can be done cheaply. -- It's ok to create a symlink or hardlink. - , retrieveKeyFileCheap :: Key -> AssociatedFile -> FilePath -> a Bool + -- Throws exception on failure. + , retrieveKeyFileCheap :: Maybe (Key -> AssociatedFile -> FilePath -> a ()) -- Security policy for reteiving keys from this remote. , retrievalSecurityPolicy :: RetrievalSecurityPolicy -- Removes a key's contents (succeeds if the contents are not present) @@ -186,7 +188,7 @@ data Verification -- ^ Content likely to have been altered during transfer, -- verify even if verification is normally disabled -unVerified :: Monad m => m Bool -> m (Bool, Verification) +unVerified :: Monad m => m a -> m (a, Verification) unVerified a = do ok <- a return (ok, UnVerified) diff --git a/Types/StoreRetrieve.hs b/Types/StoreRetrieve.hs index 9512f196ff..295c589a22 100644 --- a/Types/StoreRetrieve.hs +++ b/Types/StoreRetrieve.hs @@ -28,7 +28,7 @@ type Storer = Key -> ContentSource -> MeterUpdate -> Annex () -- Action that retrieves a Key's content from a remote, passing it to a -- callback, which will fully consume the content before returning. -- Throws exception if key is not present, or remote is not accessible. -type Retriever = Key -> MeterUpdate -> (ContentSource -> Annex Bool) -> Annex Bool +type Retriever = Key -> MeterUpdate -> (ContentSource -> Annex ()) -> Annex () -- Action that removes a Key's content from a remote. -- Succeeds if key is already not present; never throws exceptions.