mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

make retrieveKeyFile and retrieveKeyFileCheap throw exceptions

Browse source 
Converted retrieveKeyFileCheap to a Maybe, to avoid needing to throw a
exception when a remote doesn't support it.
This commit is contained in:
Joey Hess 2020-05-13 17:05:56 -04:00
commit d9c7f81ba4
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
32 changed files with 247 additions and 245 deletions
Download patch file Download diff file Expand all files Collapse all files

2
CHANGELOG
View file

@ -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 <id@joeyh.name> Mon, 04 May 2020 12:46:11 -0400

10
Command/AddUrl.hs
View file

@ -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

10
Command/Fsck.hs
View file

@ -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 =

6
Command/Get.hs
View file

@ -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

6
Command/Move.hs
View file

@ -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

17
Command/TestRemote.hs
View file

@ -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 $

14
Command/TransferKey.hs
View file

@ -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

6
Command/TransferKeys.hs
View file

@ -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.

4
Remote/Adb.hs
View file

@ -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

18
Remote/BitTorrent.hs
View file

@ -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"

7
Remote/Bup.hs
View file

@ -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.
-

7
Remote/Ddar.hs
View file

@ -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'

18
Remote/Directory.hs
View file

@ -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

4
Remote/External.hs
View file

@ -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

6
Remote/GCrypt.hs
View file

@ -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

78
Remote/Git.hs
View file

@ -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. -}

7
Remote/GitLFS.hs
View file

@ -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"

34
Remote/Glacier.hs
View file

@ -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

31
Remote/Helper/Chunked.hs
View file

@ -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

37
Remote/Helper/ExportImport.hs
View file

@ -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"

4
Remote/Helper/Hooks.hs
View file

@ -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
}

8
Remote/Helper/P2P.hs
View file

@ -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)

59
Remote/Helper/Special.hs
View file

@ -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

7
Remote/Hook.hs
View file

@ -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

2
Remote/P2P.hs
View file

@ -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

21
Remote/Rsync.hs
View file

@ -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

7
Remote/S3.hs
View file

@ -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 $

13
Remote/Tahoe.hs
View file

@ -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

32
Remote/Web.hs
View file

@ -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"

7
Remote/WebDAV.hs
View file

@ -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

8
Types/Remote.hs
View file

@ -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)

2
Types/StoreRetrieve.hs
View file

@ -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.