change retrieveExport and getKey to throw exception
retrieveExport is part of ongoing transition to make remote methods throw exceptions, rather than silently hide them. getKey very rarely fails, and when it does it's always for the same reason (user configured annex.backend to url for some reason). So, this will avoid dealing with Nothing everywhere it's used. This commit was sponsored by Ilya Shlyakhter on Patreon.
This commit is contained in:
Joey Hess
parent
4814b444dd
commit
3334d3831b
23 changed files with 151 additions and 152 deletions
|
|
@ -186,17 +186,20 @@ store'' serial dest src canoverwrite = checkAdbInPath False $ do
|
|||
retrieve :: AndroidSerial -> AndroidPath -> Retriever
|
||||
retrieve serial adir = fileRetriever $ \dest k _p ->
|
||||
let src = androidLocation adir k
|
||||
in unlessM (retrieve' serial src dest) $
|
||||
giveup "adb pull failed"
|
||||
in retrieve' serial src dest
|
||||
|
||||
retrieve' :: AndroidSerial -> AndroidPath -> FilePath -> Annex Bool
|
||||
retrieve' serial src dest = checkAdbInPath False $ do
|
||||
showOutput -- make way for adb pull output
|
||||
liftIO $ boolSystem "adb" $ mkAdbCommand serial
|
||||
[ Param "pull"
|
||||
, File $ fromAndroidPath src
|
||||
, File dest
|
||||
]
|
||||
retrieve' :: AndroidSerial -> AndroidPath -> FilePath -> Annex ()
|
||||
retrieve' serial src dest =
|
||||
unlessM go $
|
||||
giveup "adb pull failed"
|
||||
where
|
||||
go = checkAdbInPath False $ do
|
||||
showOutput -- make way for adb pull output
|
||||
liftIO $ boolSystem "adb" $ mkAdbCommand serial
|
||||
[ Param "pull"
|
||||
, File $ fromAndroidPath src
|
||||
, File dest
|
||||
]
|
||||
|
||||
remove :: AndroidSerial -> AndroidPath -> Remover
|
||||
remove serial adir k =
|
||||
|
|
@ -241,7 +244,7 @@ storeExportM serial adir src _k loc _p =
|
|||
where
|
||||
dest = androidExportLocation adir loc
|
||||
|
||||
retrieveExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
|
||||
retrieveExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex ()
|
||||
retrieveExportM serial adir _k loc dest _p = retrieve' serial src dest
|
||||
where
|
||||
src = androidExportLocation adir loc
|
||||
|
|
@ -305,17 +308,14 @@ listImportableContentsM serial adir =
|
|||
-- connection is resonably fast, it's probably as good as
|
||||
-- git's handling of similar situations with files being modified while
|
||||
-- it's updating the working tree for a merge.
|
||||
retrieveExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> ExportLocation -> ContentIdentifier -> FilePath -> Annex (Maybe Key) -> MeterUpdate -> Annex (Maybe Key)
|
||||
retrieveExportWithContentIdentifierM serial adir loc cid dest mkkey _p = catchDefaultIO Nothing $
|
||||
ifM (retrieve' serial src dest)
|
||||
( do
|
||||
k <- mkkey
|
||||
currcid <- getExportContentIdentifier serial adir loc
|
||||
return $ if currcid == Right (Just cid)
|
||||
then k
|
||||
else Nothing
|
||||
, return Nothing
|
||||
)
|
||||
retrieveExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> ExportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key
|
||||
retrieveExportWithContentIdentifierM serial adir loc cid dest mkkey _p = do
|
||||
retrieve' serial src dest
|
||||
k <- mkkey
|
||||
currcid <- getExportContentIdentifier serial adir loc
|
||||
if currcid == Right (Just cid)
|
||||
then return k
|
||||
else giveup "the file on the android device has changed"
|
||||
where
|
||||
src = androidExportLocation adir loc
|
||||
|
||||
|
|
|
|||
|
|
@ -273,10 +273,9 @@ storeExportM d src _k loc p = liftIO $ do
|
|||
where
|
||||
dest = exportPath d loc
|
||||
|
||||
retrieveExportM :: FilePath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
|
||||
retrieveExportM d _k loc dest p = liftIO $ catchBoolIO $ do
|
||||
withMeteredFile src p (L.writeFile dest)
|
||||
return True
|
||||
retrieveExportM :: FilePath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex ()
|
||||
retrieveExportM d _k loc dest p =
|
||||
liftIO $ withMeteredFile src p (L.writeFile dest)
|
||||
where
|
||||
src = exportPath d loc
|
||||
|
||||
|
|
@ -346,9 +345,9 @@ mkContentIdentifier f st =
|
|||
fmap (ContentIdentifier . encodeBS . showInodeCache)
|
||||
<$> toInodeCache noTSDelta f st
|
||||
|
||||
retrieveExportWithContentIdentifierM :: FilePath -> ExportLocation -> ContentIdentifier -> FilePath -> Annex (Maybe Key) -> MeterUpdate -> Annex (Maybe Key)
|
||||
retrieveExportWithContentIdentifierM :: FilePath -> ExportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key
|
||||
retrieveExportWithContentIdentifierM dir loc cid dest mkkey p =
|
||||
catchDefaultIO Nothing $ precheck $ docopy postcheck
|
||||
precheck $ docopy postcheck
|
||||
where
|
||||
f = exportPath dir loc
|
||||
|
||||
|
|
@ -404,7 +403,7 @@ retrieveExportWithContentIdentifierM dir loc cid dest mkkey p =
|
|||
|
||||
comparecid cont currcid
|
||||
| currcid == Just cid = cont
|
||||
| otherwise = return Nothing
|
||||
| otherwise = giveup "file content has changed"
|
||||
|
||||
storeExportWithContentIdentifierM :: FilePath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier
|
||||
storeExportWithContentIdentifierM dir src _k loc overwritablecids p = do
|
||||
|
|
|
|||
|
|
@ -291,20 +291,17 @@ storeExportM external f k loc p = either giveup return =<< go
|
|||
_ -> Nothing
|
||||
req sk = TRANSFEREXPORT Upload sk f
|
||||
|
||||
retrieveExportM :: External -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
|
||||
retrieveExportM external k loc d p = safely $
|
||||
handleRequestExport external loc req k (Just p) $ \resp -> case resp of
|
||||
TRANSFER_SUCCESS Download k'
|
||||
| k == k' -> result True
|
||||
TRANSFER_FAILURE Download k' errmsg
|
||||
| k == k' -> Just $ do
|
||||
warning $ respErrorMessage "TRANSFER" errmsg
|
||||
return (Result False)
|
||||
UNSUPPORTED_REQUEST -> Just $ do
|
||||
warning "TRANSFEREXPORT not implemented by external special remote"
|
||||
return (Result False)
|
||||
_ -> Nothing
|
||||
retrieveExportM :: External -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex ()
|
||||
retrieveExportM external k loc d p = either giveup return =<< go
|
||||
where
|
||||
go = handleRequestExport external loc req k (Just p) $ \resp -> case resp of
|
||||
TRANSFER_SUCCESS Download k'
|
||||
| k == k' -> result $ Right ()
|
||||
TRANSFER_FAILURE Download k' errmsg
|
||||
| k == k' -> result $ Left $ respErrorMessage "TRANSFER" errmsg
|
||||
UNSUPPORTED_REQUEST ->
|
||||
result $ Left "TRANSFEREXPORT not implemented by external special remote"
|
||||
_ -> Nothing
|
||||
req sk = TRANSFEREXPORT Download sk d
|
||||
|
||||
checkPresentExportM :: External -> Key -> ExportLocation -> Annex Bool
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ instance HasExportUnsupported (ParsedRemoteConfig -> RemoteGitConfig -> Annex Bo
|
|||
instance HasExportUnsupported (ExportActions Annex) where
|
||||
exportUnsupported = ExportActions
|
||||
{ storeExport = nope
|
||||
, retrieveExport = \_ _ _ _ -> return False
|
||||
, retrieveExport = nope
|
||||
, checkPresentExport = \_ _ -> return False
|
||||
, removeExport = \_ _ -> return False
|
||||
, removeExportDirectory = Just $ \_ -> return False
|
||||
|
|
@ -56,7 +56,7 @@ instance HasImportUnsupported (ParsedRemoteConfig -> RemoteGitConfig -> Annex Bo
|
|||
instance HasImportUnsupported (ImportActions Annex) where
|
||||
importUnsupported = ImportActions
|
||||
{ listImportableContents = return Nothing
|
||||
, retrieveExportWithContentIdentifier = \_ _ _ _ _ -> return Nothing
|
||||
, retrieveExportWithContentIdentifier = nope
|
||||
, storeExportWithContentIdentifier = nope
|
||||
, removeExportWithContentIdentifier = \_ _ _ -> return False
|
||||
, removeExportDirectoryWhenEmpty = Just $ \_ -> return False
|
||||
|
|
@ -319,7 +319,6 @@ adjustExportImport r rs = case getRemoteConfigValue exportTreeField (config r) o
|
|||
, giveup "unknown export location"
|
||||
)
|
||||
(l:_) -> do
|
||||
unlessM (retrieveExport (exportActions r) k l dest p) $
|
||||
giveup "retrieving from export failed"
|
||||
retrieveExport (exportActions r) k l dest p
|
||||
return UnVerified
|
||||
| otherwise = giveup $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (fromKey keyVariety k)) ++ " backend"
|
||||
|
|
|
|||
|
|
@ -315,7 +315,7 @@ storeExportM o src _k loc meterupdate =
|
|||
basedest = fromRawFilePath (fromExportLocation loc)
|
||||
populatedest = liftIO . createLinkOrCopy src
|
||||
|
||||
retrieveExportM :: RsyncOpts -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
|
||||
retrieveExportM :: RsyncOpts -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex ()
|
||||
retrieveExportM o _k loc dest p = rsyncRetrieve o [rsyncurl] dest (Just p)
|
||||
where
|
||||
rsyncurl = mkRsyncUrl o (fromRawFilePath (fromExportLocation loc))
|
||||
|
|
@ -367,9 +367,12 @@ withRsyncScratchDir a = do
|
|||
t <- fromRepo gitAnnexTmpObjectDir
|
||||
withTmpDirIn t "rsynctmp" a
|
||||
|
||||
rsyncRetrieve :: RsyncOpts -> [RsyncUrl] -> FilePath -> Maybe MeterUpdate -> Annex Bool
|
||||
rsyncRetrieve o rsyncurls dest meterupdate =
|
||||
showResumable $ untilTrue rsyncurls $ \u -> rsyncRemote Download o meterupdate
|
||||
rsyncRetrieve :: RsyncOpts -> [RsyncUrl] -> FilePath -> Maybe MeterUpdate -> Annex ()
|
||||
rsyncRetrieve o rsyncurls dest meterupdate =
|
||||
unlessM go $
|
||||
giveup "rsync failed"
|
||||
where
|
||||
go = showResumable $ untilTrue rsyncurls $ \u -> rsyncRemote Download o meterupdate
|
||||
-- use inplace when retrieving to support resuming
|
||||
[ Param "--inplace"
|
||||
, Param u
|
||||
|
|
@ -378,8 +381,7 @@ rsyncRetrieve o rsyncurls 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"
|
||||
rsyncRetrieve o (rsyncUrls o k) dest meterupdate
|
||||
|
||||
showResumable :: Annex Bool -> Annex Bool
|
||||
showResumable a = ifM a
|
||||
|
|
|
|||
41
Remote/S3.hs
41
Remote/S3.hs
|
|
@ -474,20 +474,16 @@ storeExportS3' hv r rs info magic f k loc p = withS3Handle hv $ \case
|
|||
setS3VersionID info rs k mvid
|
||||
return (metag, mvid)
|
||||
|
||||
retrieveExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
|
||||
retrieveExportS3 hv r info _k loc f p =
|
||||
catchNonAsync go (\e -> warning (show e) >> return False)
|
||||
where
|
||||
go = withS3Handle hv $ \case
|
||||
Just h -> do
|
||||
retrieveHelper info h (Left (T.pack exportloc)) f p
|
||||
return True
|
||||
retrieveExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex ()
|
||||
retrieveExportS3 hv r info _k loc f p = do
|
||||
withS3Handle hv $ \case
|
||||
Just h -> retrieveHelper info h (Left (T.pack exportloc)) f p
|
||||
Nothing -> case getPublicUrlMaker info of
|
||||
Nothing -> do
|
||||
warning $ needS3Creds (uuid r)
|
||||
return False
|
||||
Just geturl -> Url.withUrlOptions $
|
||||
Url.download p (geturl exportloc) f
|
||||
Just geturl -> either giveup return =<<
|
||||
Url.withUrlOptions
|
||||
(Url.download' p (geturl exportloc) f)
|
||||
Nothing -> giveup $ needS3Creds (uuid r)
|
||||
where
|
||||
exportloc = bucketExportLocation info loc
|
||||
|
||||
removeExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Key -> ExportLocation -> Annex Bool
|
||||
|
|
@ -634,21 +630,18 @@ mkImportableContentsVersioned info = build . groupfiles
|
|||
| otherwise =
|
||||
i : removemostrecent mtime rest
|
||||
|
||||
retrieveExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> ExportLocation -> ContentIdentifier -> FilePath -> Annex (Maybe Key) -> MeterUpdate -> Annex (Maybe Key)
|
||||
retrieveExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> ExportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key
|
||||
retrieveExportWithContentIdentifierS3 hv r rs info loc cid dest mkkey p = withS3Handle hv $ \case
|
||||
Nothing -> do
|
||||
warning $ needS3Creds (uuid r)
|
||||
return Nothing
|
||||
Just h -> flip catchNonAsync (\e -> warning (show e) >> return Nothing) $ do
|
||||
Just h -> do
|
||||
rewritePreconditionException $ retrieveHelper' h dest p $
|
||||
limitGetToContentIdentifier cid $
|
||||
S3.getObject (bucket info) o
|
||||
mk <- mkkey
|
||||
case (mk, extractContentIdentifier cid o) of
|
||||
(Just k, Right vid) ->
|
||||
setS3VersionID info rs k vid
|
||||
_ -> noop
|
||||
return mk
|
||||
k <- mkkey
|
||||
case extractContentIdentifier cid o of
|
||||
Right vid -> setS3VersionID info rs k vid
|
||||
Left _ -> noop
|
||||
return k
|
||||
Nothing -> giveup $ needS3Creds (uuid r)
|
||||
where
|
||||
o = T.pack $ bucketExportLocation info loc
|
||||
|
||||
|
|
|
|||
|
|
@ -213,12 +213,11 @@ storeExportDav hdl f k loc p = case exportLocation loc of
|
|||
storeHelper dav (keyTmpLocation k) dest reqbody
|
||||
Left err -> giveup err
|
||||
|
||||
retrieveExportDav :: DavHandleVar -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
|
||||
retrieveExportDav :: DavHandleVar -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex ()
|
||||
retrieveExportDav hdl _k loc d p = case exportLocation loc of
|
||||
Right src -> withDavHandle' hdl $ \mh -> runExport' mh $ \_dav -> do
|
||||
Right src -> withDavHandle hdl $ \h -> runExport h $ \_dav ->
|
||||
retrieveHelper src d p
|
||||
return True
|
||||
Left _err -> return False
|
||||
Left err -> giveup err
|
||||
|
||||
checkPresentExportDav :: DavHandleVar -> Remote -> Key -> ExportLocation -> Annex Bool
|
||||
checkPresentExportDav hdl _ _k loc = case exportLocation loc of
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue