make storeExport throw exceptions
This commit is contained in:
Joey Hess
parent
dc7dc1e179
commit
4814b444dd
11 changed files with 99 additions and 105 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ->
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
29
Remote/S3.hs
29
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
--
|
||||
|
|
|
|||
Loading…
Reference in a new issue