git-annex/Command/Add.hs

{- git-annex command
 -
 - Copyright 2010-2017 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL 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 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
			| updateOnly o ->
				giveup "--update --batch is not supported"
			| otherwise -> batchFilesMatching gofile
		NoBatch -> do
			l <- workTreeItems (addThese o)
			let go a = a gofile l
			unless (updateOnly o) $
				go (withFilesNotInGit (not $ includeDotFiles o))
			go withFilesMaybeModified
			unlessM (versionSupportsUnlockedPointers <||> 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
			_ -> ifM (sameInodeCache file =<< Database.Keys.getInodeCaches key)
				( stop, 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 = do
	lockingfile <- not <$> addUnlocked
	let cfg = LockDownConfig
		{ lockingFile = lockingfile
		, hardlinkFileTmp = True
		}
	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", key2file key)]
	when hascontent $
		logStatus key InfoPresent
	return True