summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Command/Export.hs76
-rw-r--r--Logs/Export.hs2
-rw-r--r--Remote/Directory.hs2
-rw-r--r--Remote/External.hs2
-rw-r--r--Remote/Helper/Export.hs16
-rw-r--r--Remote/S3.hs46
-rw-r--r--Remote/WebDAV.hs39
-rw-r--r--Types/Remote.hs2
-rw-r--r--doc/todo/export.mdwn3
9 files changed, 98 insertions, 90 deletions
diff --git a/Command/Export.hs b/Command/Export.hs
index 8f1a6f149..611656581 100644
--- a/Command/Export.hs
+++ b/Command/Export.hs
@@ -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
diff --git a/Logs/Export.hs b/Logs/Export.hs
index 2327d70d1..dc9952b86 100644
--- a/Logs/Export.hs
+++ b/Logs/Export.hs
@@ -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.
--
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index c17ed80a5..c3ebeb899 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -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
diff --git a/Remote/External.hs b/Remote/External.hs
index ed00cc93f..fd4fd0649 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -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
diff --git a/Remote/Helper/Export.hs b/Remote/Helper/Export.hs
index 517b4333f..4616d4bb1 100644
--- a/Remote/Helper/Export.hs
+++ b/Remote/Helper/Export.hs
@@ -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
diff --git a/Remote/S3.hs b/Remote/S3.hs
index 77cd7f74b..8b6fe6103 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -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
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index 12b9d40b2..c45776a69 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -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)
diff --git a/Types/Remote.hs b/Types/Remote.hs
index 511653e98..272693296 100644
--- a/Types/Remote.hs
+++ b/Types/Remote.hs
@@ -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,
diff --git a/doc/todo/export.mdwn b/doc/todo/export.mdwn
index 9584d8904..cef5a749d 100644
--- a/doc/todo/export.mdwn
+++ b/doc/todo/export.mdwn
@@ -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.
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-23 19:11:34 +0000