2017-08-29 18:58:38 +00:00
|
|
|
{- git-annex command
|
|
|
|
-
|
2024-08-02 22:43:10 +00:00
|
|
|
- Copyright 2017-2024 Joey Hess <id@joeyh.name>
|
2017-08-29 18:58:38 +00:00
|
|
|
-
|
2019-03-13 19:48:14 +00:00
|
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
2017-08-29 18:58:38 +00:00
|
|
|
-}
|
|
|
|
|
2017-09-19 18:20:47 +00:00
|
|
|
{-# LANGUAGE TupleSections, BangPatterns #-}
|
2019-12-04 17:15:34 +00:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
2017-09-07 18:32:47 +00:00
|
|
|
|
2017-08-29 18:58:38 +00:00
|
|
|
module Command.Export where
|
|
|
|
|
|
|
|
import Command
|
2017-09-12 18:19:26 +00:00
|
|
|
import qualified Annex
|
2017-08-29 18:58:38 +00:00
|
|
|
import qualified Git
|
|
|
|
import qualified Git.DiffTree
|
2017-08-31 17:29:54 +00:00
|
|
|
import qualified Git.LsTree
|
2019-05-20 15:54:55 +00:00
|
|
|
import qualified Git.Tree
|
2017-08-31 19:41:48 +00:00
|
|
|
import qualified Git.Ref
|
2017-08-31 17:29:54 +00:00
|
|
|
import Git.Types
|
2017-08-29 18:58:38 +00:00
|
|
|
import Git.FilePath
|
2017-08-31 19:41:48 +00:00
|
|
|
import Git.Sha
|
2020-05-15 16:17:15 +00:00
|
|
|
import qualified Remote
|
2024-08-02 22:43:10 +00:00
|
|
|
import qualified Types.Remote as Remote
|
2017-08-29 18:58:38 +00:00
|
|
|
import Types.Remote
|
2017-09-15 20:34:45 +00:00
|
|
|
import Types.Export
|
2017-09-18 17:57:25 +00:00
|
|
|
import Annex.Export
|
2017-08-29 18:58:38 +00:00
|
|
|
import Annex.Content
|
2017-09-20 16:56:17 +00:00
|
|
|
import Annex.Transfer
|
2017-08-29 18:58:38 +00:00
|
|
|
import Annex.CatFile
|
2019-05-20 15:54:55 +00:00
|
|
|
import Annex.FileMatcher
|
2019-03-01 20:08:18 +00:00
|
|
|
import Annex.RemoteTrackingBranch
|
2024-08-02 22:43:10 +00:00
|
|
|
import Annex.SpecialRemote.Config
|
2017-08-31 16:37:25 +00:00
|
|
|
import Logs.Location
|
2017-08-31 19:41:48 +00:00
|
|
|
import Logs.Export
|
2019-05-20 15:54:55 +00:00
|
|
|
import Logs.PreferredContent
|
2017-09-04 17:52:22 +00:00
|
|
|
import Database.Export
|
2017-09-19 17:05:43 +00:00
|
|
|
import Config
|
2017-08-29 18:58:38 +00:00
|
|
|
import Utility.Tmp
|
2017-09-20 16:56:17 +00:00
|
|
|
import Utility.Metered
|
2019-05-20 15:54:55 +00:00
|
|
|
import Utility.Matcher
|
2017-08-29 18:58:38 +00:00
|
|
|
|
2020-04-07 21:41:09 +00:00
|
|
|
import qualified Data.ByteString.Char8 as S8
|
2017-08-29 18:58:38 +00:00
|
|
|
import qualified Data.ByteString.Lazy as L
|
2017-09-07 18:32:47 +00:00
|
|
|
import qualified Data.Map as M
|
2017-09-19 18:20:47 +00:00
|
|
|
import Control.Concurrent
|
2017-08-29 18:58:38 +00:00
|
|
|
|
|
|
|
cmd :: Command
|
2022-06-29 17:28:08 +00:00
|
|
|
cmd = withAnnexOptions [jobsOption, jsonOptions, jsonProgressOption] $
|
2020-05-26 14:31:10 +00:00
|
|
|
command "export" SectionCommon
|
2020-12-17 16:51:49 +00:00
|
|
|
"export a tree of files to a special remote"
|
2020-05-26 14:31:10 +00:00
|
|
|
paramTreeish (seek <$$> optParser)
|
2017-08-29 18:58:38 +00:00
|
|
|
|
|
|
|
data ExportOptions = ExportOptions
|
|
|
|
{ exportTreeish :: Git.Ref
|
2019-03-01 20:08:18 +00:00
|
|
|
-- ^ can be a tree, a branch, a commit, or a tag
|
2017-08-29 18:58:38 +00:00
|
|
|
, exportRemote :: DeferredParse Remote
|
2017-09-19 17:05:43 +00:00
|
|
|
, exportTracking :: Bool
|
2017-08-29 18:58:38 +00:00
|
|
|
}
|
|
|
|
|
|
|
|
optParser :: CmdParamsDesc -> Parser ExportOptions
|
|
|
|
optParser _ = ExportOptions
|
|
|
|
<$> (Git.Ref <$> parsetreeish)
|
2023-04-05 19:46:51 +00:00
|
|
|
<*> (mkParseRemoteOption <$> parseToOption)
|
2017-09-19 17:05:43 +00:00
|
|
|
<*> parsetracking
|
2017-08-29 18:58:38 +00:00
|
|
|
where
|
|
|
|
parsetreeish = argument str
|
|
|
|
( metavar paramTreeish
|
|
|
|
)
|
2017-09-19 17:05:43 +00:00
|
|
|
parsetracking = switch
|
|
|
|
( long "tracking"
|
2019-02-23 19:48:25 +00:00
|
|
|
<> help ("track changes to the " ++ paramTreeish ++ " (deprecated)")
|
2017-09-19 17:05:43 +00:00
|
|
|
)
|
2017-08-29 18:58:38 +00:00
|
|
|
|
2017-09-06 19:33:40 +00:00
|
|
|
-- To handle renames which swap files, the exported file is first renamed
|
|
|
|
-- to a stable temporary name based on the key.
|
2021-03-05 18:03:51 +00:00
|
|
|
exportTempName :: Key -> ExportLocation
|
2019-12-04 17:15:34 +00:00
|
|
|
exportTempName ek = mkExportLocation $ toRawFilePath $
|
2021-03-05 18:03:51 +00:00
|
|
|
".git-annex-tmp-content-" ++ serializeKey ek
|
2017-09-06 19:33:40 +00:00
|
|
|
|
2017-08-29 18:58:38 +00:00
|
|
|
seek :: ExportOptions -> CommandSeek
|
2020-05-26 15:43:58 +00:00
|
|
|
seek o = startConcurrency commandStages $ do
|
2017-08-29 18:58:38 +00:00
|
|
|
r <- getParsed (exportRemote o)
|
2017-09-07 17:45:31 +00:00
|
|
|
unlessM (isExportSupported r) $
|
2017-09-04 17:55:49 +00:00
|
|
|
giveup "That remote does not support exports."
|
2019-03-01 20:08:18 +00:00
|
|
|
|
|
|
|
-- handle deprecated option
|
2017-09-19 18:20:47 +00:00
|
|
|
when (exportTracking o) $
|
2020-02-19 17:45:11 +00:00
|
|
|
setConfig (remoteAnnexConfig r "tracking-branch")
|
2017-09-19 18:20:47 +00:00
|
|
|
(fromRef $ exportTreeish o)
|
2019-03-01 20:08:18 +00:00
|
|
|
|
2021-03-12 17:28:43 +00:00
|
|
|
tree <- filterExport r =<<
|
2019-05-20 15:54:55 +00:00
|
|
|
fromMaybe (giveup "unknown tree") <$>
|
2019-03-11 17:18:20 +00:00
|
|
|
inRepo (Git.Ref.tree (exportTreeish o))
|
|
|
|
|
|
|
|
mtbcommitsha <- getExportCommit r (exportTreeish o)
|
2024-08-06 18:18:30 +00:00
|
|
|
seekExport r tree mtbcommitsha
|
2019-03-01 20:08:18 +00:00
|
|
|
|
2024-08-06 18:18:30 +00:00
|
|
|
seekExport :: Remote -> ExportFiltered Git.Ref -> Maybe (RemoteTrackingBranch, Sha) -> CommandSeek
|
|
|
|
seekExport r tree mtbcommitsha = do
|
2019-03-07 19:59:44 +00:00
|
|
|
db <- openDb (uuid r)
|
|
|
|
writeLockDbWhile db $ do
|
2019-03-01 20:08:18 +00:00
|
|
|
changeExport r db tree
|
2022-06-28 19:28:14 +00:00
|
|
|
unlessM (Annex.getRead Annex.fast) $ do
|
2019-03-01 20:08:18 +00:00
|
|
|
void $ fillExport r db tree mtbcommitsha
|
2019-03-07 19:59:44 +00:00
|
|
|
closeDb db
|
2017-09-19 18:20:47 +00:00
|
|
|
|
2019-03-01 20:08:18 +00:00
|
|
|
-- | When the treeish is a branch like master or refs/heads/master
|
|
|
|
-- (but not refs/remotes/...), find the commit it points to
|
|
|
|
-- and the corresponding remote tracking branch.
|
2019-03-11 17:18:20 +00:00
|
|
|
--
|
|
|
|
-- The treeish may also be a subdir within a branch, like master:subdir,
|
|
|
|
-- that results in this returning the same thing it does for the master
|
|
|
|
-- branch.
|
2019-03-01 20:08:18 +00:00
|
|
|
getExportCommit :: Remote -> Git.Ref -> Annex (Maybe (RemoteTrackingBranch, Sha))
|
|
|
|
getExportCommit r treeish
|
|
|
|
| '/' `notElem` fromRef baseref = do
|
|
|
|
let tb = mkRemoteTrackingBranch r baseref
|
|
|
|
commitsha <- inRepo $ Git.Ref.sha $ Git.Ref.underBase refsheads baseref
|
|
|
|
return (fmap (tb, ) commitsha)
|
|
|
|
| otherwise = return Nothing
|
|
|
|
where
|
2020-04-07 21:41:09 +00:00
|
|
|
baseref = Ref $ S8.takeWhile (/= ':') $ fromRef' $
|
2019-03-11 17:18:20 +00:00
|
|
|
Git.Ref.removeBase refsheads treeish
|
2019-03-01 20:08:18 +00:00
|
|
|
refsheads = "refs/heads"
|
|
|
|
|
2017-09-19 18:20:47 +00:00
|
|
|
-- | Changes what's exported to the remote. Does not upload any new
|
|
|
|
-- files, but does delete and rename files already exported to the remote.
|
2021-03-12 17:28:43 +00:00
|
|
|
changeExport :: Remote -> ExportHandle -> ExportFiltered Git.Ref -> CommandSeek
|
|
|
|
changeExport r db (ExportFiltered new) = do
|
2017-08-31 19:41:48 +00:00
|
|
|
old <- getExport (uuid r)
|
2017-09-12 20:59:04 +00:00
|
|
|
recordExportBeginning (uuid r) new
|
2017-09-19 17:05:43 +00:00
|
|
|
|
2017-09-06 19:33:40 +00:00
|
|
|
-- 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.
|
2018-10-01 18:12:06 +00:00
|
|
|
let recover diff = commandAction $
|
2019-01-30 18:55:28 +00:00
|
|
|
startRecoverIncomplete r db
|
2018-10-01 18:12:06 +00:00
|
|
|
(Git.DiffTree.srcsha diff)
|
|
|
|
(Git.DiffTree.file diff)
|
2019-01-30 16:36:30 +00:00
|
|
|
forM_ (incompleteExportedTreeishes old) $ \incomplete ->
|
2018-10-01 18:12:06 +00:00
|
|
|
mapdiff recover incomplete new
|
2020-05-26 17:44:43 +00:00
|
|
|
waitForAllRunningCommandActions
|
2017-09-06 19:33:40 +00:00
|
|
|
|
|
|
|
-- Diff the old and new trees, and delete or rename to new name all
|
|
|
|
-- changed files in the export. After this, every file that remains
|
|
|
|
-- in the export will have the content from the new treeish.
|
2017-08-31 19:41:48 +00:00
|
|
|
--
|
2017-09-18 18:24:42 +00:00
|
|
|
-- When there was an export conflict, this resolves it.
|
|
|
|
--
|
|
|
|
-- The ExportTree is also updated here to reflect the new tree.
|
2019-01-30 16:36:30 +00:00
|
|
|
case exportedTreeishes old of
|
2017-09-18 18:24:42 +00:00
|
|
|
[] -> updateExportTree db emptyTree new
|
2017-09-06 19:33:40 +00:00
|
|
|
[oldtreesha] -> do
|
2017-09-18 18:24:42 +00:00
|
|
|
diffmap <- mkDiffMap oldtreesha new db
|
2022-11-09 20:24:37 +00:00
|
|
|
let seekdiffmap a = mapM_ a (M.toList diffmap)
|
2024-08-04 15:58:07 +00:00
|
|
|
let disposeoldf = \ek oldf -> commandAction $
|
|
|
|
startDispose r db oldf ek
|
2022-11-09 20:24:37 +00:00
|
|
|
seekdiffmap $ \case
|
|
|
|
(ek, (oldf:oldfs, _newf:_)) -> do
|
|
|
|
commandAction $
|
2019-01-30 18:55:28 +00:00
|
|
|
startMoveToTempName r db oldf ek
|
2024-08-04 15:58:07 +00:00
|
|
|
forM_ oldfs (disposeoldf ek)
|
2022-11-09 20:24:37 +00:00
|
|
|
(ek, (oldfs, [])) ->
|
2024-08-04 15:58:07 +00:00
|
|
|
forM_ oldfs (disposeoldf ek)
|
2022-11-09 20:24:37 +00:00
|
|
|
(_ek, ([], _)) -> noop
|
2020-05-26 17:44:43 +00:00
|
|
|
waitForAllRunningCommandActions
|
2017-09-06 19:33:40 +00:00
|
|
|
-- Rename from temp to new files.
|
2022-11-09 20:24:37 +00:00
|
|
|
seekdiffmap $ \case
|
|
|
|
(ek, (_oldf:_, newf:_)) -> commandAction $
|
|
|
|
startMoveFromTempName r db ek newf
|
|
|
|
_ -> noop
|
2020-05-26 17:44:43 +00:00
|
|
|
waitForAllRunningCommandActions
|
2017-09-06 19:33:40 +00:00
|
|
|
ts -> do
|
2019-04-09 17:03:59 +00:00
|
|
|
warning "Resolving export conflict.."
|
2017-09-06 19:33:40 +00:00
|
|
|
forM_ ts $ \oldtreesha -> do
|
|
|
|
-- Unexport both the srcsha and the dstsha,
|
|
|
|
-- because the wrong content may have
|
|
|
|
-- been renamed to the dstsha due to the
|
|
|
|
-- export conflict.
|
|
|
|
let unexportboth d =
|
|
|
|
[ Git.DiffTree.srcsha d
|
|
|
|
, Git.DiffTree.dstsha d
|
|
|
|
]
|
|
|
|
-- Don't rename to temp, because the
|
2017-09-07 18:32:47 +00:00
|
|
|
-- content is unknown; delete instead.
|
2017-09-06 19:33:40 +00:00
|
|
|
mapdiff
|
2019-01-30 18:55:28 +00:00
|
|
|
(\diff -> commandAction $ startUnexport r db (Git.DiffTree.file diff) (unexportboth diff))
|
2017-09-06 19:33:40 +00:00
|
|
|
oldtreesha new
|
2017-09-18 18:24:42 +00:00
|
|
|
updateExportTree db emptyTree new
|
2020-05-26 17:44:43 +00:00
|
|
|
waitForAllRunningCommandActions
|
2017-09-18 22:40:16 +00:00
|
|
|
liftIO $ recordExportTreeCurrent db new
|
2017-08-31 19:41:48 +00:00
|
|
|
|
|
|
|
-- Waiting until now to record the export guarantees that,
|
|
|
|
-- if this export is interrupted, there are no files left over
|
|
|
|
-- from a previous export, that are not part of this export.
|
2017-09-12 18:19:26 +00:00
|
|
|
c <- Annex.getState Annex.errcounter
|
2017-09-18 17:57:25 +00:00
|
|
|
when (c == 0) $ do
|
2020-12-23 18:27:38 +00:00
|
|
|
recordExportUnderway (uuid r) $ ExportChange
|
2019-01-30 16:36:30 +00:00
|
|
|
{ oldTreeish = exportedTreeishes old
|
2017-09-12 18:19:26 +00:00
|
|
|
, newTreeish = new
|
|
|
|
}
|
2017-09-06 19:33:40 +00:00
|
|
|
where
|
|
|
|
mapdiff a oldtreesha newtreesha = do
|
|
|
|
(diff, cleanup) <- inRepo $
|
|
|
|
Git.DiffTree.diffTreeRecursive oldtreesha newtreesha
|
2020-07-10 17:54:52 +00:00
|
|
|
sequence_ $ map a diff
|
2017-09-06 19:33:40 +00:00
|
|
|
void $ liftIO cleanup
|
2017-09-04 18:00:54 +00:00
|
|
|
|
2021-03-05 18:03:51 +00:00
|
|
|
-- Map of old and new filenames for each changed Key in a diff.
|
2022-11-09 20:24:37 +00:00
|
|
|
type DiffMap = M.Map Key ([TopFilePath], [TopFilePath])
|
2017-09-07 18:32:47 +00:00
|
|
|
|
2017-09-18 18:24:42 +00:00
|
|
|
mkDiffMap :: Git.Ref -> Git.Ref -> ExportHandle -> Annex DiffMap
|
|
|
|
mkDiffMap old new db = do
|
2017-09-07 18:32:47 +00:00
|
|
|
(diff, cleanup) <- inRepo $ Git.DiffTree.diffTreeRecursive old new
|
|
|
|
diffmap <- M.fromListWith combinedm . concat <$> forM diff mkdm
|
|
|
|
void $ liftIO cleanup
|
|
|
|
return diffmap
|
|
|
|
where
|
2022-11-09 20:24:37 +00:00
|
|
|
combinedm (srca, dsta) (srcb, dstb) = (srca ++ srcb, dsta ++ dstb)
|
2017-09-07 18:32:47 +00:00
|
|
|
mkdm i = do
|
2017-09-18 17:57:25 +00:00
|
|
|
srcek <- getek (Git.DiffTree.srcsha i)
|
|
|
|
dstek <- getek (Git.DiffTree.dstsha i)
|
2017-09-18 18:24:42 +00:00
|
|
|
updateExportTree' db srcek dstek i
|
2017-09-07 18:32:47 +00:00
|
|
|
return $ catMaybes
|
2022-11-09 20:24:37 +00:00
|
|
|
[ (, ([Git.DiffTree.file i], [])) <$> srcek
|
|
|
|
, (, ([], [Git.DiffTree.file i])) <$> dstek
|
2017-09-07 18:32:47 +00:00
|
|
|
]
|
2017-09-18 17:57:25 +00:00
|
|
|
getek sha
|
2020-01-07 15:35:17 +00:00
|
|
|
| sha `elem` nullShas = return Nothing
|
2017-09-07 18:32:47 +00:00
|
|
|
| otherwise = Just <$> exportKey sha
|
|
|
|
|
2019-03-01 20:08:18 +00:00
|
|
|
newtype FileUploaded = FileUploaded { fromFileUploaded :: Bool }
|
|
|
|
|
|
|
|
newtype AllFilled = AllFilled { fromAllFilled :: Bool }
|
|
|
|
|
|
|
|
-- | Upload all exported files that are not yet in the remote.
|
|
|
|
--
|
|
|
|
-- Returns True when some files were uploaded (perhaps not all of them).
|
|
|
|
--
|
|
|
|
-- Once all exported files have reached the remote, updates the
|
|
|
|
-- remote tracking branch.
|
2021-03-12 17:28:43 +00:00
|
|
|
fillExport :: Remote -> ExportHandle -> ExportFiltered Git.Ref -> Maybe (RemoteTrackingBranch, Sha) -> Annex Bool
|
|
|
|
fillExport r db (ExportFiltered newtree) mtbcommitsha = do
|
2021-03-23 16:44:29 +00:00
|
|
|
(l, cleanup) <- inRepo $ Git.LsTree.lsTree
|
|
|
|
Git.LsTree.LsTreeRecursive
|
|
|
|
(Git.LsTree.LsTreeLong False)
|
|
|
|
newtree
|
2019-03-01 20:08:18 +00:00
|
|
|
cvar <- liftIO $ newMVar (FileUploaded False)
|
|
|
|
allfilledvar <- liftIO $ newMVar (AllFilled True)
|
2021-03-12 16:19:31 +00:00
|
|
|
commandActions $
|
2021-03-12 17:28:43 +00:00
|
|
|
map (startExport r db cvar allfilledvar) l
|
2017-09-19 18:20:47 +00:00
|
|
|
void $ liftIO $ cleanup
|
2020-05-26 17:44:43 +00:00
|
|
|
waitForAllRunningCommandActions
|
2017-09-19 18:20:47 +00:00
|
|
|
|
2019-03-01 20:08:18 +00:00
|
|
|
case mtbcommitsha of
|
|
|
|
Nothing -> noop
|
|
|
|
Just (tb, commitsha) ->
|
|
|
|
whenM (liftIO $ fromAllFilled <$> takeMVar allfilledvar) $
|
2019-05-06 17:56:39 +00:00
|
|
|
makeRemoteTrackingBranchMergeCommit tb commitsha
|
2019-05-01 17:13:00 +00:00
|
|
|
>>= setRemoteTrackingBranch tb
|
2019-03-01 20:08:18 +00:00
|
|
|
|
|
|
|
liftIO $ fromFileUploaded <$> takeMVar cvar
|
|
|
|
|
|
|
|
startExport :: Remote -> ExportHandle -> MVar FileUploaded -> MVar AllFilled -> Git.LsTree.TreeItem -> CommandStart
|
|
|
|
startExport r db cvar allfilledvar ti = do
|
2017-08-31 17:29:54 +00:00
|
|
|
ek <- exportKey (Git.LsTree.sha ti)
|
make CommandStart return a StartMessage
The goal is to be able to run CommandStart in the main thread when -J is
used, rather than unncessarily passing it off to a worker thread, which
incurs overhead that is signficant when the CommandStart is going to
quickly decide to stop.
To do that, the message it displays needs to be displayed in the worker
thread, after the CommandStart has run.
Also, the change will mean that CommandStart will no longer necessarily
run with the same Annex state as CommandPerform. While its docs already
said it should avoid modifying Annex state, I audited all the
CommandStart code as part of the conversion. (Note that CommandSeek
already sometimes runs with a different Annex state, and that has not been
a source of any problems, so I am not too worried that this change will
lead to breakage going forward.)
The only modification of Annex state I found was it calling
allowMessages in some Commands that default to noMessages. Dealt with
that by adding a startCustomOutput and a startingUsualMessages.
This lets a command start with noMessages and then select the output it
wants for each CommandStart.
One bit of breakage: onlyActionOn has been removed from commands that used it.
The plan is that, since a StartMessage contains an ActionItem,
when a Key can be extracted from that, the parallel job runner can
run onlyActionOn' automatically. Then commands won't need to worry about
this detail. Future work.
Otherwise, this was a fairly straightforward process of making each
CommandStart compile again. Hopefully other behavior changes were mostly
avoided.
In a few cases, a command had a CommandStart that called a CommandPerform
that then called showStart multiple times. I have collapsed those
down to a single start action. The main command to perhaps suffer from it
is Command.Direct, which used to show a start for each file, and no
longer does.
Another minor behavior change is that some commands used showStart
before, but had an associated file and a Key available, so were changed
to ShowStart with an ActionItemAssociatedFile. That will not change the
normal output or behavior, but --json output will now include the key.
This should not break it for anyone using a real json parser.
2019-06-06 19:42:30 +00:00
|
|
|
stopUnless (notrecordedpresent ek) $
|
2020-09-14 20:49:33 +00:00
|
|
|
starting ("export " ++ name r) ai si $
|
2021-03-05 18:03:51 +00:00
|
|
|
ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) ek loc))
|
make CommandStart return a StartMessage
The goal is to be able to run CommandStart in the main thread when -J is
used, rather than unncessarily passing it off to a worker thread, which
incurs overhead that is signficant when the CommandStart is going to
quickly decide to stop.
To do that, the message it displays needs to be displayed in the worker
thread, after the CommandStart has run.
Also, the change will mean that CommandStart will no longer necessarily
run with the same Annex state as CommandPerform. While its docs already
said it should avoid modifying Annex state, I audited all the
CommandStart code as part of the conversion. (Note that CommandSeek
already sometimes runs with a different Annex state, and that has not been
a source of any problems, so I am not too worried that this change will
lead to breakage going forward.)
The only modification of Annex state I found was it calling
allowMessages in some Commands that default to noMessages. Dealt with
that by adding a startCustomOutput and a startingUsualMessages.
This lets a command start with noMessages and then select the output it
wants for each CommandStart.
One bit of breakage: onlyActionOn has been removed from commands that used it.
The plan is that, since a StartMessage contains an ActionItem,
when a Key can be extracted from that, the parallel job runner can
run onlyActionOn' automatically. Then commands won't need to worry about
this detail. Future work.
Otherwise, this was a fairly straightforward process of making each
CommandStart compile again. Hopefully other behavior changes were mostly
avoided.
In a few cases, a command had a CommandStart that called a CommandPerform
that then called showStart multiple times. I have collapsed those
down to a single start action. The main command to perhaps suffer from it
is Command.Direct, which used to show a start for each file, and no
longer does.
Another minor behavior change is that some commands used showStart
before, but had an associated file and a Key available, so were changed
to ShowStart with an ActionItemAssociatedFile. That will not change the
normal output or behavior, but --json output will now include the key.
This should not break it for anyone using a real json parser.
2019-06-06 19:42:30 +00:00
|
|
|
( next $ cleanupExport r db ek loc False
|
|
|
|
, do
|
|
|
|
liftIO $ modifyMVar_ cvar (pure . const (FileUploaded True))
|
|
|
|
performExport r db ek af (Git.LsTree.sha ti) loc allfilledvar
|
|
|
|
)
|
2017-08-31 17:29:54 +00:00
|
|
|
where
|
2019-12-09 17:49:05 +00:00
|
|
|
loc = mkExportLocation f
|
2017-09-20 16:56:17 +00:00
|
|
|
f = getTopFilePath (Git.LsTree.file ti)
|
2019-12-09 17:49:05 +00:00
|
|
|
af = AssociatedFile (Just f)
|
2021-03-12 18:09:19 +00:00
|
|
|
ai = ActionItemTreeFile f
|
2020-09-14 20:49:33 +00:00
|
|
|
si = SeekInput []
|
2021-11-29 18:02:38 +00:00
|
|
|
notrecordedpresent ek =
|
|
|
|
ifM (liftIO $ notElem loc <$> getExportedLocation db ek)
|
|
|
|
( return True
|
|
|
|
-- When content was lost from the remote and
|
|
|
|
-- a fsck noticed that, the export db will still
|
|
|
|
-- list it as present in the remote. So also check
|
|
|
|
-- location tracking.
|
|
|
|
-- However, git sha keys do not have their locations
|
|
|
|
-- tracked, and fsck doesn't check them, so not
|
|
|
|
-- for those.
|
|
|
|
, if isGitShaKey ek
|
|
|
|
then return False
|
|
|
|
else notElem (uuid r) <$> loggedLocations ek
|
|
|
|
)
|
2017-08-31 17:29:54 +00:00
|
|
|
|
2021-03-05 18:03:51 +00:00
|
|
|
performExport :: Remote -> ExportHandle -> Key -> AssociatedFile -> Sha -> ExportLocation -> MVar AllFilled -> CommandPerform
|
2019-03-01 20:08:18 +00:00
|
|
|
performExport r db ek af contentsha loc allfilledvar = do
|
2021-03-05 18:17:48 +00:00
|
|
|
sent <- tryNonAsync $ if not (isGitShaKey ek)
|
2024-08-04 16:18:17 +00:00
|
|
|
then tryrenameannexobject $ ifM (inAnnex ek)
|
2017-11-14 20:27:39 +00:00
|
|
|
( notifyTransfer Upload af $
|
2021-01-13 18:50:48 +00:00
|
|
|
-- alwaysUpload because the same key
|
|
|
|
-- could be used for more than one export
|
|
|
|
-- location, and concurrently uploading
|
|
|
|
-- of the content should still be allowed.
|
2021-03-05 18:03:51 +00:00
|
|
|
alwaysUpload (uuid r) ek af Nothing stdRetry $ \pm -> do
|
2017-11-14 20:27:39 +00:00
|
|
|
let rollback = void $
|
2019-01-30 18:55:28 +00:00
|
|
|
performUnexport r db [ek] loc
|
2024-07-01 14:42:27 +00:00
|
|
|
sendAnnex ek Nothing rollback $ \f _sz ->
|
2020-05-15 16:17:15 +00:00
|
|
|
Remote.action $
|
2021-03-05 18:03:51 +00:00
|
|
|
storer f ek loc pm
|
2017-09-01 17:02:07 +00:00
|
|
|
, do
|
|
|
|
showNote "not available"
|
|
|
|
return False
|
|
|
|
)
|
|
|
|
-- Sending a non-annexed file.
|
2021-03-05 18:17:48 +00:00
|
|
|
else withTmpFile "export" $ \tmp h -> do
|
|
|
|
b <- catObject contentsha
|
|
|
|
liftIO $ L.hPut h b
|
|
|
|
liftIO $ hClose h
|
|
|
|
Remote.action $
|
|
|
|
storer tmp ek loc nullMeterUpdate
|
2019-03-05 20:49:42 +00:00
|
|
|
let failedsend = liftIO $ modifyMVar_ allfilledvar (pure . const (AllFilled False))
|
|
|
|
case sent of
|
|
|
|
Right True -> next $ cleanupExport r db ek loc True
|
|
|
|
Right False -> do
|
|
|
|
failedsend
|
2019-03-01 20:08:18 +00:00
|
|
|
stop
|
2019-03-05 20:49:42 +00:00
|
|
|
Left err -> do
|
|
|
|
failedsend
|
|
|
|
throwM err
|
2024-08-04 16:18:17 +00:00
|
|
|
where
|
|
|
|
storer = storeExport (exportActions r)
|
|
|
|
|
|
|
|
tryrenameannexobject fallback
|
|
|
|
| annexObjects (Remote.config r) = do
|
|
|
|
case renameExport (exportActions r) of
|
|
|
|
Just renameaction -> do
|
|
|
|
locs <- loggedLocations ek
|
|
|
|
gc <- Annex.getGitConfig
|
|
|
|
let objloc = exportAnnexObjectLocation gc ek
|
|
|
|
if Remote.uuid r `elem` locs
|
|
|
|
then tryNonAsync (renameaction ek objloc loc) >>= \case
|
|
|
|
Right (Just ()) -> return True
|
|
|
|
Left _err -> fallback
|
|
|
|
Right Nothing -> fallback
|
|
|
|
else fallback
|
|
|
|
Nothing -> fallback
|
|
|
|
| otherwise = fallback
|
2017-08-31 17:29:54 +00:00
|
|
|
|
2021-03-05 18:03:51 +00:00
|
|
|
cleanupExport :: Remote -> ExportHandle -> Key -> ExportLocation -> Bool -> CommandCleanup
|
2018-11-14 15:47:40 +00:00
|
|
|
cleanupExport r db ek loc sent = do
|
2021-03-05 18:03:51 +00:00
|
|
|
liftIO $ addExportedLocation db ek loc
|
2021-03-05 18:17:48 +00:00
|
|
|
when (sent && not (isGitShaKey ek)) $
|
|
|
|
logChange ek (uuid r) InfoPresent
|
2017-08-31 17:29:54 +00:00
|
|
|
return True
|
2017-08-29 18:58:38 +00:00
|
|
|
|
2019-01-30 18:55:28 +00:00
|
|
|
startUnexport :: Remote -> ExportHandle -> TopFilePath -> [Git.Sha] -> CommandStart
|
|
|
|
startUnexport r db f shas = do
|
2020-01-07 15:35:17 +00:00
|
|
|
eks <- forM (filter (`notElem` nullShas) shas) exportKey
|
2017-09-06 19:33:40 +00:00
|
|
|
if null eks
|
|
|
|
then stop
|
2020-09-14 20:49:33 +00:00
|
|
|
else starting ("unexport " ++ name r) ai si $
|
make CommandStart return a StartMessage
The goal is to be able to run CommandStart in the main thread when -J is
used, rather than unncessarily passing it off to a worker thread, which
incurs overhead that is signficant when the CommandStart is going to
quickly decide to stop.
To do that, the message it displays needs to be displayed in the worker
thread, after the CommandStart has run.
Also, the change will mean that CommandStart will no longer necessarily
run with the same Annex state as CommandPerform. While its docs already
said it should avoid modifying Annex state, I audited all the
CommandStart code as part of the conversion. (Note that CommandSeek
already sometimes runs with a different Annex state, and that has not been
a source of any problems, so I am not too worried that this change will
lead to breakage going forward.)
The only modification of Annex state I found was it calling
allowMessages in some Commands that default to noMessages. Dealt with
that by adding a startCustomOutput and a startingUsualMessages.
This lets a command start with noMessages and then select the output it
wants for each CommandStart.
One bit of breakage: onlyActionOn has been removed from commands that used it.
The plan is that, since a StartMessage contains an ActionItem,
when a Key can be extracted from that, the parallel job runner can
run onlyActionOn' automatically. Then commands won't need to worry about
this detail. Future work.
Otherwise, this was a fairly straightforward process of making each
CommandStart compile again. Hopefully other behavior changes were mostly
avoided.
In a few cases, a command had a CommandStart that called a CommandPerform
that then called showStart multiple times. I have collapsed those
down to a single start action. The main command to perhaps suffer from it
is Command.Direct, which used to show a start for each file, and no
longer does.
Another minor behavior change is that some commands used showStart
before, but had an associated file and a Key available, so were changed
to ShowStart with an ActionItemAssociatedFile. That will not change the
normal output or behavior, but --json output will now include the key.
This should not break it for anyone using a real json parser.
2019-06-06 19:42:30 +00:00
|
|
|
performUnexport r db eks loc
|
2017-08-31 19:41:48 +00:00
|
|
|
where
|
2019-12-09 17:49:05 +00:00
|
|
|
loc = mkExportLocation f'
|
2017-09-06 19:33:40 +00:00
|
|
|
f' = getTopFilePath f
|
2021-03-12 18:09:19 +00:00
|
|
|
ai = ActionItemTreeFile f'
|
2020-09-14 20:49:33 +00:00
|
|
|
si = SeekInput []
|
2017-09-06 19:33:40 +00:00
|
|
|
|
2019-01-26 16:52:56 +00:00
|
|
|
-- Unlike a usual drop from a repository, this does not check that
|
|
|
|
-- numcopies is satisfied before removing the content. Typically an export
|
|
|
|
-- 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.
|
2021-03-05 18:03:51 +00:00
|
|
|
performUnexport :: Remote -> ExportHandle -> [Key] -> ExportLocation -> CommandPerform
|
2019-01-30 18:55:28 +00:00
|
|
|
performUnexport r db eks loc = do
|
2020-05-15 18:11:59 +00:00
|
|
|
ifM (allM rm eks)
|
2019-01-30 18:55:28 +00:00
|
|
|
( next $ cleanupUnexport r db eks loc
|
2017-09-06 19:33:40 +00:00
|
|
|
, stop
|
|
|
|
)
|
2020-05-15 18:11:59 +00:00
|
|
|
where
|
2021-03-05 18:03:51 +00:00
|
|
|
rm ek = Remote.action $ removeExport (exportActions r) ek loc
|
2017-08-29 18:58:38 +00:00
|
|
|
|
2021-03-05 18:03:51 +00:00
|
|
|
cleanupUnexport :: Remote -> ExportHandle -> [Key] -> ExportLocation -> CommandCleanup
|
2019-01-30 18:55:28 +00:00
|
|
|
cleanupUnexport r db eks loc = do
|
2017-09-04 18:33:09 +00:00
|
|
|
liftIO $ do
|
2017-09-06 19:33:40 +00:00
|
|
|
forM_ eks $ \ek ->
|
2021-03-05 18:03:51 +00:00
|
|
|
removeExportedLocation db ek loc
|
2017-09-04 18:33:09 +00:00
|
|
|
flushDbQueue db
|
2017-09-15 19:04:29 +00:00
|
|
|
|
2022-10-11 17:04:33 +00:00
|
|
|
-- A versionedExport remote supports removeExportLocation to remove
|
2020-12-28 18:37:15 +00:00
|
|
|
-- the file from the exported tree, but still retains the content
|
|
|
|
-- and allows retrieving it.
|
|
|
|
unless (versionedExport (exportActions r)) $ do
|
2018-08-30 15:18:20 +00:00
|
|
|
remaininglocs <- liftIO $
|
2021-03-05 18:03:51 +00:00
|
|
|
concat <$> forM eks (getExportedLocation db)
|
2018-08-30 15:18:20 +00:00
|
|
|
when (null remaininglocs) $
|
|
|
|
forM_ eks $ \ek ->
|
2024-08-02 22:43:10 +00:00
|
|
|
-- When annexobject=true, a key that
|
|
|
|
-- was unexported may still be present
|
|
|
|
-- on the remote.
|
|
|
|
if annexObjects (Remote.config r)
|
|
|
|
then tryNonAsync (checkPresent r ek) >>= \case
|
|
|
|
Right False ->
|
|
|
|
logChange ek (uuid r) InfoMissing
|
|
|
|
_ -> noop
|
|
|
|
else logChange ek (uuid r) InfoMissing
|
2017-09-15 19:04:29 +00:00
|
|
|
|
2021-03-05 18:03:51 +00:00
|
|
|
removeEmptyDirectories r db loc eks
|
2017-09-06 19:33:40 +00:00
|
|
|
|
2024-08-04 15:58:07 +00:00
|
|
|
-- Dispose of an old exported file by either unexporting it, or by moving
|
|
|
|
-- it to the annexobjects location.
|
|
|
|
startDispose :: Remote -> ExportHandle -> TopFilePath -> Key -> CommandStart
|
|
|
|
startDispose r db f ek =
|
|
|
|
starting ("unexport " ++ name r) ai si $
|
|
|
|
if annexObjects (Remote.config r) && not (isGitShaKey ek)
|
|
|
|
then do
|
|
|
|
gc <- Annex.getGitConfig
|
|
|
|
performRename r db ek loc
|
|
|
|
(exportAnnexObjectLocation gc ek)
|
|
|
|
else performUnexport r db [ek] loc
|
|
|
|
where
|
|
|
|
loc = mkExportLocation f'
|
|
|
|
f' = getTopFilePath f
|
|
|
|
ai = ActionItemTreeFile f'
|
|
|
|
si = SeekInput []
|
|
|
|
|
2019-01-30 18:55:28 +00:00
|
|
|
startRecoverIncomplete :: Remote -> ExportHandle -> Git.Sha -> TopFilePath -> CommandStart
|
|
|
|
startRecoverIncomplete r db sha oldf
|
2020-01-07 15:35:17 +00:00
|
|
|
| sha `elem` nullShas = stop
|
2017-09-06 19:33:40 +00:00
|
|
|
| otherwise = do
|
|
|
|
ek <- exportKey sha
|
2017-09-18 17:57:25 +00:00
|
|
|
let loc = exportTempName ek
|
2021-03-12 18:09:19 +00:00
|
|
|
let ai = ActionItemTreeFile (fromExportLocation loc)
|
2020-09-14 20:49:33 +00:00
|
|
|
let si = SeekInput []
|
|
|
|
starting ("unexport " ++ name r) ai si $ do
|
2021-03-05 18:03:51 +00:00
|
|
|
liftIO $ removeExportedLocation db ek oldloc
|
make CommandStart return a StartMessage
The goal is to be able to run CommandStart in the main thread when -J is
used, rather than unncessarily passing it off to a worker thread, which
incurs overhead that is signficant when the CommandStart is going to
quickly decide to stop.
To do that, the message it displays needs to be displayed in the worker
thread, after the CommandStart has run.
Also, the change will mean that CommandStart will no longer necessarily
run with the same Annex state as CommandPerform. While its docs already
said it should avoid modifying Annex state, I audited all the
CommandStart code as part of the conversion. (Note that CommandSeek
already sometimes runs with a different Annex state, and that has not been
a source of any problems, so I am not too worried that this change will
lead to breakage going forward.)
The only modification of Annex state I found was it calling
allowMessages in some Commands that default to noMessages. Dealt with
that by adding a startCustomOutput and a startingUsualMessages.
This lets a command start with noMessages and then select the output it
wants for each CommandStart.
One bit of breakage: onlyActionOn has been removed from commands that used it.
The plan is that, since a StartMessage contains an ActionItem,
when a Key can be extracted from that, the parallel job runner can
run onlyActionOn' automatically. Then commands won't need to worry about
this detail. Future work.
Otherwise, this was a fairly straightforward process of making each
CommandStart compile again. Hopefully other behavior changes were mostly
avoided.
In a few cases, a command had a CommandStart that called a CommandPerform
that then called showStart multiple times. I have collapsed those
down to a single start action. The main command to perhaps suffer from it
is Command.Direct, which used to show a start for each file, and no
longer does.
Another minor behavior change is that some commands used showStart
before, but had an associated file and a Key available, so were changed
to ShowStart with an ActionItemAssociatedFile. That will not change the
normal output or behavior, but --json output will now include the key.
This should not break it for anyone using a real json parser.
2019-06-06 19:42:30 +00:00
|
|
|
performUnexport r db [ek] loc
|
2017-09-07 19:37:49 +00:00
|
|
|
where
|
2019-12-09 17:49:05 +00:00
|
|
|
oldloc = mkExportLocation $ getTopFilePath oldf
|
2017-09-06 19:33:40 +00:00
|
|
|
|
2021-03-05 18:03:51 +00:00
|
|
|
startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> Key -> CommandStart
|
2024-03-09 17:37:51 +00:00
|
|
|
startMoveToTempName r db f ek = case renameExport (exportActions r) of
|
|
|
|
Just _ -> starting ("rename " ++ name r) ai si $
|
2020-09-14 20:49:33 +00:00
|
|
|
performRename r db ek loc tmploc
|
2024-03-15 20:14:44 +00:00
|
|
|
Nothing -> starting ("unexport " ++ name r) ai' si $
|
|
|
|
performUnexport r db [ek] loc
|
2017-09-06 19:33:40 +00:00
|
|
|
where
|
2019-12-09 17:49:05 +00:00
|
|
|
loc = mkExportLocation f'
|
2017-09-06 19:33:40 +00:00
|
|
|
f' = getTopFilePath f
|
2017-09-18 17:57:25 +00:00
|
|
|
tmploc = exportTempName ek
|
2023-04-08 19:48:32 +00:00
|
|
|
ai = ActionItemOther $ Just $
|
|
|
|
QuotedPath f' <> " -> " <> QuotedPath (fromExportLocation tmploc)
|
2024-03-15 20:14:44 +00:00
|
|
|
ai' = ActionItemTreeFile (fromExportLocation loc)
|
2020-09-14 20:49:33 +00:00
|
|
|
si = SeekInput []
|
2017-09-06 19:33:40 +00:00
|
|
|
|
2021-03-05 18:03:51 +00:00
|
|
|
startMoveFromTempName :: Remote -> ExportHandle -> Key -> TopFilePath -> CommandStart
|
2024-03-09 17:37:51 +00:00
|
|
|
startMoveFromTempName r db ek f = case renameExport (exportActions r) of
|
|
|
|
Just _ -> stopUnless (liftIO $ elem tmploc <$> getExportedLocation db ek) $
|
2020-09-14 20:49:33 +00:00
|
|
|
starting ("rename " ++ name r) ai si $
|
make CommandStart return a StartMessage
The goal is to be able to run CommandStart in the main thread when -J is
used, rather than unncessarily passing it off to a worker thread, which
incurs overhead that is signficant when the CommandStart is going to
quickly decide to stop.
To do that, the message it displays needs to be displayed in the worker
thread, after the CommandStart has run.
Also, the change will mean that CommandStart will no longer necessarily
run with the same Annex state as CommandPerform. While its docs already
said it should avoid modifying Annex state, I audited all the
CommandStart code as part of the conversion. (Note that CommandSeek
already sometimes runs with a different Annex state, and that has not been
a source of any problems, so I am not too worried that this change will
lead to breakage going forward.)
The only modification of Annex state I found was it calling
allowMessages in some Commands that default to noMessages. Dealt with
that by adding a startCustomOutput and a startingUsualMessages.
This lets a command start with noMessages and then select the output it
wants for each CommandStart.
One bit of breakage: onlyActionOn has been removed from commands that used it.
The plan is that, since a StartMessage contains an ActionItem,
when a Key can be extracted from that, the parallel job runner can
run onlyActionOn' automatically. Then commands won't need to worry about
this detail. Future work.
Otherwise, this was a fairly straightforward process of making each
CommandStart compile again. Hopefully other behavior changes were mostly
avoided.
In a few cases, a command had a CommandStart that called a CommandPerform
that then called showStart multiple times. I have collapsed those
down to a single start action. The main command to perhaps suffer from it
is Command.Direct, which used to show a start for each file, and no
longer does.
Another minor behavior change is that some commands used showStart
before, but had an associated file and a Key available, so were changed
to ShowStart with an ActionItemAssociatedFile. That will not change the
normal output or behavior, but --json output will now include the key.
This should not break it for anyone using a real json parser.
2019-06-06 19:42:30 +00:00
|
|
|
performRename r db ek tmploc loc
|
2024-03-15 20:14:44 +00:00
|
|
|
Nothing -> starting ("unexport " ++ name r) ai' si $
|
|
|
|
performUnexport r db [ek] tmploc
|
2017-09-06 19:33:40 +00:00
|
|
|
where
|
2019-12-09 17:49:05 +00:00
|
|
|
loc = mkExportLocation f'
|
2017-09-06 19:33:40 +00:00
|
|
|
f' = getTopFilePath f
|
2024-03-09 17:37:51 +00:00
|
|
|
tmploc = exportTempName ek
|
|
|
|
ai = ActionItemOther $ Just $
|
|
|
|
QuotedPath (fromExportLocation tmploc) <> " -> " <> QuotedPath f'
|
2024-03-15 20:14:44 +00:00
|
|
|
ai' = ActionItemTreeFile (fromExportLocation tmploc)
|
2020-09-14 20:49:33 +00:00
|
|
|
si = SeekInput []
|
2017-09-06 19:33:40 +00:00
|
|
|
|
2021-03-05 18:03:51 +00:00
|
|
|
performRename :: Remote -> ExportHandle -> Key -> ExportLocation -> ExportLocation -> CommandPerform
|
2024-03-09 17:37:51 +00:00
|
|
|
performRename r db ek src dest = case renameExport (exportActions r) of
|
|
|
|
Just renameaction -> tryNonAsync (renameaction ek src dest) >>= \case
|
2020-05-15 19:05:52 +00:00
|
|
|
Right (Just ()) -> next $ cleanupRename r db ek src dest
|
|
|
|
Left err -> do
|
filter out control characters in warning messages
Converted warning and similar to use StringContainingQuotedPath. Most
warnings are static strings, some do refer to filepaths that need to be
quoted, and others don't need quoting.
Note that, since quote filters out control characters of even
UnquotedString, this makes all warnings safe, even when an attacker
sneaks in a control character in some other way.
When json is being output, no quoting is done, since json gets its own
quoting.
This does, as a side effect, make warning messages in json output not
be indented. The indentation is only needed to offset warning messages
underneath the display of the file they apply to, so that's ok.
Sponsored-by: Brett Eisenberg on Patreon
2023-04-10 18:47:32 +00:00
|
|
|
warning $ UnquotedString $ "rename failed (" ++ show err ++ "); deleting instead"
|
2019-03-11 16:44:12 +00:00
|
|
|
fallbackdelete
|
2020-05-15 19:05:52 +00:00
|
|
|
Right Nothing -> fallbackdelete
|
2024-03-09 17:37:51 +00:00
|
|
|
-- remote does not support renaming
|
|
|
|
Nothing -> fallbackdelete
|
2019-03-11 16:44:12 +00:00
|
|
|
where
|
|
|
|
fallbackdelete = performUnexport r db [ek] src
|
2017-09-06 19:33:40 +00:00
|
|
|
|
2021-03-05 18:03:51 +00:00
|
|
|
cleanupRename :: Remote -> ExportHandle -> Key -> ExportLocation -> ExportLocation -> CommandCleanup
|
2019-01-30 18:55:28 +00:00
|
|
|
cleanupRename r db ek src dest = do
|
2017-09-06 19:33:40 +00:00
|
|
|
liftIO $ do
|
2021-03-05 18:03:51 +00:00
|
|
|
removeExportedLocation db ek src
|
|
|
|
addExportedLocation db ek dest
|
2017-09-06 19:33:40 +00:00
|
|
|
flushDbQueue db
|
2017-09-15 20:34:45 +00:00
|
|
|
if exportDirectories src /= exportDirectories dest
|
2021-03-05 18:03:51 +00:00
|
|
|
then removeEmptyDirectories r db src [ek]
|
2017-09-15 20:30:49 +00:00
|
|
|
else return True
|
2017-09-18 22:40:16 +00:00
|
|
|
|
|
|
|
-- | Remove empty directories from the export. Call after removing an
|
|
|
|
-- exported file, and after calling removeExportLocation and flushing the
|
|
|
|
-- database.
|
2019-01-30 18:55:28 +00:00
|
|
|
removeEmptyDirectories :: Remote -> ExportHandle -> ExportLocation -> [Key] -> Annex Bool
|
|
|
|
removeEmptyDirectories r db loc ks
|
2017-09-18 22:40:16 +00:00
|
|
|
| null (exportDirectories loc) = return True
|
2019-01-30 18:55:28 +00:00
|
|
|
| otherwise = case removeExportDirectory (exportActions r) of
|
2017-09-18 22:40:16 +00:00
|
|
|
Nothing -> return True
|
|
|
|
Just removeexportdirectory -> do
|
|
|
|
ok <- allM (go removeexportdirectory)
|
|
|
|
(reverse (exportDirectories loc))
|
|
|
|
unless ok $ liftIO $ do
|
|
|
|
-- Add location back to export database,
|
|
|
|
-- so this is tried again next time.
|
|
|
|
forM_ ks $ \k ->
|
|
|
|
addExportedLocation db k loc
|
|
|
|
flushDbQueue db
|
|
|
|
return ok
|
|
|
|
where
|
|
|
|
go removeexportdirectory d =
|
|
|
|
ifM (liftIO $ isExportDirectoryEmpty db d)
|
2020-05-15 18:32:45 +00:00
|
|
|
( Remote.action $ removeexportdirectory d
|
2017-09-18 22:40:16 +00:00
|
|
|
, return True
|
|
|
|
)
|
2019-05-20 15:54:55 +00:00
|
|
|
|
|
|
|
-- | A value that has been filtered through the remote's preferred content
|
|
|
|
-- expression.
|
2021-03-12 17:28:43 +00:00
|
|
|
newtype ExportFiltered t = ExportFiltered t
|
2019-05-20 15:54:55 +00:00
|
|
|
|
2021-03-12 17:28:43 +00:00
|
|
|
-- | Filters the tree to annexed files that are preferred content of the
|
2022-01-03 18:21:50 +00:00
|
|
|
-- remote, and also including non-annexed files, but not submodules or
|
|
|
|
-- non-annexed symlinks.
|
2019-05-20 20:37:04 +00:00
|
|
|
--
|
2021-03-12 17:28:43 +00:00
|
|
|
-- A log is written with tree items that were filtered out, so they can
|
|
|
|
-- be added back in when importing from the remote.
|
|
|
|
filterExport :: Remote -> Git.Ref -> Annex (ExportFiltered Git.Ref)
|
|
|
|
filterExport r tree = logExportExcluded (uuid r) $ \logwriter -> do
|
2019-05-20 15:54:55 +00:00
|
|
|
m <- preferredContentMap
|
|
|
|
case M.lookup (uuid r) m of
|
2023-07-26 18:34:21 +00:00
|
|
|
Just (matcher, matcherdesc) | not (isEmpty matcher) ->
|
|
|
|
ExportFiltered <$> go (Just (matcher, matcherdesc)) logwriter
|
2021-03-12 17:28:43 +00:00
|
|
|
_ -> ExportFiltered <$> go Nothing logwriter
|
2019-05-20 15:54:55 +00:00
|
|
|
where
|
2021-03-12 17:28:43 +00:00
|
|
|
go mmatcher logwriter = do
|
2019-05-20 15:54:55 +00:00
|
|
|
g <- Annex.gitRepo
|
2019-05-20 20:37:04 +00:00
|
|
|
Git.Tree.adjustTree
|
2021-03-12 17:28:43 +00:00
|
|
|
(check mmatcher logwriter)
|
2019-05-20 20:37:04 +00:00
|
|
|
[]
|
|
|
|
(\_old new -> new)
|
|
|
|
[]
|
|
|
|
tree
|
|
|
|
g
|
2020-05-26 17:44:43 +00:00
|
|
|
|
2021-03-12 17:28:43 +00:00
|
|
|
check mmatcher logwriter ti@(Git.Tree.TreeItem topf mode sha) =
|
|
|
|
case toTreeItemType mode of
|
|
|
|
-- Don't export submodule entries.
|
|
|
|
Just TreeSubmodule -> excluded
|
2022-01-03 18:21:50 +00:00
|
|
|
Just TreeSymlink -> checkkey True
|
|
|
|
_ -> checkkey False
|
2021-03-12 17:28:43 +00:00
|
|
|
where
|
|
|
|
excluded = do
|
|
|
|
() <- liftIO $ logwriter ti
|
|
|
|
return Nothing
|
|
|
|
|
2022-01-03 18:21:50 +00:00
|
|
|
checkkey issymlink =
|
|
|
|
case mmatcher of
|
|
|
|
Nothing
|
|
|
|
| issymlink -> catKey sha >>= \case
|
|
|
|
Just _ -> return (Just ti)
|
2022-06-28 19:40:27 +00:00
|
|
|
Nothing -> excluded
|
2022-01-03 18:21:50 +00:00
|
|
|
| otherwise -> return (Just ti)
|
|
|
|
Just matcher -> catKey sha >>= \case
|
|
|
|
Just k -> checkmatcher matcher k
|
|
|
|
Nothing
|
|
|
|
| issymlink -> excluded
|
|
|
|
| otherwise -> return (Just ti)
|
|
|
|
|
2021-03-12 17:28:43 +00:00
|
|
|
checkmatcher matcher k = do
|
|
|
|
let mi = MatchingInfo $ ProvidedInfo
|
|
|
|
{ providedFilePath = Just $
|
|
|
|
-- Match filename relative
|
|
|
|
-- to the top of the tree.
|
|
|
|
getTopFilePath topf
|
|
|
|
, providedKey = Just k
|
|
|
|
, providedFileSize = Nothing
|
|
|
|
, providedMimeType = Nothing
|
|
|
|
, providedMimeEncoding = Nothing
|
|
|
|
, providedLinkType = Nothing
|
|
|
|
}
|
|
|
|
ifM (checkMatcher' matcher mi mempty)
|
|
|
|
( return (Just ti)
|
|
|
|
, excluded
|
|
|
|
)
|