2d33122215
Fixes bug that caused git-annex to fail to add a file when another git-annex process cleaned up the temp directory it was using. Solution is just to push withOtherTmp out to a higher level, so that the whole ingest process can be completed inside it. But in the assistant, that was not practical to do, since withOtherTmp runs in the Annex monad and the assistant does not. Worked around by introducing a separate temp directory that only the assistant uses for lockdown. Since only one assistant can run at a time, it's easy to clean up that directory of old cruft at startup.
157 lines
4 KiB
Haskell
157 lines
4 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2010-2017 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Command.Add where
|
|
|
|
import Command
|
|
import Annex.Ingest
|
|
import Logs.Location
|
|
import Annex.Content
|
|
import Annex.Content.Direct
|
|
import qualified Annex
|
|
import qualified Annex.Queue
|
|
import qualified Database.Keys
|
|
import Config
|
|
import Annex.FileMatcher
|
|
import Annex.Link
|
|
import Annex.Version
|
|
import Annex.Tmp
|
|
import Git.FilePath
|
|
|
|
cmd :: Command
|
|
cmd = notBareRepo $
|
|
withGlobalOptions [jobsOption, jsonOptions, fileMatchingOptions] $
|
|
command "add" SectionCommon "add files to annex"
|
|
paramPaths (seek <$$> optParser)
|
|
|
|
data AddOptions = AddOptions
|
|
{ addThese :: CmdParams
|
|
, includeDotFiles :: Bool
|
|
, batchOption :: BatchMode
|
|
, updateOnly :: Bool
|
|
}
|
|
|
|
optParser :: CmdParamsDesc -> Parser AddOptions
|
|
optParser desc = AddOptions
|
|
<$> cmdParams desc
|
|
<*> switch
|
|
( long "include-dotfiles"
|
|
<> help "don't skip dotfiles"
|
|
)
|
|
<*> parseBatchOption
|
|
<*> switch
|
|
( long "update"
|
|
<> short 'u'
|
|
<> help "only update tracked files"
|
|
)
|
|
|
|
seek :: AddOptions -> CommandSeek
|
|
seek o = allowConcurrentOutput $ do
|
|
matcher <- largeFilesMatcher
|
|
let gofile file = ifM (checkFileMatcher matcher file <||> Annex.getState Annex.force)
|
|
( start file
|
|
, ifM (annexAddSmallFiles <$> Annex.getGitConfig)
|
|
( startSmall file
|
|
, stop
|
|
)
|
|
)
|
|
case batchOption o of
|
|
Batch fmt
|
|
| updateOnly o ->
|
|
giveup "--update --batch is not supported"
|
|
| otherwise -> batchFilesMatching fmt gofile
|
|
NoBatch -> do
|
|
l <- workTreeItems (addThese o)
|
|
let go a = a (commandAction . gofile) l
|
|
unless (updateOnly o) $
|
|
go (withFilesNotInGit (not $ includeDotFiles o))
|
|
go withFilesMaybeModified
|
|
ifM versionSupportsUnlockedPointers
|
|
( go withUnmodifiedUnlockedPointers
|
|
, unlessM isDirect $
|
|
go withFilesOldUnlocked
|
|
)
|
|
|
|
{- Pass file off to git-add. -}
|
|
startSmall :: FilePath -> CommandStart
|
|
startSmall file = do
|
|
showStart "add" file
|
|
next $ next $ addSmall file
|
|
|
|
addSmall :: FilePath -> Annex Bool
|
|
addSmall file = do
|
|
showNote "non-large file; adding content to git repository"
|
|
addFile file
|
|
|
|
addFile :: FilePath -> Annex Bool
|
|
addFile file = do
|
|
ps <- forceParams
|
|
Annex.Queue.addCommand "add" (ps++[Param "--"]) [file]
|
|
return True
|
|
|
|
start :: FilePath -> CommandStart
|
|
start file = do
|
|
ifM versionSupportsUnlockedPointers
|
|
( do
|
|
mk <- liftIO $ isPointerFile file
|
|
maybe go fixuppointer mk
|
|
, go
|
|
)
|
|
where
|
|
go = ifAnnexed file addpresent add
|
|
add = liftIO (catchMaybeIO $ getSymbolicLinkStatus file) >>= \case
|
|
Nothing -> stop
|
|
Just s
|
|
| not (isRegularFile s) && not (isSymbolicLink s) -> stop
|
|
| otherwise -> do
|
|
showStart "add" file
|
|
next $ if isSymbolicLink s
|
|
then next $ addFile file
|
|
else perform file
|
|
addpresent key = ifM versionSupportsUnlockedPointers
|
|
( liftIO (catchMaybeIO $ getSymbolicLinkStatus file) >>= \case
|
|
Just s | isSymbolicLink s -> fixuplink key
|
|
_ -> add
|
|
, ifM isDirect
|
|
( liftIO (catchMaybeIO $ getSymbolicLinkStatus file) >>= \case
|
|
Just s | isSymbolicLink s -> fixuplink key
|
|
_ -> ifM (goodContent key file)
|
|
( stop , add )
|
|
, fixuplink key
|
|
)
|
|
)
|
|
fixuplink key = do
|
|
-- the annexed symlink is present but not yet added to git
|
|
showStart "add" file
|
|
liftIO $ removeFile file
|
|
addLink file key Nothing
|
|
next $ next $
|
|
cleanup key =<< inAnnex key
|
|
fixuppointer key = do
|
|
-- the pointer file is present, but not yet added to git
|
|
showStart "add" file
|
|
Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)
|
|
next $ next $ addFile file
|
|
|
|
perform :: FilePath -> CommandPerform
|
|
perform file = withOtherTmp $ \tmpdir -> do
|
|
lockingfile <- not <$> addUnlocked
|
|
let cfg = LockDownConfig
|
|
{ lockingFile = lockingfile
|
|
, hardlinkFileTmpDir = Just tmpdir
|
|
}
|
|
lockDown cfg file >>= ingestAdd >>= finish
|
|
where
|
|
finish (Just key) = next $ cleanup key True
|
|
finish Nothing = stop
|
|
|
|
cleanup :: Key -> Bool -> CommandCleanup
|
|
cleanup key hascontent = do
|
|
maybeShowJSON $ JSONChunk [("key", serializeKey key)]
|
|
when hascontent $
|
|
logStatus key InfoPresent
|
|
return True
|