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

export: cache connections for S3 and webdav

Browse source
This commit is contained in:
Joey Hess 2017-09-12 16:59:04 -04:00
parent 7ad8e8b889
commit 9c3622882b
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
9 changed files with 98 additions and 90 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

76
Command/Export.hs
View file

@ -89,15 +89,18 @@ seek o = do
-- or tag.
inRepo (Git.Ref.tree (exportTreeish o))
old <- getExport (uuid r)
recordExportBeginning (uuid r) new
db <- openDb (uuid r)
ea <- exportActions r
recordExportBeginning (uuid r) new
liftIO $ print (old, new)
-- Clean up after incomplete export of a tree, in which
-- the next block of code below may have renamed some files to
-- temp files. Diff from the incomplete tree to the new tree,
-- and delete any temp files that the new tree can't use.
forM_ (concatMap incompleteExportedTreeish old) $ \incomplete ->
mapdiff (\diff -> startRecoverIncomplete r db (Git.DiffTree.srcsha diff) (Git.DiffTree.file diff))
mapdiff (\diff -> startRecoverIncomplete r ea db (Git.DiffTree.srcsha diff) (Git.DiffTree.file diff))
incomplete
new
@ -115,15 +118,15 @@ seek o = do
seekdiffmap $ \(ek, (moldf, mnewf)) ->
case (moldf, mnewf) of
(Just oldf, Just _newf) ->
startMoveToTempName r db oldf ek
startMoveToTempName r ea db oldf ek
(Just oldf, Nothing) ->
startUnexport' r db oldf ek
startUnexport' r ea db oldf ek
_ -> stop
-- Rename from temp to new files.
seekdiffmap $ \(ek, (moldf, mnewf)) ->
case (moldf, mnewf) of
(Just _oldf, Just newf) ->
startMoveFromTempName r db ek newf
startMoveFromTempName r ea db ek newf
_ -> stop
ts -> do
warning "Export conflict detected. Different trees have been exported to the same special remote. Resolving.."
@ -139,7 +142,7 @@ seek o = do
-- Don't rename to temp, because the
-- content is unknown; delete instead.
mapdiff
(\diff -> startUnexport r db (Git.DiffTree.file diff) (unexportboth diff))
(\diff -> startUnexport r ea db (Git.DiffTree.file diff) (unexportboth diff))
oldtreesha new
-- Waiting until now to record the export guarantees that,
@ -154,7 +157,7 @@ seek o = do
-- Export everything that is not yet exported.
(l, cleanup') <- inRepo $ Git.LsTree.lsTree new
seekActions $ pure $ map (startExport r db) l
seekActions $ pure $ map (startExport r ea db) l
void $ liftIO cleanup'
closeDb db
@ -187,23 +190,24 @@ mkDiffMap old new = do
| sha == nullSha = return Nothing
| otherwise = Just <$> exportKey sha
startExport :: Remote -> ExportHandle -> Git.LsTree.TreeItem -> CommandStart
startExport r db ti = do
startExport :: Remote -> ExportActions Annex -> ExportHandle -> Git.LsTree.TreeItem -> CommandStart
startExport r ea db ti = do
ek <- exportKey (Git.LsTree.sha ti)
stopUnless (liftIO $ notElem loc <$> getExportLocation db (asKey ek)) $ do
showStart "export" f
next $ performExport r db ek (Git.LsTree.sha ti) loc
next $ performExport r ea db ek (Git.LsTree.sha ti) loc
where
loc = ExportLocation $ toInternalGitPath f
f = getTopFilePath $ Git.LsTree.file ti
performExport :: Remote -> ExportHandle -> ExportKey -> Sha -> ExportLocation -> CommandPerform
performExport r db ek contentsha loc = do
let storer = storeExport $ exportActions r
performExport :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> Sha -> ExportLocation -> CommandPerform
performExport r ea db ek contentsha loc = do
let storer = storeExport ea
sent <- case ek of
AnnexKey k -> ifM (inAnnex k)
( metered Nothing k $ \m -> do
let rollback = void $ performUnexport r db [ek] loc
let rollback = void $
performUnexport r ea db [ek] loc
sendAnnex k rollback
(\f -> storer f k loc m)
, do
@ -227,29 +231,29 @@ cleanupExport r db ek loc = do
logChange (asKey ek) (uuid r) InfoPresent
return True
startUnexport :: Remote -> ExportHandle -> TopFilePath -> [Git.Sha] -> CommandStart
startUnexport r db f shas = do
startUnexport :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> [Git.Sha] -> CommandStart
startUnexport r ea db f shas = do
eks <- forM (filter (/= nullSha) shas) exportKey
if null eks
then stop
else do
showStart "unexport" f'
next $ performUnexport r db eks loc
next $ performUnexport r ea db eks loc
where
loc = ExportLocation $ toInternalGitPath f'
f' = getTopFilePath f
startUnexport' :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
startUnexport' r db f ek = do
startUnexport' :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
startUnexport' r ea db f ek = do
showStart "unexport" f'
next $ performUnexport r db [ek] loc
next $ performUnexport r ea db [ek] loc
where
loc = ExportLocation $ toInternalGitPath f'
f' = getTopFilePath f
performUnexport :: Remote -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandPerform
performUnexport r db eks loc = do
ifM (allM (\ek -> removeExport (exportActions r) (asKey ek) loc) eks)
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 db eks loc
, stop
)
@ -269,47 +273,47 @@ cleanupUnexport r db eks loc = do
logChange (asKey ek) (uuid r) InfoMissing
return True
startRecoverIncomplete :: Remote -> ExportHandle -> Git.Sha -> TopFilePath -> CommandStart
startRecoverIncomplete r db sha oldf
startRecoverIncomplete :: Remote -> ExportActions Annex -> ExportHandle -> Git.Sha -> TopFilePath -> CommandStart
startRecoverIncomplete r ea db sha oldf
| sha == nullSha = stop
| otherwise = do
ek <- exportKey sha
let loc@(ExportLocation f) = exportTempName ek
showStart "unexport" f
liftIO $ removeExportLocation db (asKey ek) oldloc
next $ performUnexport r db [ek] loc
next $ performUnexport r ea db [ek] loc
where
oldloc = ExportLocation $ toInternalGitPath oldf'
oldf' = getTopFilePath oldf
startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
startMoveToTempName r db f ek = do
startMoveToTempName :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
startMoveToTempName r ea db f ek = do
let tmploc@(ExportLocation tmpf) = exportTempName ek
showStart "rename" (f' ++ " -> " ++ tmpf)
next $ performRename r db ek loc tmploc
next $ performRename r ea db ek loc tmploc
where
loc = ExportLocation $ toInternalGitPath f'
f' = getTopFilePath f
startMoveFromTempName :: Remote -> ExportHandle -> ExportKey -> TopFilePath -> CommandStart
startMoveFromTempName r db ek f = do
startMoveFromTempName :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> TopFilePath -> CommandStart
startMoveFromTempName r ea db ek f = do
let tmploc@(ExportLocation tmpf) = exportTempName ek
stopUnless (liftIO $ elem tmploc <$> getExportLocation db (asKey ek)) $ do
showStart "rename" (tmpf ++ " -> " ++ f')
next $ performRename r db ek tmploc loc
next $ performRename r ea db ek tmploc loc
where
loc = ExportLocation $ toInternalGitPath f'
f' = getTopFilePath f
performRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform
performRename r db ek src dest = do
ifM (renameExport (exportActions r) (asKey ek) src dest)
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 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 db [ek] src
performUnexport r ea db [ek] src
)
cleanupRename :: ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandCleanup

2
Logs/Export.hs
View file

@ -24,7 +24,7 @@ data Exported = Exported
{ exportedTreeish :: Git.Ref
, incompleteExportedTreeish :: [Git.Ref]
}
deriving (Eq)
deriving (Eq, Show)
-- | Get what's been exported to a special remote.
--

2
Remote/Directory.hs
View file

@ -61,7 +61,7 @@ gen r u c gc = do
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = True
, exportActions = ExportActions
, exportActions = return $ ExportActions
{ storeExport = storeExportDirectory dir
, retrieveExport = retrieveExportDirectory dir
, removeExport = removeExportDirectory dir

2
Remote/External.hs
View file

@ -70,7 +70,7 @@ gen r u c gc
avail <- getAvailability external r gc
exportsupported <- checkExportSupported' external
let exportactions = if exportsupported
then ExportActions
then return $ ExportActions
{ storeExport = storeExportExternal external
, retrieveExport = retrieveExportExternal external
, removeExport = removeExportExternal external

16
Remote/Helper/Export.hs
View file

@ -26,8 +26,8 @@ class HasExportUnsupported a where
instance HasExportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where
exportUnsupported = \_ _ -> return False
instance HasExportUnsupported (ExportActions Annex) where
exportUnsupported = ExportActions
instance HasExportUnsupported (Annex (ExportActions Annex)) where
exportUnsupported = return $ ExportActions
{ storeExport = \_ _ _ _ -> do
warning "store export is unsupported"
return False
@ -103,7 +103,9 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
[] -> do
warning "unknown export location"
return False
(l:_) -> retrieveExport (exportActions r) k l dest p
(l:_) -> do
ea <- exportActions r
retrieveExport ea k l dest p
else do
warning $ "exported content cannot be verified due to using the " ++ formatKeyVariety (keyVariety k) ++ " backend"
return False
@ -111,8 +113,9 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
-- Remove all files a key was exported to.
, removeKey = \k -> do
locs <- liftIO $ getExportLocation db k
ea <- exportActions r
oks <- forM locs $ \loc -> do
ok <- removeExport (exportActions r) k loc
ok <- removeExport ea k loc
when ok $
liftIO $ removeExportLocation db k loc
return ok
@ -125,8 +128,9 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
-- Check if any of the files a key was exported
-- to are present. This doesn't guarantee the
-- export contains the right content.
, checkPresent = \k ->
anyM (checkPresentExport (exportActions r) k)
, checkPresent = \k -> do
ea <- exportActions r
anyM (checkPresentExport ea k)
=<< liftIO (getExportLocation db k)
, mkUnavailable = return Nothing
, getInfo = do

46
Remote/S3.hs
View file

@ -86,13 +86,14 @@ gen r u c gc = do
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
, exportActions = ExportActions
{ storeExport = storeExportS3 this info
, retrieveExport = retrieveExportS3 this info
, removeExport = removeExportS3 this info
, checkPresentExport = checkPresentExportS3 this info
, renameExport = renameExportS3 this info
}
, exportActions = withS3Handle c gc u $ \h ->
return $ ExportActions
{ storeExport = storeExportS3 info h
, retrieveExport = retrieveExportS3 info h
, removeExport = removeExportS3 info h
, checkPresentExport = checkPresentExportS3 info h
, renameExport = renameExportS3 info h
}
, whereisKey = Just (getWebUrls info c)
, remoteFsck = Nothing
, repairRepo = Nothing
@ -321,41 +322,40 @@ checkKeyHelper info h object = do
| otherwise = Nothing
#endif
storeExportS3 :: Remote -> S3Info -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
storeExportS3 r info f _k loc p =
storeExportS3 :: S3Info -> S3Handle -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
storeExportS3 info h f _k loc p =
catchNonAsync go (\e -> warning (show e) >> return False)
where
go = withS3Handle (config r) (gitconfig r) (uuid r) $ \h -> do
go = do
storeHelper info h f (T.pack $ bucketExportLocation info loc) p
return True
retrieveExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
retrieveExportS3 r info _k loc f p =
retrieveExportS3 :: S3Info -> S3Handle -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
retrieveExportS3 info h _k loc f p =
catchNonAsync go (\e -> warning (show e) >> return False)
where
go = withS3Handle (config r) (gitconfig r) (uuid r) $ \h -> do
go = do
retrieveHelper info h (T.pack $ bucketExportLocation info loc) f p
return True
removeExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> Annex Bool
removeExportS3 r info _k loc =
removeExportS3 :: S3Info -> S3Handle -> Key -> ExportLocation -> Annex Bool
removeExportS3 info h _k loc =
catchNonAsync go (\e -> warning (show e) >> return False)
where
go = withS3Handle (config r) (gitconfig r) (uuid r) $ \h -> do
go = do
res <- tryNonAsync $ sendS3Handle h $
S3.DeleteObject (T.pack $ bucketExportLocation info loc) (bucket info)
return $ either (const False) (const True) res
checkPresentExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> Annex Bool
checkPresentExportS3 r info _k loc =
withS3Handle (config r) (gitconfig r) (uuid r) $ \h -> do
checkKeyHelper info h (T.pack $ bucketExportLocation info loc)
checkPresentExportS3 :: S3Info -> S3Handle -> Key -> ExportLocation -> Annex Bool
checkPresentExportS3 info h _k loc =
checkKeyHelper info h (T.pack $ bucketExportLocation info loc)
-- S3 has no move primitive; copy and delete.
renameExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex Bool
renameExportS3 r info _k src dest = catchNonAsync go (\_ -> return False)
renameExportS3 :: S3Info -> S3Handle -> Key -> ExportLocation -> ExportLocation -> Annex Bool
renameExportS3 info h _k src dest = catchNonAsync go (\_ -> return False)
where
go = withS3Handle (config r) (gitconfig r) (uuid r) $ \h -> do
go = do
let co = S3.copyObject (bucket info) dstobject
(S3.ObjectId (bucket info) srcobject Nothing)
S3.CopyMetadata

39
Remote/WebDAV.hs
View file

@ -70,12 +70,12 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
, exportActions = ExportActions
{ storeExport = storeExportDav this
, retrieveExport = retrieveExportDav this
, removeExport = removeExportDav this
, checkPresentExport = checkPresentExportDav this
, renameExport = renameExportDav this
, exportActions = withDAVHandle this $ \mh -> return $ ExportActions
{ storeExport = storeExportDav mh
, retrieveExport = retrieveExportDav mh
, removeExport = removeExportDav mh
, checkPresentExport = checkPresentExportDav this mh
, renameExport = renameExportDav mh
}
, whereisKey = Nothing
, remoteFsck = Nothing
@ -178,37 +178,36 @@ checkKey r chunkconfig (Just dav) k = do
existsDAV (keyLocation k)
either giveup return v
storeExportDav :: Remote -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
storeExportDav r f _k loc p = runExport r $ \dav -> do
storeExportDav :: Maybe DavHandle -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
storeExportDav mh f _k loc p = runExport mh $ \dav -> do
reqbody <- liftIO $ httpBodyStorer f p
storeHelper dav (exportTmpLocation loc) (exportLocation loc) reqbody
return True
retrieveExportDav :: Remote -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
retrieveExportDav r _k loc d p = runExport r $ \_dav -> do
retrieveExportDav :: Maybe DavHandle -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
retrieveExportDav mh _k loc d p = runExport mh $ \_dav -> do
retrieveHelper (exportLocation loc) d p
return True
removeExportDav :: Remote -> Key -> ExportLocation -> Annex Bool
removeExportDav r _k loc = runExport r $ \_dav ->
removeExportDav :: Maybe DavHandle -> Key -> ExportLocation -> Annex Bool
removeExportDav mh _k loc = runExport mh $ \_dav ->
removeHelper (exportLocation loc)
checkPresentExportDav :: Remote -> Key -> ExportLocation -> Annex Bool
checkPresentExportDav r _k loc = withDAVHandle r $ \mh -> case mh of
checkPresentExportDav :: Remote -> Maybe DavHandle -> Key -> ExportLocation -> Annex Bool
checkPresentExportDav r mh _k loc = case mh of
Nothing -> giveup $ name r ++ " not configured"
Just h -> liftIO $ do
v <- goDAV h $ existsDAV (exportLocation loc)
either giveup return v
renameExportDav :: Remote -> Key -> ExportLocation -> ExportLocation -> Annex Bool
renameExportDav r _k src dest = runExport r $ \dav -> do
renameExportDav :: Maybe DavHandle -> Key -> ExportLocation -> ExportLocation -> Annex Bool
renameExportDav mh _k src dest = runExport mh $ \dav -> do
moveDAV (baseURL dav) (exportLocation src) (exportLocation dest)
return True
runExport :: Remote -> (DavHandle -> DAVT IO Bool) -> Annex Bool
runExport r a = withDAVHandle r $ \mh -> case mh of
Nothing -> return False
Just h -> fromMaybe False <$> liftIO (goDAV h $ safely (a h))
runExport :: Maybe DavHandle -> (DavHandle -> DAVT IO Bool) -> Annex Bool
runExport Nothing _ = return False
runExport (Just h) a = fromMaybe False <$> liftIO (goDAV h $ safely (a h))
configUrl :: Remote -> Maybe URLString
configUrl r = fixup <$> M.lookup "url" (config r)

2
Types/Remote.hs
View file

@ -100,7 +100,7 @@ data RemoteA a = Remote
-- operation.
, checkPresentCheap :: Bool
-- Some remotes support exports of trees.
, exportActions :: ExportActions a
, exportActions :: a (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,

3
doc/todo/export.mdwn
View file

@ -48,4 +48,5 @@ Low priority:
fails to actually delete it.
Hypothesis: Those are done in separate http connections and it might be
talking to two different backend servers that are out of sync.
So, making export cache connections might help.
So, making export cache connections might help. Update: No, caching
connections did not solve it.