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

purify exportActions

Browse source 
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 commit 809cfbbd8a and
5d394023eb S3 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 2019-01-30 14:55:28 -04:00
parent 5d394023eb
commit 9cebfd7002
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
11 changed files with 143 additions and 148 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

107
Command/Export.hs
View file

@ -82,16 +82,15 @@ seek o = do
inRepo (Git.Ref.tree (exportTreeish o)) inRepo (Git.Ref.tree (exportTreeish o))
withExclusiveLock (gitAnnexExportLock (uuid r)) $ do withExclusiveLock (gitAnnexExportLock (uuid r)) $ do
db <- openDb (uuid r) db <- openDb (uuid r)
ea <- exportActions r changeExport r db new
changeExport r ea db new
unlessM (Annex.getState Annex.fast) $ unlessM (Annex.getState Annex.fast) $
void $ fillExport r ea db new void $ fillExport r db new
closeDb db closeDb db
-- | Changes what's exported to the remote. Does not upload any new -- | Changes what's exported to the remote. Does not upload any new
-- files, but does delete and rename files already exported to the remote. -- files, but does delete and rename files already exported to the remote.
changeExport :: Remote -> ExportActions Annex -> ExportHandle -> Git.Ref -> CommandSeek changeExport :: Remote -> ExportHandle -> Git.Ref -> CommandSeek
changeExport r ea db new = do changeExport r db new = do
old <- getExport (uuid r) old <- getExport (uuid r)
recordExportBeginning (uuid r) new 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, -- temp files. Diff from the incomplete tree to the new tree,
-- and delete any temp files that the new tree can't use. -- and delete any temp files that the new tree can't use.
let recover diff = commandAction $ let recover diff = commandAction $
startRecoverIncomplete r ea db startRecoverIncomplete r db
(Git.DiffTree.srcsha diff) (Git.DiffTree.srcsha diff)
(Git.DiffTree.file diff) (Git.DiffTree.file diff)
forM_ (incompleteExportedTreeishes old) $ \incomplete -> forM_ (incompleteExportedTreeishes old) $ \incomplete ->
@ -123,15 +122,15 @@ changeExport r ea db new = do
seekdiffmap $ \(ek, (moldf, mnewf)) -> do seekdiffmap $ \(ek, (moldf, mnewf)) -> do
case (moldf, mnewf) of case (moldf, mnewf) of
(Just oldf, Just _newf) -> (Just oldf, Just _newf) ->
startMoveToTempName r ea db oldf ek startMoveToTempName r db oldf ek
(Just oldf, Nothing) -> (Just oldf, Nothing) ->
startUnexport' r ea db oldf ek startUnexport' r db oldf ek
_ -> stop _ -> stop
-- Rename from temp to new files. -- Rename from temp to new files.
seekdiffmap $ \(ek, (moldf, mnewf)) -> seekdiffmap $ \(ek, (moldf, mnewf)) ->
case (moldf, mnewf) of case (moldf, mnewf) of
(Just _oldf, Just newf) -> (Just _oldf, Just newf) ->
startMoveFromTempName r ea db ek newf startMoveFromTempName r db ek newf
_ -> stop _ -> stop
ts -> do ts -> do
warning "Export conflict detected. Different trees have been exported to the same special remote. Resolving.." 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 -- Don't rename to temp, because the
-- content is unknown; delete instead. -- content is unknown; delete instead.
mapdiff 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 oldtreesha new
updateExportTree db emptyTree new updateExportTree db emptyTree new
liftIO $ recordExportTreeCurrent db 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, -- | Upload all exported files that are not yet in the remote,
-- Returns True when files were uploaded. -- Returns True when files were uploaded.
fillExport :: Remote -> ExportActions Annex -> ExportHandle -> Git.Ref -> Annex Bool fillExport :: Remote -> ExportHandle -> Git.Ref -> Annex Bool
fillExport r ea db new = do fillExport r db new = do
(l, cleanup) <- inRepo $ Git.LsTree.lsTree new (l, cleanup) <- inRepo $ Git.LsTree.lsTree new
cvar <- liftIO $ newMVar False cvar <- liftIO $ newMVar False
commandActions $ map (startExport r ea db cvar) l commandActions $ map (startExport r db cvar) l
void $ liftIO $ cleanup void $ liftIO $ cleanup
liftIO $ takeMVar cvar liftIO $ takeMVar cvar
startExport :: Remote -> ExportActions Annex -> ExportHandle -> MVar Bool -> Git.LsTree.TreeItem -> CommandStart startExport :: Remote -> ExportHandle -> MVar Bool -> Git.LsTree.TreeItem -> CommandStart
startExport r ea db cvar ti = do startExport r db cvar ti = do
ek <- exportKey (Git.LsTree.sha ti) ek <- exportKey (Git.LsTree.sha ti)
stopUnless (notrecordedpresent ek) $ do stopUnless (notrecordedpresent ek) $ do
showStart ("export " ++ name r) f 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 ( next $ next $ cleanupExport r db ek loc False
, do , do
liftIO $ modifyMVar_ cvar (pure . const True) 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 where
loc = mkExportLocation f loc = mkExportLocation f
@ -222,9 +221,9 @@ startExport r ea db cvar ti = do
-- will still list it, so also check location tracking. -- will still list it, so also check location tracking.
<*> (notElem (uuid r) <$> loggedLocations (asKey ek)) <*> (notElem (uuid r) <$> loggedLocations (asKey ek))
performExport :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> AssociatedFile -> Sha -> ExportLocation -> CommandPerform performExport :: Remote -> ExportHandle -> ExportKey -> AssociatedFile -> Sha -> ExportLocation -> CommandPerform
performExport r ea db ek af contentsha loc = do performExport r db ek af contentsha loc = do
let storer = storeExport ea let storer = storeExport (exportActions r)
sent <- case ek of sent <- case ek of
AnnexKey k -> ifM (inAnnex k) AnnexKey k -> ifM (inAnnex k)
( notifyTransfer Upload af $ ( notifyTransfer Upload af $
@ -232,7 +231,7 @@ performExport r ea db ek af contentsha loc = do
-- exports cannot be resumed. -- exports cannot be resumed.
upload (uuid r) k af noRetry $ \pm -> do upload (uuid r) k af noRetry $ \pm -> do
let rollback = void $ let rollback = void $
performUnexport r ea db [ek] loc performUnexport r db [ek] loc
sendAnnex k rollback $ \f -> sendAnnex k rollback $ \f ->
metered Nothing k (return $ Just f) $ \_ m -> do metered Nothing k (return $ Just f) $ \_ m -> do
let m' = combineMeterUpdate pm m let m' = combineMeterUpdate pm m
@ -259,22 +258,22 @@ cleanupExport r db ek loc sent = do
logChange (asKey ek) (uuid r) InfoPresent logChange (asKey ek) (uuid r) InfoPresent
return True return True
startUnexport :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> [Git.Sha] -> CommandStart startUnexport :: Remote -> ExportHandle -> TopFilePath -> [Git.Sha] -> CommandStart
startUnexport r ea db f shas = do startUnexport r db f shas = do
eks <- forM (filter (/= nullSha) shas) exportKey eks <- forM (filter (/= nullSha) shas) exportKey
if null eks if null eks
then stop then stop
else do else do
showStart ("unexport " ++ name r) f' showStart ("unexport " ++ name r) f'
next $ performUnexport r ea db eks loc next $ performUnexport r db eks loc
where where
loc = mkExportLocation f' loc = mkExportLocation f'
f' = getTopFilePath f f' = getTopFilePath f
startUnexport' :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart startUnexport' :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
startUnexport' r ea db f ek = do startUnexport' r db f ek = do
showStart ("unexport " ++ name r) f' showStart ("unexport " ++ name r) f'
next $ performUnexport r ea db [ek] loc next $ performUnexport r db [ek] loc
where where
loc = mkExportLocation f' loc = mkExportLocation f'
f' = getTopFilePath 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. -- remote is untrusted, so would not count as a copy anyway.
-- Or, an export may be appendonly, and removing a file from it does -- Or, an export may be appendonly, and removing a file from it does
-- not really remove the content, which must be accessible later on. -- not really remove the content, which must be accessible later on.
performUnexport :: Remote -> ExportActions Annex -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandPerform performUnexport :: Remote -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandPerform
performUnexport r ea db eks loc = do performUnexport r db eks loc = do
ifM (allM (\ek -> removeExport ea (asKey ek) loc) eks) ifM (allM (\ek -> removeExport (exportActions r) (asKey ek) loc) eks)
( next $ cleanupUnexport r ea db eks loc ( next $ cleanupUnexport r db eks loc
, stop , stop
) )
cleanupUnexport :: Remote -> ExportActions Annex -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandCleanup cleanupUnexport :: Remote -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandCleanup
cleanupUnexport r ea db eks loc = do cleanupUnexport r db eks loc = do
liftIO $ do liftIO $ do
forM_ eks $ \ek -> forM_ eks $ \ek ->
removeExportedLocation db (asKey ek) loc removeExportedLocation db (asKey ek) loc
@ -308,68 +307,68 @@ cleanupUnexport r ea db eks loc = do
forM_ eks $ \ek -> forM_ eks $ \ek ->
logChange (asKey ek) (uuid r) InfoMissing 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 :: Remote -> ExportHandle -> Git.Sha -> TopFilePath -> CommandStart
startRecoverIncomplete r ea db sha oldf startRecoverIncomplete r db sha oldf
| sha == nullSha = stop | sha == nullSha = stop
| otherwise = do | otherwise = do
ek <- exportKey sha ek <- exportKey sha
let loc = exportTempName ek let loc = exportTempName ek
showStart ("unexport " ++ name r) (fromExportLocation loc) showStart ("unexport " ++ name r) (fromExportLocation loc)
liftIO $ removeExportedLocation db (asKey ek) oldloc liftIO $ removeExportedLocation db (asKey ek) oldloc
next $ performUnexport r ea db [ek] loc next $ performUnexport r db [ek] loc
where where
oldloc = mkExportLocation oldf' oldloc = mkExportLocation oldf'
oldf' = getTopFilePath oldf oldf' = getTopFilePath oldf
startMoveToTempName :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
startMoveToTempName r ea db f ek = do startMoveToTempName r db f ek = do
showStart ("rename " ++ name r) (f' ++ " -> " ++ fromExportLocation tmploc) showStart ("rename " ++ name r) (f' ++ " -> " ++ fromExportLocation tmploc)
next $ performRename r ea db ek loc tmploc next $ performRename r db ek loc tmploc
where where
loc = mkExportLocation f' loc = mkExportLocation f'
f' = getTopFilePath f f' = getTopFilePath f
tmploc = exportTempName ek tmploc = exportTempName ek
startMoveFromTempName :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> TopFilePath -> CommandStart startMoveFromTempName :: Remote -> ExportHandle -> ExportKey -> TopFilePath -> CommandStart
startMoveFromTempName r ea db ek f = do startMoveFromTempName r db ek f = do
let tmploc = exportTempName ek let tmploc = exportTempName ek
stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $ do stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $ do
showStart ("rename " ++ name r) (fromExportLocation tmploc ++ " -> " ++ f') showStart ("rename " ++ name r) (fromExportLocation tmploc ++ " -> " ++ f')
next $ performRename r ea db ek tmploc loc next $ performRename r db ek tmploc loc
where where
loc = mkExportLocation f' loc = mkExportLocation f'
f' = getTopFilePath f f' = getTopFilePath f
performRename :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform performRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform
performRename r ea db ek src dest = do performRename r db ek src dest = do
ifM (renameExport ea (asKey ek) src dest) ifM (renameExport (exportActions r) (asKey ek) src dest)
( next $ cleanupRename ea db ek src dest ( next $ cleanupRename r db ek src dest
-- In case the special remote does not support renaming, -- In case the special remote does not support renaming,
-- unexport the src instead. -- unexport the src instead.
, do , do
warning "rename failed; deleting instead" 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 :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandCleanup
cleanupRename ea db ek src dest = do cleanupRename r db ek src dest = do
liftIO $ do liftIO $ do
removeExportedLocation db (asKey ek) src removeExportedLocation db (asKey ek) src
addExportedLocation db (asKey ek) dest addExportedLocation db (asKey ek) dest
flushDbQueue db flushDbQueue db
if exportDirectories src /= exportDirectories dest if exportDirectories src /= exportDirectories dest
then removeEmptyDirectories ea db src [asKey ek] then removeEmptyDirectories r db src [asKey ek]
else return True else return True
-- | Remove empty directories from the export. Call after removing an -- | Remove empty directories from the export. Call after removing an
-- exported file, and after calling removeExportLocation and flushing the -- exported file, and after calling removeExportLocation and flushing the
-- database. -- database.
removeEmptyDirectories :: ExportActions Annex -> ExportHandle -> ExportLocation -> [Key] -> Annex Bool removeEmptyDirectories :: Remote -> ExportHandle -> ExportLocation -> [Key] -> Annex Bool
removeEmptyDirectories ea db loc ks removeEmptyDirectories r db loc ks
| null (exportDirectories loc) = return True | null (exportDirectories loc) = return True
| otherwise = case removeExportDirectory ea of | otherwise = case removeExportDirectory (exportActions r) of
Nothing -> return True Nothing -> return True
Just removeexportdirectory -> do Just removeexportdirectory -> do
ok <- allM (go removeexportdirectory) ok <- allM (go removeexportdirectory)

12
Command/Sync.hs
View file

@ -691,7 +691,6 @@ seekExportContent rs (currbranch, _) = or <$> forM rs go
where where
go r = withExclusiveLock (gitAnnexExportLock (Remote.uuid r)) $ do go r = withExclusiveLock (gitAnnexExportLock (Remote.uuid r)) $ do
db <- Export.openDb (Remote.uuid r) db <- Export.openDb (Remote.uuid r)
ea <- Remote.exportActions r
exported <- case remoteAnnexExportTracking (Remote.gitconfig r) of exported <- case remoteAnnexExportTracking (Remote.gitconfig r) of
Nothing -> nontracking r Nothing -> nontracking r
Just b -> do Just b -> do
@ -699,9 +698,9 @@ seekExportContent rs (currbranch, _) = or <$> forM rs go
case mcur of case mcur of
Nothing -> nontracking r Nothing -> nontracking r
Just cur -> do Just cur -> do
Command.Export.changeExport r ea db cur Command.Export.changeExport r db cur
return [mkExported 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 nontracking r = do
exported <- getExport (Remote.uuid r) exported <- getExport (Remote.uuid r)
@ -720,10 +719,9 @@ seekExportContent rs (currbranch, _) = or <$> forM rs go
_ -> noop _ -> noop
fillexport _ _ _ [] = return False fillexport _ _ [] = return False
fillexport r ea db (t:[]) = fillexport r db (t:[]) = Command.Export.fillExport r db t
Command.Export.fillExport r ea db t fillexport r _ _ = do
fillexport r _ _ _ = do
warnExportConflict r warnExportConflict r
return False return False

2
Command/TestRemote.hs
View file

@ -95,7 +95,7 @@ start o = do
perform :: [Remote] -> [Remote] -> Maybe Remote -> [Key] -> CommandPerform perform :: [Remote] -> [Remote] -> Maybe Remote -> [Key] -> CommandPerform
perform rs unavailrs exportr ks = do perform rs unavailrs exportr ks = do
ea <- maybe exportUnsupported Remote.exportActions exportr let ea = maybe exportUnsupported Remote.exportActions exportr
st <- Annex.getState id st <- Annex.getState id
let tests = testGroup "Remote Tests" $ concat let tests = testGroup "Remote Tests" $ concat
[ [ testGroup "unavailable remote" (testUnavailable st r (Prelude.head ks)) | r <- unavailrs ] [ [ testGroup "unavailable remote" (testUnavailable st r (Prelude.head ks)) | r <- unavailrs ]

2
Remote/Adb.hs
View file

@ -53,7 +53,7 @@ gen r u c gc = do
, lockContent = Nothing , lockContent = Nothing
, checkPresent = checkPresentDummy , checkPresent = checkPresentDummy
, checkPresentCheap = False , checkPresentCheap = False
, exportActions = return $ ExportActions , exportActions = ExportActions
{ storeExport = storeExportM serial adir { storeExport = storeExportM serial adir
, retrieveExport = retrieveExportM serial adir , retrieveExport = retrieveExportM serial adir
, removeExport = removeExportM serial adir , removeExport = removeExportM serial adir

2
Remote/Directory.hs
View file

@ -63,7 +63,7 @@ gen r u c gc = do
, lockContent = Nothing , lockContent = Nothing
, checkPresent = checkPresentDummy , checkPresent = checkPresentDummy
, checkPresentCheap = True , checkPresentCheap = True
, exportActions = return $ ExportActions , exportActions = ExportActions
{ storeExport = storeExportM dir { storeExport = storeExportM dir
, retrieveExport = retrieveExportM dir , retrieveExport = retrieveExportM dir
, removeExport = removeExportM dir , removeExport = removeExportM dir

2
Remote/External.hs
View file

@ -75,7 +75,7 @@ gen r u c gc
then checkExportSupported' external then checkExportSupported' external
else return False else return False
let exportactions = if exportsupported let exportactions = if exportsupported
then return $ ExportActions then ExportActions
{ storeExport = storeExportM external { storeExport = storeExportM external
, retrieveExport = retrieveExportM external , retrieveExport = retrieveExportM external
, removeExport = removeExportM external , removeExport = removeExportM external

14
Remote/Helper/Export.hs
View file

@ -31,8 +31,8 @@ class HasExportUnsupported a where
instance HasExportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where instance HasExportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where
exportUnsupported = \_ _ -> return False exportUnsupported = \_ _ -> return False
instance HasExportUnsupported (Annex (ExportActions Annex)) where instance HasExportUnsupported (ExportActions Annex) where
exportUnsupported = return $ ExportActions exportUnsupported = ExportActions
{ storeExport = \_ _ _ _ -> do { storeExport = \_ _ _ _ -> do
warning "store export is unsupported" warning "store export is unsupported"
return False return False
@ -182,10 +182,8 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
-- non-export remote) -- non-export remote)
, checkPresent = if appendonly r , checkPresent = if appendonly r
then checkPresent r then checkPresent r
else \k -> do else \k -> anyM (checkPresentExport (exportActions r) k)
ea <- exportActions r =<< getexportlocs k
anyM (checkPresentExport ea k)
=<< getexportlocs k
-- checkPresent from an export is more expensive -- checkPresent from an export is more expensive
-- than otherwise, so not cheap. Also, this -- than otherwise, so not cheap. Also, this
-- avoids things that look at checkPresentCheap and -- avoids things that look at checkPresentCheap and
@ -211,9 +209,7 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
, warning "unknown export location" , warning "unknown export location"
) )
return False return False
(l:_) -> do (l:_) -> retrieveExport (exportActions r) k l dest p
ea <- exportActions r
retrieveExport ea k l dest p
else do else do
warning $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (keyVariety k)) ++ " backend" warning $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (keyVariety k)) ++ " backend"
return False return False

2
Remote/Rsync.hs
View file

@ -77,7 +77,7 @@ gen r u c gc = do
, lockContent = Nothing , lockContent = Nothing
, checkPresent = checkPresentDummy , checkPresent = checkPresentDummy
, checkPresentCheap = False , checkPresentCheap = False
, exportActions = return $ ExportActions , exportActions = ExportActions
{ storeExport = storeExportM o { storeExport = storeExportM o
, retrieveExport = retrieveExportM o , retrieveExport = retrieveExportM o
, removeExport = removeExportM o , removeExport = removeExportM o

91
Remote/S3.hs
View file

@ -100,16 +100,15 @@ gen r u c gc = do
, lockContent = Nothing , lockContent = Nothing
, checkPresent = checkPresentDummy , checkPresent = checkPresentDummy
, checkPresentCheap = False , checkPresentCheap = False
, exportActions = withS3HandleMaybe' c gc u $ \mh -> , exportActions = ExportActions
return $ ExportActions { storeExport = storeExportS3 this info magic
{ storeExport = storeExportS3 u info mh magic , retrieveExport = retrieveExportS3 this info
, retrieveExport = retrieveExportS3 u info mh , removeExport = removeExportS3 this info
, removeExport = removeExportS3 u info mh , checkPresentExport = checkPresentExportS3 this info
, checkPresentExport = checkPresentExportS3 u info mh -- S3 does not have directories.
-- S3 does not have directories. , removeExportDirectory = Nothing
, removeExportDirectory = Nothing , renameExport = renameExportS3 this info
, renameExport = renameExportS3 u info mh }
}
, whereisKey = Just (getPublicWebUrls u info c) , whereisKey = Just (getPublicWebUrls u info c)
, remoteFsck = Nothing , remoteFsck = Nothing
, repairRepo = Nothing , repairRepo = Nothing
@ -341,63 +340,68 @@ checkKeyHelper info h loc = do
| otherwise = Nothing | otherwise = Nothing
#endif #endif
storeExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool storeExportS3 :: Remote -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
storeExportS3 u info (Just h) magic f k loc p = storeExportS3 r info magic f k loc p = withS3HandleMaybe r $ \case
catchNonAsync go (\e -> warning (show e) >> return False) Just h -> catchNonAsync (go h) (\e -> warning (show e) >> return False)
Nothing -> do
warning $ needS3Creds (uuid r)
return False
where where
go = do go h = do
let o = T.pack $ bucketExportLocation info loc let o = T.pack $ bucketExportLocation info loc
storeHelper info h magic f o p storeHelper info h magic f o p
>>= setS3VersionID info u k >>= setS3VersionID info (uuid r) k
return True return True
storeExportS3 u _ Nothing _ _ _ _ _ = do
warning $ needS3Creds u
return False
retrieveExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool retrieveExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
retrieveExportS3 u info mh _k loc f p = retrieveExportS3 r info _k loc f p =
catchNonAsync go (\e -> warning (show e) >> return False) catchNonAsync go (\e -> warning (show e) >> return False)
where where
go = case mh of go = withS3HandleMaybe r $ \case
Just h -> do Just h -> do
retrieveHelper info h (Left (T.pack exporturl)) f p retrieveHelper info h (Left (T.pack exporturl)) f p
return True return True
Nothing -> case getPublicUrlMaker info of Nothing -> case getPublicUrlMaker info of
Nothing -> do Nothing -> do
warning $ needS3Creds u warning $ needS3Creds (uuid r)
return False return False
Just geturl -> Url.withUrlOptions $ Just geturl -> Url.withUrlOptions $
liftIO . Url.download p (geturl exporturl) f liftIO . Url.download p (geturl exporturl) f
exporturl = bucketExportLocation info loc exporturl = bucketExportLocation info loc
removeExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Key -> ExportLocation -> Annex Bool removeExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> Annex Bool
removeExportS3 u info (Just h) k loc = checkVersioning info u k $ removeExportS3 r info k loc = withS3HandleMaybe r $ \case
catchNonAsync go (\e -> warning (show e) >> return False) 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 where
go = do go h = do
res <- tryNonAsync $ sendS3Handle h $ res <- tryNonAsync $ sendS3Handle h $
S3.DeleteObject (T.pack $ bucketExportLocation info loc) (bucket info) S3.DeleteObject (T.pack $ bucketExportLocation info loc) (bucket info)
return $ either (const False) (const True) res 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 :: Remote -> S3Info -> Key -> ExportLocation -> Annex Bool
checkPresentExportS3 _u info (Just h) _k loc = checkPresentExportS3 r info k loc = withS3HandleMaybe r $ \case
checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc)) Just h -> checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc))
checkPresentExportS3 u info Nothing k loc = case getPublicUrlMaker info of Nothing -> case getPublicUrlMaker info of
Nothing -> do Just geturl -> withUrlOptions $ liftIO .
warning $ needS3Creds u checkBoth (geturl $ bucketExportLocation info loc) (keySize k)
giveup "No S3 credentials configured" Nothing -> do
Just geturl -> withUrlOptions $ liftIO . warning $ needS3Creds (uuid r)
checkBoth (geturl $ bucketExportLocation info loc) (keySize k) giveup "No S3 credentials configured"
-- S3 has no move primitive; copy and delete. -- S3 has no move primitive; copy and delete.
renameExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Key -> ExportLocation -> ExportLocation -> Annex Bool renameExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex Bool
renameExportS3 u info (Just h) k src dest = checkVersioning info u k $ renameExportS3 r info k src dest = withS3HandleMaybe r $ \case
catchNonAsync go (\_ -> return False) Just h -> checkVersioning info (uuid r) k $
catchNonAsync (go h) (\_ -> return False)
Nothing -> do
warning $ needS3Creds (uuid r)
return False
where where
go = do go h = do
let co = S3.copyObject (bucket info) dstobject let co = S3.copyObject (bucket info) dstobject
(S3.ObjectId (bucket info) srcobject Nothing) (S3.ObjectId (bucket info) srcobject Nothing)
S3.CopyMetadata S3.CopyMetadata
@ -407,9 +411,6 @@ renameExportS3 u info (Just h) k src dest = checkVersioning info u k $
return True return True
srcobject = T.pack $ bucketExportLocation info src srcobject = T.pack $ bucketExportLocation info src
dstobject = T.pack $ bucketExportLocation info dest 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 {- Generate the bucket if it does not already exist, including creating the
- UUID file within the bucket. - UUID file within the bucket.

55
Remote/WebDAV.hs
View file

@ -79,14 +79,14 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
, lockContent = Nothing , lockContent = Nothing
, checkPresent = checkPresentDummy , checkPresent = checkPresentDummy
, checkPresentCheap = False , checkPresentCheap = False
, exportActions = withDAVHandle this $ \mh -> return $ ExportActions , exportActions = ExportActions
{ storeExport = storeExportDav mh { storeExport = storeExportDav this
, retrieveExport = retrieveExportDav mh , retrieveExport = retrieveExportDav this
, checkPresentExport = checkPresentExportDav this mh , checkPresentExport = checkPresentExportDav this
, removeExport = removeExportDav mh , removeExport = removeExportDav this
, removeExportDirectory = Just $ , removeExportDirectory = Just $
removeExportDirectoryDav mh removeExportDirectoryDav this
, renameExport = renameExportDav mh , renameExport = renameExportDav this
} }
, whereisKey = Nothing , whereisKey = Nothing
, remoteFsck = Nothing , remoteFsck = Nothing
@ -193,45 +193,46 @@ checkKey r chunkconfig (Just dav) k = do
existsDAV (keyLocation k) existsDAV (keyLocation k)
either giveup return v either giveup return v
storeExportDav :: Maybe DavHandle -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool storeExportDav :: Remote -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
storeExportDav mh f k loc p = runExport mh $ \dav -> do storeExportDav r f k loc p = withDAVHandle r $ \mh -> runExport mh $ \dav -> do
reqbody <- liftIO $ httpBodyStorer f p reqbody <- liftIO $ httpBodyStorer f p
storeHelper dav (keyTmpLocation k) (exportLocation loc) reqbody storeHelper dav (keyTmpLocation k) (exportLocation loc) reqbody
return True return True
retrieveExportDav :: Maybe DavHandle -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool retrieveExportDav :: Remote -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
retrieveExportDav mh _k loc d p = runExport mh $ \_dav -> do retrieveExportDav r _k loc d p = withDAVHandle r $ \mh -> runExport mh $ \_dav -> do
retrieveHelper (exportLocation loc) d p retrieveHelper (exportLocation loc) d p
return True return True
checkPresentExportDav :: Remote -> Maybe DavHandle -> Key -> ExportLocation -> Annex Bool checkPresentExportDav :: Remote -> Key -> ExportLocation -> Annex Bool
checkPresentExportDav r mh _k loc = case mh of checkPresentExportDav r _k loc = withDAVHandle r $ \case
Nothing -> giveup $ name r ++ " not configured" Nothing -> giveup $ name r ++ " not configured"
Just h -> liftIO $ do Just h -> liftIO $ do
v <- goDAV h $ existsDAV (exportLocation loc) v <- goDAV h $ existsDAV (exportLocation loc)
either giveup return v either giveup return v
removeExportDav :: Maybe DavHandle -> Key -> ExportLocation -> Annex Bool removeExportDav :: Remote -> Key -> ExportLocation -> Annex Bool
removeExportDav mh _k loc = runExport mh $ \_dav -> removeExportDav r _k loc = withDAVHandle r $ \mh -> runExport mh $ \_dav ->
removeHelper (exportLocation loc) removeHelper (exportLocation loc)
removeExportDirectoryDav :: Maybe DavHandle -> ExportDirectory -> Annex Bool removeExportDirectoryDav :: Remote -> ExportDirectory -> Annex Bool
removeExportDirectoryDav mh dir = runExport mh $ \_dav -> do removeExportDirectoryDav r dir = withDAVHandle r $ \mh -> runExport mh $ \_dav -> do
let d = fromExportDirectory dir let d = fromExportDirectory dir
debugDav $ "delContent " ++ d debugDav $ "delContent " ++ d
safely (inLocation d delContentM) safely (inLocation d delContentM)
>>= maybe (return False) (const $ return True) >>= maybe (return False) (const $ return True)
renameExportDav :: Maybe DavHandle -> Key -> ExportLocation -> ExportLocation -> Annex Bool renameExportDav :: Remote -> Key -> ExportLocation -> ExportLocation -> Annex Bool
renameExportDav Nothing _ _ _ = return False renameExportDav r _k src dest = withDAVHandle r $ \case
renameExportDav (Just h) _k src dest Just h
-- box.com's DAV endpoint has buggy handling of renames, -- box.com's DAV endpoint has buggy handling of renames,
-- so avoid renaming when using it. -- so avoid renaming when using it.
| boxComUrl `isPrefixOf` baseURL h = return False | boxComUrl `isPrefixOf` baseURL h -> return False
| otherwise = runExport (Just h) $ \dav -> do | otherwise -> runExport (Just h) $ \dav -> do
maybe noop (void . mkColRecursive) (locationParent (exportLocation dest)) maybe noop (void . mkColRecursive) (locationParent (exportLocation dest))
moveDAV (baseURL dav) (exportLocation src) (exportLocation dest) moveDAV (baseURL dav) (exportLocation src) (exportLocation dest)
return True return True
Nothing -> return False
runExport :: Maybe DavHandle -> (DavHandle -> DAVT IO Bool) -> Annex Bool runExport :: Maybe DavHandle -> (DavHandle -> DAVT IO Bool) -> Annex Bool
runExport Nothing _ = return False runExport Nothing _ = return False

2
Types/Remote.hs
View file

@ -103,7 +103,7 @@ data RemoteA a = Remote
-- operation. -- operation.
, checkPresentCheap :: Bool , checkPresentCheap :: Bool
-- Some remotes support exports of trees. -- Some remotes support exports of trees.
, exportActions :: a (ExportActions a) , exportActions :: ExportActions a
-- Some remotes can provide additional details for whereis. -- Some remotes can provide additional details for whereis.
, whereisKey :: Maybe (Key -> a [String]) , whereisKey :: Maybe (Key -> a [String])
-- Some remotes can run a fsck operation on the remote, -- Some remotes can run a fsck operation on the remote,