From 4814b444dd8b96f01ba3460ebe9023f7dcbb5509 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 15 May 2020 12:17:15 -0400 Subject: [PATCH] make storeExport throw exceptions --- Command/Export.hs | 7 +++-- Command/TestRemote.hs | 6 ++--- Remote/Adb.hs | 20 ++++++++------- Remote/Directory.hs | 48 +++++++++++++++++------------------ Remote/External.hs | 21 +++++++-------- Remote/Helper/ExportImport.hs | 25 ++++++++---------- Remote/Helper/ReadOnly.hs | 11 ++++---- Remote/Rsync.hs | 4 +-- Remote/S3.hs | 29 +++++++++------------ Remote/WebDAV.hs | 26 +++++++++---------- Types/Remote.hs | 7 +++-- 11 files changed, 99 insertions(+), 105 deletions(-) diff --git a/Command/Export.hs b/Command/Export.hs index 97c9014f51..b95d669c74 100644 --- a/Command/Export.hs +++ b/Command/Export.hs @@ -20,6 +20,7 @@ import qualified Git.Ref import Git.Types import Git.FilePath import Git.Sha +import qualified Remote import Types.Remote import Types.Export import Annex.Export @@ -280,7 +281,8 @@ performExport r db ek af contentsha loc allfilledvar = do let rollback = void $ performUnexport r db [ek] loc sendAnnex k rollback $ \f -> - storer f k loc pm + Remote.action $ + storer f k loc pm , do showNote "not available" return False @@ -291,7 +293,8 @@ performExport r db ek af contentsha loc allfilledvar = do b <- catObject contentsha liftIO $ L.hPut h b liftIO $ hClose h - storer tmp sha1k loc nullMeterUpdate + Remote.action $ + storer tmp sha1k loc nullMeterUpdate let failedsend = liftIO $ modifyMVar_ allfilledvar (pure . const (AllFilled False)) case sent of Right True -> next $ cleanupExport r db ek loc True diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index 646dbe031c..d7b1950e68 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -287,15 +287,15 @@ testExportTree runannex mkr mkk1 mkk2 = , check "remove export when not present" $ \ea k1 _k2 -> removeexport ea k1 , check "store export" $ \ea k1 _k2 -> - storeexport ea k1 + isRight <$> tryNonAsync (storeexport ea k1) , check "check present export after store" $ \ea k1 _k2 -> checkpresentexport ea k1 , check "store export when already present" $ \ea k1 _k2 -> - storeexport ea k1 + isRight <$> tryNonAsync (storeexport ea k1) , check "retrieve export" $ \ea k1 _k2 -> retrieveexport ea k1 , check "store new content to export" $ \ea _k1 k2 -> - storeexport ea k2 + isRight <$> tryNonAsync (storeexport ea k2) , check "check present export after store of new content" $ \ea _k1 k2 -> checkpresentexport ea k2 , check "retrieve export new content" $ \ea _k1 k2 -> diff --git a/Remote/Adb.hs b/Remote/Adb.hs index 9432b3cea8..4cd1337f61 100644 --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -234,8 +234,10 @@ androidHashDir adir k = AndroidPath $ where hdir = replace [pathSeparator] "/" (fromRawFilePath (hashDirLower def k)) -storeExportM :: AndroidSerial -> AndroidPath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool -storeExportM serial adir src _k loc _p = store' serial dest src +storeExportM :: AndroidSerial -> AndroidPath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () +storeExportM serial adir src _k loc _p = + unlessM (store' serial dest src) $ + giveup "adb failed" where dest = androidExportLocation adir loc @@ -317,19 +319,19 @@ retrieveExportWithContentIdentifierM serial adir loc cid dest mkkey _p = catchDe where src = androidExportLocation adir loc -storeExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Either String ContentIdentifier) +storeExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier storeExportWithContentIdentifierM serial adir src _k loc overwritablecids _p = -- Check if overwrite is safe before sending, because sending the -- file is expensive and don't want to do it unncessarily. ifM checkcanoverwrite ( ifM (store'' serial dest src checkcanoverwrite) - ( getExportContentIdentifier serial adir loc >>= return . \case - Right (Just cid) -> Right cid - Right Nothing -> Left "adb failed to store file" - Left _ -> Left "unable to get content identifier for file stored on adtb" - , return $ Left "adb failed to store file" + ( getExportContentIdentifier serial adir loc >>= \case + Right (Just cid) -> return cid + Right Nothing -> giveup "adb failed to store file" + Left _ -> giveup "unable to get content identifier for file stored by adb" + , giveup "adb failed to store file" ) - , return $ Left "unsafe to overwrite file" + , giveup "unsafe to overwrite file" ) where dest = androidExportLocation adir loc diff --git a/Remote/Directory.hs b/Remote/Directory.hs index ac9685215d..8d6fa62902 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -264,13 +264,12 @@ checkPresentGeneric' d check = ifM check ) ) -storeExportM :: FilePath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool -storeExportM d src _k loc p = liftIO $ catchBoolIO $ do +storeExportM :: FilePath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () +storeExportM d src _k loc p = liftIO $ do createDirectoryUnder d (takeDirectory dest) -- Write via temp file so that checkPresentGeneric will not -- see it until it's fully stored. viaTmp (\tmp () -> withMeteredFile src p (L.writeFile tmp)) dest () - return True where dest = exportPath d loc @@ -407,37 +406,36 @@ retrieveExportWithContentIdentifierM dir loc cid dest mkkey p = | currcid == Just cid = cont | otherwise = return Nothing -storeExportWithContentIdentifierM :: FilePath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Either String ContentIdentifier) -storeExportWithContentIdentifierM dir src _k loc overwritablecids p = - catchNonAsync go (return . Left . show) +storeExportWithContentIdentifierM :: FilePath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier +storeExportWithContentIdentifierM dir src _k loc overwritablecids p = do + liftIO $ createDirectoryUnder dir destdir + withTmpFileIn destdir template $ \tmpf tmph -> do + liftIO $ withMeteredFile src p (L.hPut tmph) + liftIO $ hFlush tmph + liftIO $ hClose tmph + liftIO (getFileStatus tmpf) >>= liftIO . mkContentIdentifier tmpf >>= \case + Nothing -> giveup "unable to generate content identifier" + Just newcid -> do + checkExportContent dir loc + (newcid:overwritablecids) + (giveup "unsafe to overwrite file") + (const $ liftIO $ rename tmpf dest) + return newcid where - go = do - liftIO $ createDirectoryUnder dir destdir - withTmpFileIn destdir template $ \tmpf tmph -> do - liftIO $ withMeteredFile src p (L.hPut tmph) - liftIO $ hFlush tmph - liftIO $ hClose tmph - liftIO (getFileStatus tmpf) >>= liftIO . mkContentIdentifier tmpf >>= \case - Nothing -> - return $ Left "unable to generate content identifier" - Just newcid -> - checkExportContent dir loc (newcid:overwritablecids) (Left "unsafe to overwrite file") $ const $ do - liftIO $ rename tmpf dest - return (Right newcid) dest = exportPath dir loc (destdir, base) = splitFileName dest template = relatedTemplate (base ++ ".tmp") removeExportWithContentIdentifierM :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool removeExportWithContentIdentifierM dir k loc removeablecids = - checkExportContent dir loc removeablecids False $ \case + checkExportContent dir loc removeablecids (return False) $ \case DoesNotExist -> return True KnownContentIdentifier -> removeExportM dir k loc checkPresentExportWithContentIdentifierM :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool checkPresentExportWithContentIdentifierM dir _k loc knowncids = checkPresentGeneric' dir $ - checkExportContent dir loc knowncids False $ \case + checkExportContent dir loc knowncids (return False) $ \case DoesNotExist -> return False KnownContentIdentifier -> return True @@ -458,18 +456,18 @@ data CheckResult = DoesNotExist | KnownContentIdentifier -- -- So, it suffices to check if the destination file's current -- content is known, and immediately run the callback. -checkExportContent :: FilePath -> ExportLocation -> [ContentIdentifier] -> a -> (CheckResult -> Annex a) -> Annex a +checkExportContent :: FilePath -> ExportLocation -> [ContentIdentifier] -> Annex a -> (CheckResult -> Annex a) -> Annex a checkExportContent dir loc knowncids unsafe callback = tryWhenExists (liftIO $ getFileStatus dest) >>= \case Just destst - | not (isRegularFile destst) -> return unsafe + | not (isRegularFile destst) -> unsafe | otherwise -> catchDefaultIO Nothing (liftIO $ mkContentIdentifier dest destst) >>= \case Just destcid | destcid `elem` knowncids -> callback KnownContentIdentifier -- dest exists with other content - | otherwise -> return unsafe + | otherwise -> unsafe -- should never happen - Nothing -> return unsafe + Nothing -> unsafe -- dest does not exist Nothing -> callback DoesNotExist where diff --git a/Remote/External.hs b/Remote/External.hs index 6e8b8e9a5f..03f0e59f80 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -279,19 +279,16 @@ whereisKeyM external k = handleRequestKey external WHEREIS k Nothing $ \resp -> UNSUPPORTED_REQUEST -> result [] _ -> Nothing -storeExportM :: External -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool -storeExportM external f k loc p = safely $ - handleRequestExport external loc req k (Just p) $ \resp -> case resp of - TRANSFER_SUCCESS Upload k' | k == k' -> result True - TRANSFER_FAILURE Upload 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 +storeExportM :: External -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () +storeExportM external f k loc p = either giveup return =<< go where + go = handleRequestExport external loc req k (Just p) $ \resp -> case resp of + TRANSFER_SUCCESS Upload k' | k == k' -> result $ Right () + TRANSFER_FAILURE Upload k' errmsg | k == k' -> + result $ Left $ respErrorMessage "TRANSFER" errmsg + UNSUPPORTED_REQUEST -> + result $ Left "TRANSFEREXPORT not implemented by external special remote" + _ -> Nothing req sk = TRANSFEREXPORT Upload sk f retrieveExportM :: External -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs index 87c3f58da4..a3338bf77a 100644 --- a/Remote/Helper/ExportImport.hs +++ b/Remote/Helper/ExportImport.hs @@ -36,15 +36,15 @@ instance HasExportUnsupported (ParsedRemoteConfig -> RemoteGitConfig -> Annex Bo instance HasExportUnsupported (ExportActions Annex) where exportUnsupported = ExportActions - { storeExport = \_ _ _ _ -> do - warning "store export is unsupported" - return False + { storeExport = nope , retrieveExport = \_ _ _ _ -> return False , checkPresentExport = \_ _ -> return False , removeExport = \_ _ -> return False , removeExportDirectory = Just $ \_ -> return False , renameExport = \_ _ _ -> return Nothing } + where + nope = giveup "export not supported" -- | Use for remotes that do not support imports. class HasImportUnsupported a where @@ -57,11 +57,13 @@ instance HasImportUnsupported (ImportActions Annex) where importUnsupported = ImportActions { listImportableContents = return Nothing , retrieveExportWithContentIdentifier = \_ _ _ _ _ -> return Nothing - , storeExportWithContentIdentifier = \_ _ _ _ _ -> return (Left "import not supported") + , storeExportWithContentIdentifier = nope , removeExportWithContentIdentifier = \_ _ _ -> return False , removeExportDirectoryWhenEmpty = Just $ \_ -> return False , checkPresentExportWithContentIdentifier = \_ _ _ -> return False } + where + nope = giveup "import not supported" exportIsSupported :: ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool exportIsSupported = \_ _ -> return True @@ -151,16 +153,11 @@ adjustExportImport r rs = case getRemoteConfigValue exportTreeField (config r) o oldks <- liftIO $ Export.getExportTreeKey exportdb loc oldcids <- liftIO $ concat <$> mapM (ContentIdentifier.getContentIdentifiers db rs) oldks - storeExportWithContentIdentifier (importActions r') f k loc oldcids p >>= \case - Left err -> do - warning err - return False - Right newcid -> do - withExclusiveLock gitAnnexContentIdentifierLock $ do - liftIO $ ContentIdentifier.recordContentIdentifier db rs newcid k - liftIO $ ContentIdentifier.flushDbQueue db - recordContentIdentifier rs newcid k - return True + newcid <- storeExportWithContentIdentifier (importActions r') f k loc oldcids p + withExclusiveLock gitAnnexContentIdentifierLock $ do + liftIO $ ContentIdentifier.recordContentIdentifier db rs newcid k + liftIO $ ContentIdentifier.flushDbQueue db + recordContentIdentifier rs newcid k , removeExport = \k loc -> removeExportWithContentIdentifier (importActions r') k loc =<< keycids k diff --git a/Remote/Helper/ReadOnly.hs b/Remote/Helper/ReadOnly.hs index f6ae84887c..b343930d8b 100644 --- a/Remote/Helper/ReadOnly.hs +++ b/Remote/Helper/ReadOnly.hs @@ -53,8 +53,8 @@ readonlyRemoveKey _ = readonlyFail readonlyStorer :: Storer readonlyStorer _ _ _ = readonlyFail -readonlyStoreExport :: FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool -readonlyStoreExport _ _ _ _ = readonlyFail' +readonlyStoreExport :: FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () +readonlyStoreExport _ _ _ _ = readonlyFail readonlyRemoveExport :: Key -> ExportLocation -> Annex Bool readonlyRemoveExport _ _ = readonlyFail' @@ -65,14 +65,13 @@ readonlyRemoveExportDirectory _ = readonlyFail' readonlyRenameExport :: Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) readonlyRenameExport _ _ _ = return Nothing -readonlyStoreExportWithContentIdentifier :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Either String ContentIdentifier) -readonlyStoreExportWithContentIdentifier _ _ _ _ _ = - return $ Left readonlyWarning +readonlyStoreExportWithContentIdentifier :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier +readonlyStoreExportWithContentIdentifier _ _ _ _ _ = readonlyFail readonlyRemoveExportWithContentIdentifier :: Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool readonlyRemoveExportWithContentIdentifier _ _ _ = readonlyFail' -readonlyFail :: Annex () +readonlyFail :: Annex a readonlyFail = giveup readonlyWarning readonlyFail' :: Annex Bool diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 6b599f4fed..862a235bec 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -308,9 +308,9 @@ checkPresentGeneric o rsyncurls = do proc "rsync" $ toCommand $ opts ++ [Param u] return True -storeExportM :: RsyncOpts -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool +storeExportM :: RsyncOpts -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () storeExportM o src _k loc meterupdate = - storeGeneric' o meterupdate basedest populatedest + storeGeneric o meterupdate basedest populatedest where basedest = fromRawFilePath (fromExportLocation loc) populatedest = liftIO . createLinkOrCopy src diff --git a/Remote/S3.hs b/Remote/S3.hs index 86fb713e3c..32012c7e4b 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -460,22 +460,19 @@ checkKeyHelper' info h o limit = liftIO $ runResourceT $ do where req = limit $ S3.headObject (bucket info) o -storeExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool -storeExportS3 hv r rs info magic f k loc p = fst - <$> storeExportS3' hv r rs info magic f k loc p +storeExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () +storeExportS3 hv r rs info magic f k loc p = void $ storeExportS3' hv r rs info magic f k loc p -storeExportS3' :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex (Bool, (Maybe S3Etag, Maybe S3VersionID)) +storeExportS3' :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex (Maybe S3Etag, Maybe S3VersionID) storeExportS3' hv r rs info magic f k loc p = withS3Handle hv $ \case - Just h -> catchNonAsync (go h) (\e -> warning (show e) >> return (False, (Nothing, Nothing))) - Nothing -> do - warning $ needS3Creds (uuid r) - return (False, (Nothing, Nothing)) + Just h -> go h + Nothing -> giveup $ needS3Creds (uuid r) where go h = do let o = T.pack $ bucketExportLocation info loc (metag, mvid) <- storeHelper info h magic f o p setS3VersionID info rs k mvid - return (True, (metag, mvid)) + return (metag, mvid) retrieveExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool retrieveExportS3 hv r info _k loc f p = @@ -671,7 +668,7 @@ rewritePreconditionException a = catchJust (Url.matchStatusCodeException want) a -- -- When the bucket is not versioned, data loss can result. -- This is why that configuration requires --force to enable. -storeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Either String ContentIdentifier) +storeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier storeExportWithContentIdentifierS3 hv r rs info magic src k loc _overwritablecids p | versioning info = go -- FIXME Actual aws version that supports getting Etag for a store @@ -680,18 +677,16 @@ storeExportWithContentIdentifierS3 hv r rs info magic src k loc _overwritablecid #if MIN_VERSION_aws(0,99,0) | otherwise = go #else - | otherwise = return $ - Left "git-annex is built with too old a version of the aws library to support this operation" + | otherwise = giveup "git-annex is built with too old a version of the aws library to support this operation" #endif where go = storeExportS3' hv r rs info magic src k loc p >>= \case - (False, _) -> return $ Left "failed to store content in S3 bucket" - (True, (_, Just vid)) -> return $ Right $ + (_, Just vid) -> return $ mkS3VersionedContentIdentifier vid - (True, (Just etag, Nothing)) -> return $ Right $ + (Just etag, Nothing) -> return $ mkS3UnversionedContentIdentifier etag - (True, (Nothing, Nothing)) -> - return $ Left "did not get ETag for store to S3 bucket" + (Nothing, Nothing) -> + giveup "did not get ETag for store to S3 bucket" -- Does not guarantee that the removed object has the content identifier, -- but when the bucket is versioned, the removed object content can still diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 441c19b724..ff89ce3a87 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -206,19 +206,16 @@ checkKey hv r chunkconfig k = withDavHandle hv $ \dav -> do existsDAV (keyLocation k) either giveup return v -storeExportDav :: DavHandleVar -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool +storeExportDav :: DavHandleVar -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () storeExportDav hdl f k loc p = case exportLocation loc of - Right dest -> withDavHandle' hdl $ \mh -> runExport mh $ \dav -> do + Right dest -> withDavHandle hdl $ \h -> runExport h $ \dav -> do reqbody <- liftIO $ httpBodyStorer f p storeHelper dav (keyTmpLocation k) dest reqbody - return True - Left err -> do - warning err - return False + Left err -> giveup err retrieveExportDav :: DavHandleVar -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool retrieveExportDav hdl _k loc d p = case exportLocation loc of - Right src -> withDavHandle' hdl $ \mh -> runExport mh $ \_dav -> do + Right src -> withDavHandle' hdl $ \mh -> runExport' mh $ \_dav -> do retrieveHelper src d p return True Left _err -> return False @@ -234,7 +231,7 @@ checkPresentExportDav hdl _ _k loc = case exportLocation loc of removeExportDav :: DavHandleVar-> Key -> ExportLocation -> Annex Bool removeExportDav hdl _k loc = case exportLocation loc of - Right p -> withDavHandle' hdl $ \mh -> runExport mh $ \_dav -> + Right p -> withDavHandle' hdl $ \mh -> runExport' mh $ \_dav -> removeHelper p -- When the exportLocation is not legal for webdav, -- the content is certianly not stored there, so it's ok for @@ -244,7 +241,7 @@ removeExportDav hdl _k loc = case exportLocation loc of Left _err -> return True removeExportDirectoryDav :: DavHandleVar -> ExportDirectory -> Annex Bool -removeExportDirectoryDav hdl dir = withDavHandle' hdl $ \mh -> runExport mh $ \_dav -> do +removeExportDirectoryDav hdl dir = withDavHandle' hdl $ \mh -> runExport' mh $ \_dav -> do let d = fromRawFilePath $ fromExportDirectory dir debugDav $ "delContent " ++ d safely (inLocation d delContentM) @@ -258,7 +255,7 @@ renameExportDav hdl _k src dest = case (exportLocation src, exportLocation dest) -- so avoid renaming when using it. | boxComUrl `isPrefixOf` baseURL h -> return Nothing | otherwise -> do - v <- runExport (Right h) $ \dav -> do + v <- runExport' (Right h) $ \dav -> do maybe noop (void . mkColRecursive) (locationParent destl) moveDAV (baseURL dav) srcl destl return True @@ -266,9 +263,12 @@ renameExportDav hdl _k src dest = case (exportLocation src, exportLocation dest) Left _e -> return (Just False) _ -> return (Just False) -runExport :: Either String DavHandle -> (DavHandle -> DAVT IO Bool) -> Annex Bool -runExport (Left _e) _ = return False -runExport (Right h) a = fromMaybe False <$> liftIO (goDAV h $ safely (a h)) +runExport' :: Either String DavHandle -> (DavHandle -> DAVT IO Bool) -> Annex Bool +runExport' (Left _e) _ = return False +runExport' (Right h) a = fromMaybe False <$> liftIO (goDAV h $ safely (a h)) + +runExport :: DavHandle -> (DavHandle -> DAVT IO a) -> Annex a +runExport h a = liftIO (goDAV h (a h)) configUrl :: ParsedRemoteConfig -> Maybe URLString configUrl c = fixup <$> getRemoteConfigValue urlField c diff --git a/Types/Remote.hs b/Types/Remote.hs index 0bd7550a4c..4a946d808c 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -231,7 +231,8 @@ data ExportActions a = ExportActions -- Exports content to an ExportLocation. -- The exported file should not appear to be present on the remote -- until all of its contents have been transferred. - { storeExport :: FilePath -> Key -> ExportLocation -> MeterUpdate -> a Bool + -- Throws exception on failure. + { storeExport :: FilePath -> Key -> ExportLocation -> MeterUpdate -> a () -- Retrieves exported content to a file. -- (The MeterUpdate does not need to be used if it writes -- sequentially to the file.) @@ -293,6 +294,8 @@ data ImportActions a = ImportActions -- needs to make sure that the ContentIdentifier it returns -- corresponds to what it wrote, not to what some other writer -- wrote. + -- + -- Throws exception on failure. , storeExportWithContentIdentifier :: FilePath -> Key @@ -300,7 +303,7 @@ data ImportActions a = ImportActions -- old content that it's safe to overwrite -> [ContentIdentifier] -> MeterUpdate - -> a (Either String ContentIdentifier) + -> a ContentIdentifier -- This is used rather than removeExport when a special remote -- supports imports. --