purify exportActions
Purifying exportActions will allow introspecting and modifying it, which is needed to add progress bar display to it. Only S3 and WebDAV ran an Annex action while constructing ExportActions. There was a small performance gain from them doing that, since a resource was able to be prepared and reused for multiple actions by Command.Export. As seen in commit809cfbbd8aand5d394023ebS3 and WebDAV actually create a new handle for each access in normal, non-export use. It doesn't seem worth making export use of them marginally more efficient than normal use. It would be better to do that work upfront when constructing the remote. Or perhaps use a MVar to cache a handle. This commit was sponsored by Nick Piper on Patreon.
This commit is contained in:
Joey Hess
parent
5d394023eb
commit
9cebfd7002
11 changed files with 143 additions and 148 deletions
|
|
@ -82,16 +82,15 @@ seek o = do
|
|||
inRepo (Git.Ref.tree (exportTreeish o))
|
||||
withExclusiveLock (gitAnnexExportLock (uuid r)) $ do
|
||||
db <- openDb (uuid r)
|
||||
ea <- exportActions r
|
||||
changeExport r ea db new
|
||||
changeExport r db new
|
||||
unlessM (Annex.getState Annex.fast) $
|
||||
void $ fillExport r ea db new
|
||||
void $ fillExport r db new
|
||||
closeDb db
|
||||
|
||||
-- | Changes what's exported to the remote. Does not upload any new
|
||||
-- files, but does delete and rename files already exported to the remote.
|
||||
changeExport :: Remote -> ExportActions Annex -> ExportHandle -> Git.Ref -> CommandSeek
|
||||
changeExport r ea db new = do
|
||||
changeExport :: Remote -> ExportHandle -> Git.Ref -> CommandSeek
|
||||
changeExport r db new = do
|
||||
old <- getExport (uuid r)
|
||||
recordExportBeginning (uuid r) new
|
||||
|
||||
|
|
@ -100,7 +99,7 @@ changeExport r ea db new = do
|
|||
-- temp files. Diff from the incomplete tree to the new tree,
|
||||
-- and delete any temp files that the new tree can't use.
|
||||
let recover diff = commandAction $
|
||||
startRecoverIncomplete r ea db
|
||||
startRecoverIncomplete r db
|
||||
(Git.DiffTree.srcsha diff)
|
||||
(Git.DiffTree.file diff)
|
||||
forM_ (incompleteExportedTreeishes old) $ \incomplete ->
|
||||
|
|
@ -123,15 +122,15 @@ changeExport r ea db new = do
|
|||
seekdiffmap $ \(ek, (moldf, mnewf)) -> do
|
||||
case (moldf, mnewf) of
|
||||
(Just oldf, Just _newf) ->
|
||||
startMoveToTempName r ea db oldf ek
|
||||
startMoveToTempName r db oldf ek
|
||||
(Just oldf, Nothing) ->
|
||||
startUnexport' r ea db oldf ek
|
||||
startUnexport' r db oldf ek
|
||||
_ -> stop
|
||||
-- Rename from temp to new files.
|
||||
seekdiffmap $ \(ek, (moldf, mnewf)) ->
|
||||
case (moldf, mnewf) of
|
||||
(Just _oldf, Just newf) ->
|
||||
startMoveFromTempName r ea db ek newf
|
||||
startMoveFromTempName r db ek newf
|
||||
_ -> stop
|
||||
ts -> do
|
||||
warning "Export conflict detected. Different trees have been exported to the same special remote. Resolving.."
|
||||
|
|
@ -147,7 +146,7 @@ changeExport r ea db new = do
|
|||
-- Don't rename to temp, because the
|
||||
-- content is unknown; delete instead.
|
||||
mapdiff
|
||||
(\diff -> commandAction $ startUnexport r ea db (Git.DiffTree.file diff) (unexportboth diff))
|
||||
(\diff -> commandAction $ startUnexport r db (Git.DiffTree.file diff) (unexportboth diff))
|
||||
oldtreesha new
|
||||
updateExportTree db emptyTree new
|
||||
liftIO $ recordExportTreeCurrent db new
|
||||
|
|
@ -193,24 +192,24 @@ mkDiffMap old new db = do
|
|||
|
||||
-- | Upload all exported files that are not yet in the remote,
|
||||
-- Returns True when files were uploaded.
|
||||
fillExport :: Remote -> ExportActions Annex -> ExportHandle -> Git.Ref -> Annex Bool
|
||||
fillExport r ea db new = do
|
||||
fillExport :: Remote -> ExportHandle -> Git.Ref -> Annex Bool
|
||||
fillExport r db new = do
|
||||
(l, cleanup) <- inRepo $ Git.LsTree.lsTree new
|
||||
cvar <- liftIO $ newMVar False
|
||||
commandActions $ map (startExport r ea db cvar) l
|
||||
commandActions $ map (startExport r db cvar) l
|
||||
void $ liftIO $ cleanup
|
||||
liftIO $ takeMVar cvar
|
||||
|
||||
startExport :: Remote -> ExportActions Annex -> ExportHandle -> MVar Bool -> Git.LsTree.TreeItem -> CommandStart
|
||||
startExport r ea db cvar ti = do
|
||||
startExport :: Remote -> ExportHandle -> MVar Bool -> Git.LsTree.TreeItem -> CommandStart
|
||||
startExport r db cvar ti = do
|
||||
ek <- exportKey (Git.LsTree.sha ti)
|
||||
stopUnless (notrecordedpresent ek) $ do
|
||||
showStart ("export " ++ name r) f
|
||||
ifM (either (const False) id <$> tryNonAsync (checkPresentExport ea (asKey ek) loc))
|
||||
ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) (asKey ek) loc))
|
||||
( next $ next $ cleanupExport r db ek loc False
|
||||
, do
|
||||
liftIO $ modifyMVar_ cvar (pure . const True)
|
||||
next $ performExport r ea db ek af (Git.LsTree.sha ti) loc
|
||||
next $ performExport r db ek af (Git.LsTree.sha ti) loc
|
||||
)
|
||||
where
|
||||
loc = mkExportLocation f
|
||||
|
|
@ -222,9 +221,9 @@ startExport r ea db cvar ti = do
|
|||
-- will still list it, so also check location tracking.
|
||||
<*> (notElem (uuid r) <$> loggedLocations (asKey ek))
|
||||
|
||||
performExport :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> AssociatedFile -> Sha -> ExportLocation -> CommandPerform
|
||||
performExport r ea db ek af contentsha loc = do
|
||||
let storer = storeExport ea
|
||||
performExport :: Remote -> ExportHandle -> ExportKey -> AssociatedFile -> Sha -> ExportLocation -> CommandPerform
|
||||
performExport r db ek af contentsha loc = do
|
||||
let storer = storeExport (exportActions r)
|
||||
sent <- case ek of
|
||||
AnnexKey k -> ifM (inAnnex k)
|
||||
( notifyTransfer Upload af $
|
||||
|
|
@ -232,7 +231,7 @@ performExport r ea db ek af contentsha loc = do
|
|||
-- exports cannot be resumed.
|
||||
upload (uuid r) k af noRetry $ \pm -> do
|
||||
let rollback = void $
|
||||
performUnexport r ea db [ek] loc
|
||||
performUnexport r db [ek] loc
|
||||
sendAnnex k rollback $ \f ->
|
||||
metered Nothing k (return $ Just f) $ \_ m -> do
|
||||
let m' = combineMeterUpdate pm m
|
||||
|
|
@ -259,22 +258,22 @@ cleanupExport r db ek loc sent = do
|
|||
logChange (asKey ek) (uuid r) InfoPresent
|
||||
return True
|
||||
|
||||
startUnexport :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> [Git.Sha] -> CommandStart
|
||||
startUnexport r ea db f shas = do
|
||||
startUnexport :: Remote -> ExportHandle -> TopFilePath -> [Git.Sha] -> CommandStart
|
||||
startUnexport r db f shas = do
|
||||
eks <- forM (filter (/= nullSha) shas) exportKey
|
||||
if null eks
|
||||
then stop
|
||||
else do
|
||||
showStart ("unexport " ++ name r) f'
|
||||
next $ performUnexport r ea db eks loc
|
||||
next $ performUnexport r db eks loc
|
||||
where
|
||||
loc = mkExportLocation f'
|
||||
f' = getTopFilePath f
|
||||
|
||||
startUnexport' :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
|
||||
startUnexport' r ea db f ek = do
|
||||
startUnexport' :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
|
||||
startUnexport' r db f ek = do
|
||||
showStart ("unexport " ++ name r) f'
|
||||
next $ performUnexport r ea db [ek] loc
|
||||
next $ performUnexport r db [ek] loc
|
||||
where
|
||||
loc = mkExportLocation f'
|
||||
f' = getTopFilePath f
|
||||
|
|
@ -284,15 +283,15 @@ startUnexport' r ea db f ek = do
|
|||
-- remote is untrusted, so would not count as a copy anyway.
|
||||
-- Or, an export may be appendonly, and removing a file from it does
|
||||
-- not really remove the content, which must be accessible later on.
|
||||
performUnexport :: Remote -> ExportActions Annex -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandPerform
|
||||
performUnexport r ea db eks loc = do
|
||||
ifM (allM (\ek -> removeExport ea (asKey ek) loc) eks)
|
||||
( next $ cleanupUnexport r ea db eks loc
|
||||
performUnexport :: Remote -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandPerform
|
||||
performUnexport r db eks loc = do
|
||||
ifM (allM (\ek -> removeExport (exportActions r) (asKey ek) loc) eks)
|
||||
( next $ cleanupUnexport r db eks loc
|
||||
, stop
|
||||
)
|
||||
|
||||
cleanupUnexport :: Remote -> ExportActions Annex -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandCleanup
|
||||
cleanupUnexport r ea db eks loc = do
|
||||
cleanupUnexport :: Remote -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandCleanup
|
||||
cleanupUnexport r db eks loc = do
|
||||
liftIO $ do
|
||||
forM_ eks $ \ek ->
|
||||
removeExportedLocation db (asKey ek) loc
|
||||
|
|
@ -308,68 +307,68 @@ cleanupUnexport r ea db eks loc = do
|
|||
forM_ eks $ \ek ->
|
||||
logChange (asKey ek) (uuid r) InfoMissing
|
||||
|
||||
removeEmptyDirectories ea db loc (map asKey eks)
|
||||
removeEmptyDirectories r db loc (map asKey eks)
|
||||
|
||||
startRecoverIncomplete :: Remote -> ExportActions Annex -> ExportHandle -> Git.Sha -> TopFilePath -> CommandStart
|
||||
startRecoverIncomplete r ea db sha oldf
|
||||
startRecoverIncomplete :: Remote -> ExportHandle -> Git.Sha -> TopFilePath -> CommandStart
|
||||
startRecoverIncomplete r db sha oldf
|
||||
| sha == nullSha = stop
|
||||
| otherwise = do
|
||||
ek <- exportKey sha
|
||||
let loc = exportTempName ek
|
||||
showStart ("unexport " ++ name r) (fromExportLocation loc)
|
||||
liftIO $ removeExportedLocation db (asKey ek) oldloc
|
||||
next $ performUnexport r ea db [ek] loc
|
||||
next $ performUnexport r db [ek] loc
|
||||
where
|
||||
oldloc = mkExportLocation oldf'
|
||||
oldf' = getTopFilePath oldf
|
||||
|
||||
startMoveToTempName :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
|
||||
startMoveToTempName r ea db f ek = do
|
||||
startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
|
||||
startMoveToTempName r db f ek = do
|
||||
showStart ("rename " ++ name r) (f' ++ " -> " ++ fromExportLocation tmploc)
|
||||
next $ performRename r ea db ek loc tmploc
|
||||
next $ performRename r db ek loc tmploc
|
||||
where
|
||||
loc = mkExportLocation f'
|
||||
f' = getTopFilePath f
|
||||
tmploc = exportTempName ek
|
||||
|
||||
startMoveFromTempName :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> TopFilePath -> CommandStart
|
||||
startMoveFromTempName r ea db ek f = do
|
||||
startMoveFromTempName :: Remote -> ExportHandle -> ExportKey -> TopFilePath -> CommandStart
|
||||
startMoveFromTempName r db ek f = do
|
||||
let tmploc = exportTempName ek
|
||||
stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $ do
|
||||
showStart ("rename " ++ name r) (fromExportLocation tmploc ++ " -> " ++ f')
|
||||
next $ performRename r ea db ek tmploc loc
|
||||
next $ performRename r db ek tmploc loc
|
||||
where
|
||||
loc = mkExportLocation f'
|
||||
f' = getTopFilePath f
|
||||
|
||||
performRename :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform
|
||||
performRename r ea db ek src dest = do
|
||||
ifM (renameExport ea (asKey ek) src dest)
|
||||
( next $ cleanupRename ea db ek src dest
|
||||
performRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform
|
||||
performRename r db ek src dest = do
|
||||
ifM (renameExport (exportActions r) (asKey ek) src dest)
|
||||
( next $ cleanupRename r db ek src dest
|
||||
-- In case the special remote does not support renaming,
|
||||
-- unexport the src instead.
|
||||
, do
|
||||
warning "rename failed; deleting instead"
|
||||
performUnexport r ea db [ek] src
|
||||
performUnexport r db [ek] src
|
||||
)
|
||||
|
||||
cleanupRename :: ExportActions Annex -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandCleanup
|
||||
cleanupRename ea db ek src dest = do
|
||||
cleanupRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandCleanup
|
||||
cleanupRename r db ek src dest = do
|
||||
liftIO $ do
|
||||
removeExportedLocation db (asKey ek) src
|
||||
addExportedLocation db (asKey ek) dest
|
||||
flushDbQueue db
|
||||
if exportDirectories src /= exportDirectories dest
|
||||
then removeEmptyDirectories ea db src [asKey ek]
|
||||
then removeEmptyDirectories r db src [asKey ek]
|
||||
else return True
|
||||
|
||||
-- | Remove empty directories from the export. Call after removing an
|
||||
-- exported file, and after calling removeExportLocation and flushing the
|
||||
-- database.
|
||||
removeEmptyDirectories :: ExportActions Annex -> ExportHandle -> ExportLocation -> [Key] -> Annex Bool
|
||||
removeEmptyDirectories ea db loc ks
|
||||
removeEmptyDirectories :: Remote -> ExportHandle -> ExportLocation -> [Key] -> Annex Bool
|
||||
removeEmptyDirectories r db loc ks
|
||||
| null (exportDirectories loc) = return True
|
||||
| otherwise = case removeExportDirectory ea of
|
||||
| otherwise = case removeExportDirectory (exportActions r) of
|
||||
Nothing -> return True
|
||||
Just removeexportdirectory -> do
|
||||
ok <- allM (go removeexportdirectory)
|
||||
|
|
|
|||
|
|
@ -691,7 +691,6 @@ seekExportContent rs (currbranch, _) = or <$> forM rs go
|
|||
where
|
||||
go r = withExclusiveLock (gitAnnexExportLock (Remote.uuid r)) $ do
|
||||
db <- Export.openDb (Remote.uuid r)
|
||||
ea <- Remote.exportActions r
|
||||
exported <- case remoteAnnexExportTracking (Remote.gitconfig r) of
|
||||
Nothing -> nontracking r
|
||||
Just b -> do
|
||||
|
|
@ -699,9 +698,9 @@ seekExportContent rs (currbranch, _) = or <$> forM rs go
|
|||
case mcur of
|
||||
Nothing -> nontracking r
|
||||
Just cur -> do
|
||||
Command.Export.changeExport r ea db cur
|
||||
Command.Export.changeExport r db cur
|
||||
return [mkExported cur []]
|
||||
Export.closeDb db `after` fillexport r ea db (exportedTreeishes exported)
|
||||
Export.closeDb db `after` fillexport r db (exportedTreeishes exported)
|
||||
|
||||
nontracking r = do
|
||||
exported <- getExport (Remote.uuid r)
|
||||
|
|
@ -720,10 +719,9 @@ seekExportContent rs (currbranch, _) = or <$> forM rs go
|
|||
_ -> noop
|
||||
|
||||
|
||||
fillexport _ _ _ [] = return False
|
||||
fillexport r ea db (t:[]) =
|
||||
Command.Export.fillExport r ea db t
|
||||
fillexport r _ _ _ = do
|
||||
fillexport _ _ [] = return False
|
||||
fillexport r db (t:[]) = Command.Export.fillExport r db t
|
||||
fillexport r _ _ = do
|
||||
warnExportConflict r
|
||||
return False
|
||||
|
||||
|
|
|
|||
|
|
@ -95,7 +95,7 @@ start o = do
|
|||
|
||||
perform :: [Remote] -> [Remote] -> Maybe Remote -> [Key] -> CommandPerform
|
||||
perform rs unavailrs exportr ks = do
|
||||
ea <- maybe exportUnsupported Remote.exportActions exportr
|
||||
let ea = maybe exportUnsupported Remote.exportActions exportr
|
||||
st <- Annex.getState id
|
||||
let tests = testGroup "Remote Tests" $ concat
|
||||
[ [ testGroup "unavailable remote" (testUnavailable st r (Prelude.head ks)) | r <- unavailrs ]
|
||||
|
|
|
|||
|
|
@ -53,7 +53,7 @@ gen r u c gc = do
|
|||
, lockContent = Nothing
|
||||
, checkPresent = checkPresentDummy
|
||||
, checkPresentCheap = False
|
||||
, exportActions = return $ ExportActions
|
||||
, exportActions = ExportActions
|
||||
{ storeExport = storeExportM serial adir
|
||||
, retrieveExport = retrieveExportM serial adir
|
||||
, removeExport = removeExportM serial adir
|
||||
|
|
|
|||
|
|
@ -63,7 +63,7 @@ gen r u c gc = do
|
|||
, lockContent = Nothing
|
||||
, checkPresent = checkPresentDummy
|
||||
, checkPresentCheap = True
|
||||
, exportActions = return $ ExportActions
|
||||
, exportActions = ExportActions
|
||||
{ storeExport = storeExportM dir
|
||||
, retrieveExport = retrieveExportM dir
|
||||
, removeExport = removeExportM dir
|
||||
|
|
|
|||
|
|
@ -75,7 +75,7 @@ gen r u c gc
|
|||
then checkExportSupported' external
|
||||
else return False
|
||||
let exportactions = if exportsupported
|
||||
then return $ ExportActions
|
||||
then ExportActions
|
||||
{ storeExport = storeExportM external
|
||||
, retrieveExport = retrieveExportM external
|
||||
, removeExport = removeExportM external
|
||||
|
|
|
|||
|
|
@ -31,8 +31,8 @@ class HasExportUnsupported a where
|
|||
instance HasExportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where
|
||||
exportUnsupported = \_ _ -> return False
|
||||
|
||||
instance HasExportUnsupported (Annex (ExportActions Annex)) where
|
||||
exportUnsupported = return $ ExportActions
|
||||
instance HasExportUnsupported (ExportActions Annex) where
|
||||
exportUnsupported = ExportActions
|
||||
{ storeExport = \_ _ _ _ -> do
|
||||
warning "store export is unsupported"
|
||||
return False
|
||||
|
|
@ -182,10 +182,8 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
|
|||
-- non-export remote)
|
||||
, checkPresent = if appendonly r
|
||||
then checkPresent r
|
||||
else \k -> do
|
||||
ea <- exportActions r
|
||||
anyM (checkPresentExport ea k)
|
||||
=<< getexportlocs k
|
||||
else \k -> anyM (checkPresentExport (exportActions r) k)
|
||||
=<< getexportlocs k
|
||||
-- checkPresent from an export is more expensive
|
||||
-- than otherwise, so not cheap. Also, this
|
||||
-- avoids things that look at checkPresentCheap and
|
||||
|
|
@ -211,9 +209,7 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
|
|||
, warning "unknown export location"
|
||||
)
|
||||
return False
|
||||
(l:_) -> do
|
||||
ea <- exportActions r
|
||||
retrieveExport ea k l dest p
|
||||
(l:_) -> retrieveExport (exportActions r) k l dest p
|
||||
else do
|
||||
warning $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (keyVariety k)) ++ " backend"
|
||||
return False
|
||||
|
|
|
|||
|
|
@ -77,7 +77,7 @@ gen r u c gc = do
|
|||
, lockContent = Nothing
|
||||
, checkPresent = checkPresentDummy
|
||||
, checkPresentCheap = False
|
||||
, exportActions = return $ ExportActions
|
||||
, exportActions = ExportActions
|
||||
{ storeExport = storeExportM o
|
||||
, retrieveExport = retrieveExportM o
|
||||
, removeExport = removeExportM o
|
||||
|
|
|
|||
91
Remote/S3.hs
91
Remote/S3.hs
|
|
@ -100,16 +100,15 @@ gen r u c gc = do
|
|||
, lockContent = Nothing
|
||||
, checkPresent = checkPresentDummy
|
||||
, checkPresentCheap = False
|
||||
, exportActions = withS3HandleMaybe' c gc u $ \mh ->
|
||||
return $ ExportActions
|
||||
{ storeExport = storeExportS3 u info mh magic
|
||||
, retrieveExport = retrieveExportS3 u info mh
|
||||
, removeExport = removeExportS3 u info mh
|
||||
, checkPresentExport = checkPresentExportS3 u info mh
|
||||
-- S3 does not have directories.
|
||||
, removeExportDirectory = Nothing
|
||||
, renameExport = renameExportS3 u info mh
|
||||
}
|
||||
, exportActions = ExportActions
|
||||
{ storeExport = storeExportS3 this info magic
|
||||
, retrieveExport = retrieveExportS3 this info
|
||||
, removeExport = removeExportS3 this info
|
||||
, checkPresentExport = checkPresentExportS3 this info
|
||||
-- S3 does not have directories.
|
||||
, removeExportDirectory = Nothing
|
||||
, renameExport = renameExportS3 this info
|
||||
}
|
||||
, whereisKey = Just (getPublicWebUrls u info c)
|
||||
, remoteFsck = Nothing
|
||||
, repairRepo = Nothing
|
||||
|
|
@ -341,63 +340,68 @@ checkKeyHelper info h loc = do
|
|||
| otherwise = Nothing
|
||||
#endif
|
||||
|
||||
storeExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
|
||||
storeExportS3 u info (Just h) magic f k loc p =
|
||||
catchNonAsync go (\e -> warning (show e) >> return False)
|
||||
storeExportS3 :: Remote -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
|
||||
storeExportS3 r info magic f k loc p = withS3HandleMaybe r $ \case
|
||||
Just h -> catchNonAsync (go h) (\e -> warning (show e) >> return False)
|
||||
Nothing -> do
|
||||
warning $ needS3Creds (uuid r)
|
||||
return False
|
||||
where
|
||||
go = do
|
||||
go h = do
|
||||
let o = T.pack $ bucketExportLocation info loc
|
||||
storeHelper info h magic f o p
|
||||
>>= setS3VersionID info u k
|
||||
>>= setS3VersionID info (uuid r) k
|
||||
return True
|
||||
storeExportS3 u _ Nothing _ _ _ _ _ = do
|
||||
warning $ needS3Creds u
|
||||
return False
|
||||
|
||||
retrieveExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
|
||||
retrieveExportS3 u info mh _k loc f p =
|
||||
retrieveExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
|
||||
retrieveExportS3 r info _k loc f p =
|
||||
catchNonAsync go (\e -> warning (show e) >> return False)
|
||||
where
|
||||
go = case mh of
|
||||
go = withS3HandleMaybe r $ \case
|
||||
Just h -> do
|
||||
retrieveHelper info h (Left (T.pack exporturl)) f p
|
||||
return True
|
||||
Nothing -> case getPublicUrlMaker info of
|
||||
Nothing -> do
|
||||
warning $ needS3Creds u
|
||||
warning $ needS3Creds (uuid r)
|
||||
return False
|
||||
Just geturl -> Url.withUrlOptions $
|
||||
liftIO . Url.download p (geturl exporturl) f
|
||||
exporturl = bucketExportLocation info loc
|
||||
|
||||
removeExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Key -> ExportLocation -> Annex Bool
|
||||
removeExportS3 u info (Just h) k loc = checkVersioning info u k $
|
||||
catchNonAsync go (\e -> warning (show e) >> return False)
|
||||
removeExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> Annex Bool
|
||||
removeExportS3 r info k loc = withS3HandleMaybe r $ \case
|
||||
Just h -> checkVersioning info (uuid r) k $
|
||||
catchNonAsync (go h) (\e -> warning (show e) >> return False)
|
||||
Nothing -> do
|
||||
warning $ needS3Creds (uuid r)
|
||||
return False
|
||||
where
|
||||
go = do
|
||||
go h = do
|
||||
res <- tryNonAsync $ sendS3Handle h $
|
||||
S3.DeleteObject (T.pack $ bucketExportLocation info loc) (bucket info)
|
||||
return $ either (const False) (const True) res
|
||||
removeExportS3 u _ Nothing _ _ = do
|
||||
warning $ needS3Creds u
|
||||
return False
|
||||
|
||||
checkPresentExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Key -> ExportLocation -> Annex Bool
|
||||
checkPresentExportS3 _u info (Just h) _k loc =
|
||||
checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc))
|
||||
checkPresentExportS3 u info Nothing k loc = case getPublicUrlMaker info of
|
||||
Nothing -> do
|
||||
warning $ needS3Creds u
|
||||
giveup "No S3 credentials configured"
|
||||
Just geturl -> withUrlOptions $ liftIO .
|
||||
checkBoth (geturl $ bucketExportLocation info loc) (keySize k)
|
||||
checkPresentExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> Annex Bool
|
||||
checkPresentExportS3 r info k loc = withS3HandleMaybe r $ \case
|
||||
Just h -> checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc))
|
||||
Nothing -> case getPublicUrlMaker info of
|
||||
Just geturl -> withUrlOptions $ liftIO .
|
||||
checkBoth (geturl $ bucketExportLocation info loc) (keySize k)
|
||||
Nothing -> do
|
||||
warning $ needS3Creds (uuid r)
|
||||
giveup "No S3 credentials configured"
|
||||
|
||||
-- S3 has no move primitive; copy and delete.
|
||||
renameExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Key -> ExportLocation -> ExportLocation -> Annex Bool
|
||||
renameExportS3 u info (Just h) k src dest = checkVersioning info u k $
|
||||
catchNonAsync go (\_ -> return False)
|
||||
renameExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex Bool
|
||||
renameExportS3 r info k src dest = withS3HandleMaybe r $ \case
|
||||
Just h -> checkVersioning info (uuid r) k $
|
||||
catchNonAsync (go h) (\_ -> return False)
|
||||
Nothing -> do
|
||||
warning $ needS3Creds (uuid r)
|
||||
return False
|
||||
where
|
||||
go = do
|
||||
go h = do
|
||||
let co = S3.copyObject (bucket info) dstobject
|
||||
(S3.ObjectId (bucket info) srcobject Nothing)
|
||||
S3.CopyMetadata
|
||||
|
|
@ -407,9 +411,6 @@ renameExportS3 u info (Just h) k src dest = checkVersioning info u k $
|
|||
return True
|
||||
srcobject = T.pack $ bucketExportLocation info src
|
||||
dstobject = T.pack $ bucketExportLocation info dest
|
||||
renameExportS3 u _ Nothing _ _ _ = do
|
||||
warning $ needS3Creds u
|
||||
return False
|
||||
|
||||
{- Generate the bucket if it does not already exist, including creating the
|
||||
- UUID file within the bucket.
|
||||
|
|
|
|||
|
|
@ -79,14 +79,14 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
|
|||
, lockContent = Nothing
|
||||
, checkPresent = checkPresentDummy
|
||||
, checkPresentCheap = False
|
||||
, exportActions = withDAVHandle this $ \mh -> return $ ExportActions
|
||||
{ storeExport = storeExportDav mh
|
||||
, retrieveExport = retrieveExportDav mh
|
||||
, checkPresentExport = checkPresentExportDav this mh
|
||||
, removeExport = removeExportDav mh
|
||||
, exportActions = ExportActions
|
||||
{ storeExport = storeExportDav this
|
||||
, retrieveExport = retrieveExportDav this
|
||||
, checkPresentExport = checkPresentExportDav this
|
||||
, removeExport = removeExportDav this
|
||||
, removeExportDirectory = Just $
|
||||
removeExportDirectoryDav mh
|
||||
, renameExport = renameExportDav mh
|
||||
removeExportDirectoryDav this
|
||||
, renameExport = renameExportDav this
|
||||
}
|
||||
, whereisKey = Nothing
|
||||
, remoteFsck = Nothing
|
||||
|
|
@ -193,45 +193,46 @@ checkKey r chunkconfig (Just dav) k = do
|
|||
existsDAV (keyLocation k)
|
||||
either giveup return v
|
||||
|
||||
storeExportDav :: Maybe DavHandle -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
|
||||
storeExportDav mh f k loc p = runExport mh $ \dav -> do
|
||||
storeExportDav :: Remote -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
|
||||
storeExportDav r f k loc p = withDAVHandle r $ \mh -> runExport mh $ \dav -> do
|
||||
reqbody <- liftIO $ httpBodyStorer f p
|
||||
storeHelper dav (keyTmpLocation k) (exportLocation loc) reqbody
|
||||
return True
|
||||
|
||||
retrieveExportDav :: Maybe DavHandle -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
|
||||
retrieveExportDav mh _k loc d p = runExport mh $ \_dav -> do
|
||||
retrieveExportDav :: Remote -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
|
||||
retrieveExportDav r _k loc d p = withDAVHandle r $ \mh -> runExport mh $ \_dav -> do
|
||||
retrieveHelper (exportLocation loc) d p
|
||||
return True
|
||||
|
||||
checkPresentExportDav :: Remote -> Maybe DavHandle -> Key -> ExportLocation -> Annex Bool
|
||||
checkPresentExportDav r mh _k loc = case mh of
|
||||
checkPresentExportDav :: Remote -> Key -> ExportLocation -> Annex Bool
|
||||
checkPresentExportDav r _k loc = withDAVHandle r $ \case
|
||||
Nothing -> giveup $ name r ++ " not configured"
|
||||
Just h -> liftIO $ do
|
||||
v <- goDAV h $ existsDAV (exportLocation loc)
|
||||
either giveup return v
|
||||
|
||||
removeExportDav :: Maybe DavHandle -> Key -> ExportLocation -> Annex Bool
|
||||
removeExportDav mh _k loc = runExport mh $ \_dav ->
|
||||
removeExportDav :: Remote -> Key -> ExportLocation -> Annex Bool
|
||||
removeExportDav r _k loc = withDAVHandle r $ \mh -> runExport mh $ \_dav ->
|
||||
removeHelper (exportLocation loc)
|
||||
|
||||
removeExportDirectoryDav :: Maybe DavHandle -> ExportDirectory -> Annex Bool
|
||||
removeExportDirectoryDav mh dir = runExport mh $ \_dav -> do
|
||||
removeExportDirectoryDav :: Remote -> ExportDirectory -> Annex Bool
|
||||
removeExportDirectoryDav r dir = withDAVHandle r $ \mh -> runExport mh $ \_dav -> do
|
||||
let d = fromExportDirectory dir
|
||||
debugDav $ "delContent " ++ d
|
||||
safely (inLocation d delContentM)
|
||||
>>= maybe (return False) (const $ return True)
|
||||
|
||||
renameExportDav :: Maybe DavHandle -> Key -> ExportLocation -> ExportLocation -> Annex Bool
|
||||
renameExportDav Nothing _ _ _ = return False
|
||||
renameExportDav (Just h) _k src dest
|
||||
-- box.com's DAV endpoint has buggy handling of renames,
|
||||
-- so avoid renaming when using it.
|
||||
| boxComUrl `isPrefixOf` baseURL h = return False
|
||||
| otherwise = runExport (Just h) $ \dav -> do
|
||||
maybe noop (void . mkColRecursive) (locationParent (exportLocation dest))
|
||||
moveDAV (baseURL dav) (exportLocation src) (exportLocation dest)
|
||||
return True
|
||||
renameExportDav :: Remote -> Key -> ExportLocation -> ExportLocation -> Annex Bool
|
||||
renameExportDav r _k src dest = withDAVHandle r $ \case
|
||||
Just h
|
||||
-- box.com's DAV endpoint has buggy handling of renames,
|
||||
-- so avoid renaming when using it.
|
||||
| boxComUrl `isPrefixOf` baseURL h -> return False
|
||||
| otherwise -> runExport (Just h) $ \dav -> do
|
||||
maybe noop (void . mkColRecursive) (locationParent (exportLocation dest))
|
||||
moveDAV (baseURL dav) (exportLocation src) (exportLocation dest)
|
||||
return True
|
||||
Nothing -> return False
|
||||
|
||||
runExport :: Maybe DavHandle -> (DavHandle -> DAVT IO Bool) -> Annex Bool
|
||||
runExport Nothing _ = return False
|
||||
|
|
|
|||
|
|
@ -103,7 +103,7 @@ data RemoteA a = Remote
|
|||
-- operation.
|
||||
, checkPresentCheap :: Bool
|
||||
-- Some remotes support exports of trees.
|
||||
, exportActions :: a (ExportActions a)
|
||||
, exportActions :: ExportActions a
|
||||
-- Some remotes can provide additional details for whereis.
|
||||
, whereisKey :: Maybe (Key -> a [String])
|
||||
-- Some remotes can run a fsck operation on the remote,
|
||||
|
|
|
|||
Loading…
Reference in a new issue