code:
{- git-annex usage messages
 -
 - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module CmdLine.Usage where

import Common.Annex

import Types.Command

import System.Console.GetOpt

usageMessage :: String -> String
usageMessage s = "Usage: " ++ s

{- Usage message with lists of commands by section. -}
usage :: String -> [Command] -> String
usage header cmds = unlines $ usageMessage header : concatMap go [minBound..]
  where
	go section
		| null cs = []
		| otherwise =
			[ ""
			, descSection section ++ ":"
			, ""
			] ++ map cmdline cs
	  where
		cs = filter (\c -> cmdsection c == section) scmds
	cmdline c = concat
		[ cmdname c
		, namepad (cmdname c)
		, cmdparamdesc c
		, descpad (cmdparamdesc c)
		, cmddesc c
		]
	pad n s = replicate (n - length s) ' '
	namepad = pad $ longest cmdname + 1
	descpad = pad $ longest cmdparamdesc + 2
	longest f = foldl max 0 $ map (length . f) cmds
	scmds = sort cmds

{- Usage message for a single command. -}
commandUsage :: Command -> String
commandUsage cmd = unlines
	[ usageInfo header (cmdoptions cmd)
	, "To see additional options common to all commands, run: git annex help options"
	]
  where
	header = usageMessage $ unwords
		[ "git-annex"
		, cmdname cmd
		, cmdparamdesc cmd
		, "[option ...]"
		]

{- Descriptions of params used in usage messages. -}
paramPaths :: String
paramPaths = paramOptional $ paramRepeating paramPath -- most often used
paramPath :: String
paramPath = "PATH"
paramKey :: String
paramKey = "KEY"
paramDesc :: String
paramDesc = "DESC"
paramUrl :: String
paramUrl = "URL"
paramNumber :: String
paramNumber = "NUMBER"
paramNumRange :: String
paramNumRange = "NUM|RANGE"
paramRemote :: String
paramRemote = "REMOTE"
paramField :: String
paramField = "FIELD"
paramGlob :: String
paramGlob = "GLOB"
paramName :: String
paramName = "NAME"
paramValue :: String
paramValue = "VALUE"
paramUUID :: String
paramUUID = "UUID"
paramType :: String
paramType = "TYPE"
paramDate :: String
paramDate = "DATE"
paramTime :: String
paramTime = "TIME"
paramFormat :: String
paramFormat = "FORMAT"
paramFile :: String
paramFile = "FILE"
paramRef :: String
paramRef = "REF"
paramGroup :: String
paramGroup = "GROUP"
paramExpression :: String
paramExpression = "EXPR"
paramSize :: String
paramSize = "SIZE"
paramAddress :: String
paramAddress = "ADDRESS"
paramKeyValue :: String
paramKeyValue = "K=V"
paramNothing :: String
paramNothing = ""
paramRepeating :: String -> String
paramRepeating s = s ++ " ..."
paramOptional :: String -> String
paramOptional s = "[" ++ s ++ "]"
paramPair :: String -> String -> String
paramPair a b = a ++ " " ++ b


code:
{- git-annex command infrastructure
 -
 - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command (
	command,
	noRepo,
	noCommit,
	noMessages,
	withOptions,
	next,
	stop,
	stopUnless,
	whenAnnexed,
	ifAnnexed,
	isBareRepo,
	checkAuto,
	module ReExported
) where

import Common.Annex
import qualified Backend
import qualified Annex
import qualified Git
import Types.Command as ReExported
import Types.Option as ReExported
import CmdLine.Seek as ReExported
import Checks as ReExported
import CmdLine.Usage as ReExported
import CmdLine.Action as ReExported
import CmdLine.Option as ReExported
import CmdLine.GitAnnex.Options as ReExported

{- Generates a normal command -}
command :: String -> String -> CommandSeek -> CommandSection -> String -> Command
command = Command [] Nothing commonChecks False False

{- Indicates that a command doesn't need to commit any changes to
 - the git-annex branch. -}
noCommit :: Command -> Command
noCommit c = c { cmdnocommit = True }

{- Indicates that a command should not output anything other than what
 - it directly sends to stdout. (--json can override this). -}
noMessages :: Command -> Command
noMessages c = c { cmdnomessages = True }

{- Adds a fallback action to a command, that will be run if it's used
 - outside a git repository. -}
noRepo :: (CmdParams -> IO ()) -> Command -> Command
noRepo a c = c { cmdnorepo = Just a }

{- Adds options to a command. -}
withOptions :: [Option] -> Command -> Command
withOptions o c = c { cmdoptions = o }

{- For start and perform stages to indicate what step to run next. -}
next :: a -> Annex (Maybe a)
next a = return $ Just a

{- Or to indicate nothing needs to be done. -}
stop :: Annex (Maybe a)
stop = return Nothing

{- Stops unless a condition is met. -}
stopUnless :: Annex Bool -> Annex (Maybe a) -> Annex (Maybe a)
stopUnless c a = ifM c ( a , stop )

{- Modifies an action to only act on files that are already annexed,
 - and passes the key on to it. -}
whenAnnexed :: (FilePath -> Key -> Annex (Maybe a)) -> FilePath -> Annex (Maybe a)
whenAnnexed a file = ifAnnexed file (a file) (return Nothing)

ifAnnexed :: FilePath -> (Key -> Annex a) -> Annex a -> Annex a
ifAnnexed file yes no = maybe no yes =<< Backend.lookupFile file

isBareRepo :: Annex Bool
isBareRepo = fromRepo Git.repoIsLocalBare

checkAuto :: Annex Bool -> Annex Bool
checkAuto checker = ifM (Annex.getState Annex.auto)
	( checker , return True )

repo_name: kakafarm/git

license: unknown


code:
{- git-annex command
 -
 - Copyright 2010, 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Command.Add where

import Common.Annex
import Annex.Exception
import Command
import Types.KeySource
import Backend
import Logs.Location
import Annex.Content
import Annex.Content.Direct
import Annex.Perms
import Annex.Link
import Annex.MetaData
import qualified Annex
import qualified Annex.Queue
#ifdef WITH_CLIBS
#ifndef __ANDROID__
import Utility.Touch
#endif
#endif
import Config
import Utility.InodeCache
import Annex.FileMatcher
import Annex.ReplaceFile
import Utility.Tmp

def :: [Command]
def = [notBareRepo $ withOptions [includeDotFilesOption] $
	command "add" paramPaths seek SectionCommon
		"add files to annex"]

includeDotFilesOption :: Option
includeDotFilesOption = flagOption [] "include-dotfiles" "don't skip dotfiles"

{- Add acts on both files not checked into git yet, and unlocked files.
 -
 - In direct mode, it acts on any files that have changed. -}
seek :: CommandSeek
seek ps = do
	matcher <- largeFilesMatcher
	let go a = flip a ps $ \file -> ifM (checkFileMatcher matcher file <||> Annex.getState Annex.force)
		( start file
		, stop
		)
	skipdotfiles <- not <$> Annex.getFlag (optionName includeDotFilesOption)
	go $ withFilesNotInGit skipdotfiles
	ifM isDirect
		( go withFilesMaybeModified
		, go withFilesUnlocked
		)

{- The add subcommand annexes a file, generating a key for it using a
 - backend, and then moving it into the annex directory and setting up
 - the symlink pointing to its content. -}
start :: FilePath -> CommandStart
start file = ifAnnexed file addpresent add
  where
	add = do
		ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file
		case ms of
			Nothing -> stop
			Just s
				| isSymbolicLink s || not (isRegularFile s) -> stop
				| otherwise -> do
					showStart "add" file
					next $ perform file
	addpresent key = ifM isDirect
		( ifM (goodContent key file) ( stop , add )
		, fixup key
		)
	fixup key = do
		-- fixup from an interrupted add; the symlink
		-- is present but not yet added to git
		showStart "add" file
		liftIO $ removeFile file
		next $ next $ cleanup file key Nothing =<< inAnnex key

{- The file that's being added is locked down before a key is generated,
 - to prevent it from being modified in between. This lock down is not
 - perfect at best (and pretty weak at worst). For example, it does not
 - guard against files that are already opened for write by another process.
 - So a KeySource is returned. Its inodeCache can be used to detect any
 - changes that might be made to the file after it was locked down.
 -
 - When possible, the file is hard linked to a temp directory. This guards
 - against some changes, like deletion or overwrite of the file, and
 - allows lsof checks to be done more efficiently when adding a lot of files.
 -
 - Lockdown can fail if a file gets deleted, and Nothing will be returned.
 -}
lockDown :: FilePath -> Annex (Maybe KeySource)
lockDown = either (\e -> showErr e >> return Nothing) (return . Just) <=< lockDown'

lockDown' :: FilePath -> Annex (Either IOException KeySource)
lockDown' file = ifM crippledFileSystem
	( withTSDelta $ liftIO . tryIO . nohardlink
	, tryAnnexIO $ do
		tmp <- fromRepo gitAnnexTmpMiscDir
		createAnnexDirectory tmp
		go tmp
	)
  where
	{- In indirect mode, the write bit is removed from the file as part
	 - of lock down to guard against further writes, and because objects
	 - in the annex have their write bit disabled anyway.
	 -
	 - Freezing the content early also lets us fail early when
	 - someone else owns the file.
	 -
	 - This is not done in direct mode, because files there need to
	 - remain writable at all times.
	-}
  	go tmp = do
		unlessM isDirect $
			freezeContent file
		withTSDelta $ \delta -> liftIO $ do
			(tmpfile, h) <- openTempFile tmp $
				relatedTemplate $ takeFileName file
			hClose h
			nukeFile tmpfile
			withhardlink delta tmpfile `catchIO` const (nohardlink delta)
  	nohardlink delta = do
		cache <- genInodeCache file delta
		return KeySource
			{ keyFilename = file
			, contentLocation = file
			, inodeCache = cache
			}
	withhardlink delta tmpfile = do
		createLink file tmpfile
		cache <- genInodeCache tmpfile delta
		return KeySource
			{ keyFilename = file
			, contentLocation = tmpfile
			, inodeCache = cache
			}

{- Ingests a locked down file into the annex.
 -
 - In direct mode, leaves the file alone, and just updates bookkeeping
 - information.
 -}
ingest :: Maybe KeySource -> Annex (Maybe Key, Maybe InodeCache)
ingest Nothing = return (Nothing, Nothing)
ingest (Just source) = withTSDelta $ \delta -> do
	backend <- chooseBackend $ keyFilename source
	k <- genKey source backend
	ms <- liftIO $ catchMaybeIO $ getFileStatus $ contentLocation source
	mcache <- maybe (pure Nothing) (liftIO . toInodeCache delta) ms
	case (mcache, inodeCache source) of
		(_, Nothing) -> go k mcache ms
		(Just newc, Just c) | compareStrong c newc -> go k mcache ms
		_ -> failure "changed while it was being added"
  where
	go k mcache ms = ifM isDirect
		( godirect k mcache ms
		, goindirect k mcache ms
		)

	goindirect (Just (key, _)) mcache ms = do
		catchAnnex (moveAnnex key $ contentLocation source)
			(undo (keyFilename source) key)
		maybe noop (genMetaData key (keyFilename source)) ms
		liftIO $ nukeFile $ keyFilename source
		return $ (Just key, mcache)
	goindirect _ _ _ = failure "failed to generate a key"

	godirect (Just (key, _)) (Just cache) ms = do
		addInodeCache key cache
		maybe noop (genMetaData key (keyFilename source)) ms
		finishIngestDirect key source
		return $ (Just key, Just cache)
	godirect _ _ _ = failure "failed to generate a key"

	failure msg = do
		warning $ keyFilename source ++ " " ++ msg
		when (contentLocation source /= keyFilename source) $
			liftIO $ nukeFile $ contentLocation source
		return (Nothing, Nothing)

finishIngestDirect :: Key -> KeySource -> Annex ()
finishIngestDirect key source = do
	void $ addAssociatedFile key $ keyFilename source
	when (contentLocation source /= keyFilename source) $
		liftIO $ nukeFile $ contentLocation source

	{- Copy to any other locations using the same key. -}
	otherfs <- filter (/= keyFilename source) <$> associatedFiles key
	forM_ otherfs $
		addContentWhenNotPresent key (keyFilename source)

perform :: FilePath -> CommandPerform
perform file = lockDown file >>= ingest >>= go
  where
  	go (Just key, cache) = next $ cleanup file key cache True
	go (Nothing, _) = stop

{- On error, put the file back so it doesn't seem to have vanished.
 - This can be called before or after the symlink is in place. -}
undo :: FilePath -> Key -> IOException -> Annex a
undo file key e = do
	whenM (inAnnex key) $ do
		liftIO $ nukeFile file
		catchAnnex (fromAnnex key file) tryharder
		logStatus key InfoMissing
	throwAnnex e
  where
	-- fromAnnex could fail if the file ownership is weird
	tryharder :: IOException -> Annex ()
	tryharder _ = do
		src <- calcRepo $ gitAnnexLocation key
		liftIO $ moveFile src file

{- Creates the symlink to the annexed content, returns the link target. -}
link :: FilePath -> Key -> Maybe InodeCache -> Annex String
link file key mcache = flip catchAnnex (undo file key) $ do
	l <- inRepo $ gitAnnexLink file key
	replaceFile file $ makeAnnexLink l

	-- touch symlink to have same time as the original file,
	-- as provided in the InodeCache
	case mcache of
#if defined(WITH_CLIBS) && ! defined(__ANDROID__)
		Just c -> liftIO $ touch file (TimeSpec $ inodeCacheToMtime c) False
#else
		Just _ -> noop
#endif
		Nothing -> noop

	return l

{- Creates the symlink to the annexed content, and stages it in git.
 -
 - As long as the filesystem supports symlinks, we use
 - git add, rather than directly staging the symlink to git.
 - Using git add is best because it allows the queuing to work
 - and is faster (staging the symlink runs hash-object commands each time).
 - Also, using git add allows it to skip gitignored files, unless forced
 - to include them.
 -}
addLink :: FilePath -> Key -> Maybe InodeCache -> Annex ()
addLink file key mcache = ifM (coreSymlinks <$> Annex.getGitConfig)
	( do
		_ <- link file key mcache
		params <- ifM (Annex.getState Annex.force)
			( return [Param "-f"]
			, return []
			)
		Annex.Queue.addCommand "add" (params++[Param "--"]) [file]
	, do
		l <- link file key mcache
		addAnnexLink l file
	)

cleanup :: FilePath -> Key -> Maybe InodeCache -> Bool -> CommandCleanup
cleanup file key mcache hascontent = do
	ifM (isDirect <&&> pure hascontent)
		( do
			l <- inRepo $ gitAnnexLink file key
			stageSymlink file =<< hashSymlink l
		, addLink file key mcache
		)
	when hascontent $
		logStatus key InfoPresent
	return True


code:
{- git-annex command
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.AddUnused where

import Common.Annex
import Logs.Location
import Command
import qualified Command.Add
import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused)
import Types.Key

def :: [Command]
def = [notDirect $ command "addunused" (paramRepeating paramNumRange)
	seek SectionMaintenance "add back unused files"]

seek :: CommandSeek
seek = withUnusedMaps start

start :: UnusedMaps -> Int -> CommandStart
start = startUnused "addunused" perform
	(performOther "bad")
	(performOther "tmp")

perform :: Key -> CommandPerform
perform key = next $ do
	logStatus key InfoPresent
	Command.Add.addLink file key Nothing
	return True
  where
	file = "unused." ++ key2file key

{- The content is not in the annex, but in another directory, and
 - it seems better to error out, rather than moving bad/tmp content into
 - the annex. -}
performOther :: String -> Key -> CommandPerform
performOther other _ = error $ "cannot addunused " ++ other ++ "content"


code:
{- git-annex command
 -
 - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Command.AddUrl where

import Network.URI

import Common.Annex
import Command
import Backend
import qualified Command.Add
import qualified Annex
import qualified Annex.Queue
import qualified Annex.Url as Url
import qualified Backend.URL
import Annex.Content
import Logs.Web
import Types.Key
import Types.KeySource
import Config
import Annex.Content.Direct
import Logs.Location
import qualified Annex.Transfer as Transfer
#ifdef WITH_QUVI
import Annex.Quvi
import qualified Utility.Quvi as Quvi
#endif

def :: [Command]
def = [notBareRepo $ withOptions [fileOption, pathdepthOption, relaxedOption] $
	command "addurl" (paramRepeating paramUrl) seek
		SectionCommon "add urls to annex"]

fileOption :: Option
fileOption = fieldOption [] "file" paramFile "specify what file the url is added to"

pathdepthOption :: Option
pathdepthOption = fieldOption [] "pathdepth" paramNumber "path components to use in filename"

relaxedOption :: Option
relaxedOption = flagOption [] "relaxed" "skip size check"

seek :: CommandSeek
seek ps = do
	f <- getOptionField fileOption return
	relaxed <- getOptionFlag relaxedOption
	d <- getOptionField pathdepthOption (return . maybe Nothing readish)
	withStrings (start relaxed f d) ps

start :: Bool -> Maybe FilePath -> Maybe Int -> String -> CommandStart
start relaxed optfile pathdepth s = go $ fromMaybe bad $ parseURI s
  where
  	(s', downloader) = getDownloader s
	bad = fromMaybe (error $ "bad url " ++ s') $
		parseURI $ escapeURIString isUnescapedInURI s'
	choosefile = flip fromMaybe optfile
	go url = case downloader of
		QuviDownloader -> usequvi
		DefaultDownloader ->
#ifdef WITH_QUVI
			ifM (quviSupported s')
				( usequvi
				, regulardownload url
				)
#else
			regulardownload url
#endif
	regulardownload url = do
		pathmax <- liftIO $ fileNameLengthLimit "."
		let file = choosefile $ url2file url pathdepth pathmax
		showStart "addurl" file
		next $ perform relaxed s' file
#ifdef WITH_QUVI
	badquvi = error $ "quvi does not know how to download url " ++ s'
	usequvi = do
		page <- fromMaybe badquvi
			<$> withQuviOptions Quvi.forceQuery [Quvi.quiet, Quvi.httponly] s'
		let link = fromMaybe badquvi $ headMaybe $ Quvi.pageLinks page
		pathmax <- liftIO $ fileNameLengthLimit "."
		let file = choosefile $ truncateFilePath pathmax $ sanitizeFilePath $
			Quvi.pageTitle page ++ "." ++ Quvi.linkSuffix link
		showStart "addurl" file
		next $ performQuvi relaxed s' (Quvi.linkUrl link) file
#else
	usequvi = error "not built with quvi support"
#endif

#ifdef WITH_QUVI
performQuvi :: Bool -> URLString -> URLString -> FilePath -> CommandPerform
performQuvi relaxed pageurl videourl file = ifAnnexed file addurl geturl
  where
  	quviurl = setDownloader pageurl QuviDownloader
  	addurl key = next $ cleanup quviurl file key Nothing
	geturl = next $ isJust <$> addUrlFileQuvi relaxed quviurl videourl file
#endif

#ifdef WITH_QUVI
addUrlFileQuvi :: Bool -> URLString -> URLString -> FilePath -> Annex (Maybe Key)
addUrlFileQuvi relaxed quviurl videourl file = do
	key <- Backend.URL.fromUrl quviurl Nothing
	ifM (pure relaxed <||> Annex.getState Annex.fast)
		( do
			cleanup' quviurl file key Nothing
			return (Just key)
		, do
			{- Get the size, and use that to check
			 - disk space. However, the size info is not
			 - retained, because the size of a video stream
			 - might change and we want to be able to download
			 - it later. -}
			sizedkey <- addSizeUrlKey videourl key
			prepGetViaTmpChecked sizedkey Nothing $ do
				tmp <- fromRepo $ gitAnnexTmpObjectLocation key
				showOutput
				ok <- Transfer.notifyTransfer Transfer.Download (Just file) $
					Transfer.download webUUID key (Just file) Transfer.forwardRetry $ const $ do
						liftIO $ createDirectoryIfMissing True (parentDir tmp)
						downloadUrl [videourl] tmp
				if ok
					then do
						cleanup' quviurl file key (Just tmp)
						return (Just key)
					else return Nothing
		)
#endif

perform :: Bool -> URLString -> FilePath -> CommandPerform
perform relaxed url file = ifAnnexed file addurl geturl
  where
	geturl = next $ isJust <$> addUrlFile relaxed url file
	addurl key
		| relaxed = do
			setUrlPresent key url
			next $ return True
		| otherwise = ifM (elem url <$> getUrls key)
			( stop
			, do
				(exists, samesize) <- Url.withUrlOptions $ Url.check url (keySize key)
				if exists && samesize
					then do
						setUrlPresent key url
						next $ return True
					else do
						warning $ "while adding a new url to an already annexed file, " ++ if exists
							then "url does not have expected file size (use --relaxed to bypass this check) " ++ url
							else "failed to verify url exists: " ++ url
						stop
			)

addUrlFile :: Bool -> URLString -> FilePath -> Annex (Maybe Key)
addUrlFile relaxed url file = do
	liftIO $ createDirectoryIfMissing True (parentDir file)
	ifM (Annex.getState Annex.fast <||> pure relaxed)
		( nodownload relaxed url file
		, do
			showAction $ "downloading " ++ url ++ " "
			download url file
		)

download :: URLString -> FilePath -> Annex (Maybe Key)
download url file = do
	{- Generate a dummy key to use for this download, before we can
	 - examine the file and find its real key. This allows resuming
	 - downloads, as the dummy key for a given url is stable. -}
	dummykey <- addSizeUrlKey url =<< Backend.URL.fromUrl url Nothing
	prepGetViaTmpChecked dummykey Nothing $ do
		tmp <- fromRepo $ gitAnnexTmpObjectLocation dummykey
		showOutput
		ifM (runtransfer dummykey tmp)
			( do
				backend <- chooseBackend file
				let source = KeySource
					{ keyFilename = file
					, contentLocation = tmp
					, inodeCache = Nothing
					}
				k <- genKey source backend
				case k of
					Nothing -> return Nothing
					Just (key, _) -> do
						cleanup' url file key (Just tmp)
						return (Just key)
			, return Nothing
			)
  where
  	runtransfer dummykey tmp =  Transfer.notifyTransfer Transfer.Download (Just file) $
		Transfer.download webUUID dummykey (Just file) Transfer.forwardRetry $ const $ do
			liftIO $ createDirectoryIfMissing True (parentDir tmp)
			downloadUrl [url] tmp

{- Hits the url to get the size, if available.
 -
 - This is needed to avoid exceeding the diskreserve when downloading,
 - and so the assistant can display a pretty progress bar.
 -}
addSizeUrlKey :: URLString -> Key -> Annex Key
addSizeUrlKey url key = do
	size <- snd <$> Url.withUrlOptions (Url.exists url)
	return $ key { keySize = size }

cleanup :: URLString -> FilePath -> Key -> Maybe FilePath -> Annex Bool
cleanup url file key mtmp = do
	cleanup' url file key mtmp
	return True

cleanup' :: URLString -> FilePath -> Key -> Maybe FilePath -> Annex ()
cleanup' url file key mtmp = do
	when (isJust mtmp) $
		logStatus key InfoPresent
	setUrlPresent key url
	Command.Add.addLink file key Nothing
	whenM isDirect $ do
		void $ addAssociatedFile key file
		{- For moveAnnex to work in direct mode, the symlink
		 - must already exist, so flush the queue. -}
		Annex.Queue.flush
	maybe noop (moveAnnex key) mtmp

nodownload :: Bool -> URLString -> FilePath -> Annex (Maybe Key)
nodownload relaxed url file = do
	(exists, size) <- if relaxed
		then pure (True, Nothing)
		else Url.withUrlOptions (Url.exists url)
	if exists
		then do
			key <- Backend.URL.fromUrl url size
			cleanup' url file key Nothing
			return (Just key)
		else do
			warning $ "unable to access url: " ++ url
			return Nothing

url2file :: URI -> Maybe Int -> Int -> FilePath
url2file url pathdepth pathmax = case pathdepth of
	Nothing -> truncateFilePath pathmax $ sanitizeFilePath fullurl
	Just depth
		| depth >= length urlbits -> frombits id
		| depth > 0 -> frombits $ drop depth
		| depth < 0 -> frombits $ reverse . take (negate depth) . reverse
		| otherwise -> error "bad --pathdepth"
  where
	fullurl = uriRegName auth ++ uriPath url ++ uriQuery url
	frombits a = intercalate "/" $ a urlbits
	urlbits = map (truncateFilePath pathmax . sanitizeFilePath) $
		filter (not . null) $ split "/" fullurl
	auth = fromMaybe (error $ "bad url " ++ show url) $ uriAuthority url


code:
{- git-annex assistant
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.Assistant where

import Common.Annex
import Command
import qualified Command.Watch
import Annex.Init
import Config.Files
import qualified Build.SysConfig
import Utility.HumanTime
import Assistant.Install

import System.Environment

def :: [Command]
def = [noRepo checkAutoStart $ dontCheck repoExists $ withOptions options $
	notBareRepo $ command "assistant" paramNothing seek SectionCommon
		"automatically handle changes"]

options :: [Option]
options =
	[ Command.Watch.foregroundOption
	, Command.Watch.stopOption
	, autoStartOption
	, startDelayOption
	]

autoStartOption :: Option
autoStartOption = flagOption [] "autostart" "start in known repositories"

startDelayOption :: Option
startDelayOption = fieldOption [] "startdelay" paramNumber "delay before running startup scan"

seek :: CommandSeek
seek ps = do
	stopdaemon <- getOptionFlag Command.Watch.stopOption
	foreground <- getOptionFlag Command.Watch.foregroundOption
	autostart <- getOptionFlag autoStartOption
	startdelay <- getOptionField startDelayOption (pure . maybe Nothing parseDuration)
	withNothing (start foreground stopdaemon autostart startdelay) ps

start :: Bool -> Bool -> Bool -> Maybe Duration -> CommandStart
start foreground stopdaemon autostart startdelay
	| autostart = do
		liftIO $ autoStart startdelay
		stop
	| otherwise = do
		liftIO ensureInstalled
		ensureInitialized
		Command.Watch.start True foreground stopdaemon startdelay

{- Run outside a git repository. Check to see if any parameter is
 - --autostart and enter autostart mode. -}
checkAutoStart :: CmdParams -> IO ()
checkAutoStart _ = ifM (elem "--autostart" <$> getArgs)
	( autoStart Nothing
	, error "Not in a git repository."
	)

autoStart :: Maybe Duration -> IO ()
autoStart startdelay = do
	dirs <- liftIO readAutoStartFile
	when (null dirs) $ do
		f <- autoStartFile
		error $ "Nothing listed in " ++ f
	program <- readProgramFile
	haveionice <- pure Build.SysConfig.ionice <&&> inPath "ionice"
	forM_ dirs $ \d -> do
		putStrLn $ "git-annex autostart in " ++ d
		ifM (catchBoolIO $ go haveionice program d)
			( putStrLn "ok"
			, putStrLn "failed"
			)
  where
	go haveionice program dir = do
		setCurrentDirectory dir
		if haveionice
			then boolSystem "ionice" (Param "-c3" : Param program : baseparams)
			else boolSystem program baseparams
	  where
		baseparams =
			[ Param "assistant"
			, Param $ "--startdelay=" ++ fromDuration (fromMaybe (Duration 5) startdelay)
			]


code:
{- git-annex command
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.Commit where

import Common.Annex
import Command
import qualified Annex.Branch
import qualified Git

def :: [Command]
def = [command "commit" paramNothing seek
	SectionPlumbing "commits any staged changes to the git-annex branch"]

seek :: CommandSeek
seek = withNothing start

start :: CommandStart
start = next $ next $ do
	Annex.Branch.commit "update"
	_ <- runhook <=< inRepo $ Git.hookPath "annex-content"
	return True
  where
	runhook (Just hook) = liftIO $ boolSystem hook []
	runhook Nothing = return True


code:
{- git-annex command
 -
 - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.ConfigList where

import Common.Annex
import Command
import Annex.UUID
import Annex.Init
import qualified Annex.Branch
import qualified Git.Config
import Remote.GCrypt (coreGCryptId)

def :: [Command]
def = [noCommit $ command "configlist" paramNothing seek
	SectionPlumbing "outputs relevant git configuration"]

seek :: CommandSeek
seek = withNothing start

start :: CommandStart
start = do
	u <- findOrGenUUID
	showConfig "annex.uuid" $ fromUUID u
	showConfig coreGCryptId =<< fromRepo (Git.Config.get coreGCryptId "")
	stop
  where
  	showConfig k v = liftIO $ putStrLn $ k ++ "=" ++ v

{- The repository may not yet have a UUID; automatically initialize it
 - when there's a git-annex branch available. -}
findOrGenUUID :: Annex UUID
findOrGenUUID = do
	u <- getUUID
	if u /= NoUUID
		then return u
		else ifM Annex.Branch.hasSibling
			( do
				initialize Nothing
				getUUID
			, return NoUUID
			)


code:
{- git-annex command
 -
 - Copyright 2010 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.Copy where

import Common.Annex
import Command
import qualified Command.Move
import qualified Remote
import Annex.Wanted
import Config.NumCopies

def :: [Command]
def = [withOptions Command.Move.moveOptions $ command "copy" paramPaths seek
	SectionCommon "copy content of files to/from another repository"]

seek :: CommandSeek
seek ps = do
	to <- getOptionField toOption Remote.byNameWithUUID
	from <- getOptionField fromOption Remote.byNameWithUUID
	withKeyOptions
	 	(Command.Move.startKey to from False)
		(withFilesInGit $ whenAnnexed $ start to from)
		ps

{- A copy is just a move that does not delete the source file.
 - However, --auto mode avoids unnecessary copies, and avoids getting or
 - sending non-preferred content. -}
start :: Maybe Remote -> Maybe Remote -> FilePath -> Key -> CommandStart
start to from file key = stopUnless shouldCopy $
	Command.Move.start to from False file key
  where
	shouldCopy = checkAuto (check <||> numCopiesCheck file key (<))
	check = case to of
		Nothing -> wantGet False (Just key) (Just file)
		Just r -> wantSend False (Just key) (Just file) (Remote.uuid r)


code:
{- git-annex command
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.Dead where

import Command
import Types.TrustLevel
import Command.Trust (trustCommand)

def :: [Command]
def = [command "dead" (paramRepeating paramRemote) seek
	SectionSetup "hide a lost repository"]

seek :: CommandSeek
seek = trustCommand "dead" DeadTrusted


code:
{- git-annex command
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.Describe where

import Common.Annex
import Command
import qualified Remote
import Logs.UUID

def :: [Command]
def = [command "describe" (paramPair paramRemote paramDesc) seek
	SectionSetup "change description of a repository"]

seek :: CommandSeek
seek = withWords start

start :: [String] -> CommandStart
start (name:description) = do
	showStart "describe" name
	u <- Remote.nameToUUID name
	next $ perform u $ unwords description
start _ = error "Specify a repository and a description."

perform :: UUID -> String -> CommandPerform
perform u description = do
	describeUUID u description
	next $ return True


code:
{- git-annex command
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.Direct where

import Control.Exception.Extensible

import Common.Annex
import Command
import qualified Git
import qualified Git.LsFiles
import qualified Git.Branch
import Config
import Annex.Direct
import Annex.Exception

def :: [Command]
def = [notBareRepo $ noDaemonRunning $
	command "direct" paramNothing seek
		SectionSetup "switch repository to direct mode"]

seek :: CommandSeek
seek = withNothing start

start :: CommandStart
start = ifM isDirect ( stop , next perform )

perform :: CommandPerform
perform = do
	showStart "commit" ""
	showOutput
	_ <- inRepo $ Git.Branch.commitCommand Git.Branch.ManualCommit
		[ Param "-a"
		, Param "-m"
		, Param "commit before switching to direct mode"
		]
	showEndOk

	top <- fromRepo Git.repoPath
	(l, clean) <- inRepo $ Git.LsFiles.inRepo [top]
	forM_ l go
	void $ liftIO clean
	next cleanup
  where
	go = whenAnnexed $ \f k -> do
		r <- toDirectGen k f
		case r of
			Nothing -> noop
			Just a -> do
				showStart "direct" f
				r' <- tryAnnex a
				case r' of
					Left e -> warnlocked e
					Right _ -> showEndOk
		return Nothing

	warnlocked :: SomeException -> Annex ()
	warnlocked e = do
		warning $ show e
		warning "leaving this file as-is; correct this problem and run git annex fsck on it"

cleanup :: CommandCleanup
cleanup = do
	showStart "direct" ""
	setDirect True
	return True


code:
{- git-annex command
 -
 - Copyright 2010 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.Drop where

import Common.Annex
import Command
import qualified Remote
import qualified Annex
import Annex.UUID
import Logs.Location
import Logs.Trust
import Logs.PreferredContent
import Config.NumCopies
import Annex.Content
import Annex.Wanted
import Annex.Notification

import qualified Data.Set as S

def :: [Command]
def = [withOptions [dropFromOption] $ command "drop" paramPaths seek
	SectionCommon "indicate content of files not currently wanted"]

dropFromOption :: Option
dropFromOption = fieldOption ['f'] "from" paramRemote "drop content from a remote"

seek :: CommandSeek
seek ps = do
	from <- getOptionField dropFromOption Remote.byNameWithUUID
	withFilesInGit (whenAnnexed $ start from) ps

start :: Maybe Remote -> FilePath -> Key -> CommandStart
start from file key = checkDropAuto from file key $ \numcopies ->
	stopUnless (checkAuto $ wantDrop False (Remote.uuid <$> from) (Just key) (Just file)) $
		case from of
			Nothing -> startLocal (Just file) numcopies key Nothing
			Just remote -> do
				u <- getUUID
				if Remote.uuid remote == u
					then startLocal (Just file) numcopies key Nothing
					else startRemote (Just file) numcopies key remote

startLocal :: AssociatedFile -> NumCopies -> Key -> Maybe Remote -> CommandStart
startLocal afile numcopies key knownpresentremote = stopUnless (inAnnex key) $ do
	showStart' "drop" key afile
	next $ performLocal key afile numcopies knownpresentremote

startRemote :: AssociatedFile -> NumCopies -> Key -> Remote -> CommandStart
startRemote afile numcopies key remote = do
	showStart' ("drop " ++ Remote.name remote) key afile
	next $ performRemote key afile numcopies remote

performLocal :: Key -> AssociatedFile -> NumCopies -> Maybe Remote -> CommandPerform
performLocal key afile numcopies knownpresentremote = lockContent key $ do
	(remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
	let trusteduuids' = case knownpresentremote of
		Nothing -> trusteduuids
		Just r -> nub (Remote.uuid r:trusteduuids)
	untrusteduuids <- trustGet UnTrusted
	let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids'++untrusteduuids)
	u <- getUUID
	ifM (canDrop u key afile numcopies trusteduuids' tocheck [])
		( do
			removeAnnex key
			notifyDrop afile True
			next $ cleanupLocal key
		, do
			notifyDrop afile False
			stop
		)

performRemote :: Key -> AssociatedFile -> NumCopies -> Remote -> CommandPerform
performRemote key afile numcopies remote = lockContent key $ do
	-- Filter the remote it's being dropped from out of the lists of
	-- places assumed to have the key, and places to check.
	-- When the local repo has the key, that's one additional copy,
	-- as long asthe local repo is not untrusted.
	(remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
	present <- inAnnex key
	u <- getUUID
	trusteduuids' <- if present
		then ifM ((<= SemiTrusted) <$> lookupTrust u)
			( pure (u:trusteduuids)
			, pure trusteduuids
			)
		else pure trusteduuids
	let have = filter (/= uuid) trusteduuids'
	untrusteduuids <- trustGet UnTrusted
	let tocheck = filter (/= remote) $
		Remote.remotesWithoutUUID remotes (have++untrusteduuids)
	stopUnless (canDrop uuid key afile numcopies have tocheck [uuid]) $ do
		ok <- Remote.removeKey remote key
		next $ cleanupRemote key remote ok
  where
	uuid = Remote.uuid remote

cleanupLocal :: Key -> CommandCleanup
cleanupLocal key = do
	logStatus key InfoMissing
	return True

cleanupRemote :: Key -> Remote -> Bool -> CommandCleanup
cleanupRemote key remote ok = do
	when ok $
		Remote.logStatus remote key InfoMissing
	return ok

{- Checks specified remotes to verify that enough copies of a key exist to
 - allow it to be safely removed (with no data loss). Can be provided with
 - some locations where the key is known/assumed to be present.
 -
 - Also checks if it's required content, and refuses to drop if so.
 -
 - --force overrides and always allows dropping.
 -}
canDrop :: UUID -> Key -> AssociatedFile -> NumCopies -> [UUID] -> [Remote] -> [UUID] -> Annex Bool
canDrop dropfrom key afile numcopies have check skip = ifM (Annex.getState Annex.force)
	( return True
	, checkRequiredContent dropfrom key afile
		<&&>
	  findCopies key numcopies skip have check
	)

findCopies :: Key -> NumCopies -> [UUID] -> [UUID] -> [Remote] -> Annex Bool
findCopies key need skip = helper [] []
  where
	helper bad missing have []
		| NumCopies (length have) >= need = return True
		| otherwise = notEnoughCopies key need have (skip++missing) bad
	helper bad missing have (r:rs)
		| NumCopies (length have) >= need = return True
		| otherwise = do
			let u = Remote.uuid r
			let duplicate = u `elem` have
			haskey <- Remote.hasKey r key
			case (duplicate, haskey) of
				(False, Right True)  -> helper bad missing (u:have) rs
				(False, Left _)      -> helper (r:bad) missing have rs
				(False, Right False) -> helper bad (u:missing) have rs
				_                    -> helper bad missing have rs

notEnoughCopies :: Key -> NumCopies -> [UUID] -> [UUID] -> [Remote] -> Annex Bool
notEnoughCopies key need have skip bad = do
	unsafe
	showLongNote $
		"Could only verify the existence of " ++
		show (length have) ++ " out of " ++ show (fromNumCopies need) ++
		" necessary copies"
	Remote.showTriedRemotes bad
	Remote.showLocations key (have++skip)
		"Rather than dropping this file, try using: git annex move"
	hint
	return False
  where
	unsafe = showNote "unsafe"
	hint = showLongNote "(Use --force to override this check, or adjust numcopies.)"

checkRequiredContent :: UUID -> Key -> AssociatedFile -> Annex Bool
checkRequiredContent u k afile =
	ifM (isRequiredContent (Just u) S.empty (Just k) afile False)
		( requiredContent
		, return True
		)

requiredContent :: Annex Bool
requiredContent = do
	showLongNote "That file is required content, it cannot be dropped!"
	showLongNote "(Use --force to override this check, or adjust required content configuration.)"
	return False

{- In auto mode, only runs the action if there are enough
 - copies on other semitrusted repositories. -}
checkDropAuto :: Maybe Remote -> FilePath -> Key -> (NumCopies -> CommandStart) -> CommandStart
checkDropAuto mremote file key a = do
	numcopies <- getFileNumCopies file
	Annex.getState Annex.auto >>= auto numcopies
  where
	auto numcopies False = a numcopies
	auto numcopies True = do
		locs <- Remote.keyLocations key
		uuid <- getUUID
		let remoteuuid = fromMaybe uuid $ Remote.uuid <$> mremote
		locs' <- trustExclude UnTrusted $ filter (/= remoteuuid) locs
		if NumCopies (length locs') >= numcopies
			then a numcopies
			else stop


code:
{- git-annex command
 -
 - Copyright 2010 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.DropKey where

import Common.Annex
import Command
import qualified Annex
import Logs.Location
import Annex.Content

def :: [Command]
def = [noCommit $ command "dropkey" (paramRepeating paramKey) seek
	SectionPlumbing "drops annexed content for specified keys"]

seek :: CommandSeek
seek = withKeys start

start :: Key -> CommandStart
start key = stopUnless (inAnnex key) $ do
	unlessM (Annex.getState Annex.force) $
		error "dropkey can cause data loss; use --force if you're sure you want to do this"
	showStart' "dropkey" key Nothing
	next $ perform key

perform :: Key -> CommandPerform
perform key = lockContent key $ do
	removeAnnex key
	next $ cleanup key

cleanup :: Key -> CommandCleanup
cleanup key = do
	logStatus key InfoMissing
	return True


code:
{- git-annex command
 -
 - Copyright 2010,2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.DropUnused where

import Common.Annex
import Command
import qualified Annex
import qualified Command.Drop
import qualified Remote
import qualified Git
import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused)
import Config.NumCopies

def :: [Command]
def = [withOptions [Command.Drop.dropFromOption] $
	command "dropunused" (paramRepeating paramNumRange)
		seek SectionMaintenance "drop unused file content"]

seek :: CommandSeek
seek ps = do
	numcopies <- getNumCopies
	withUnusedMaps (start numcopies) ps

start :: NumCopies -> UnusedMaps -> Int -> CommandStart
start numcopies = startUnused "dropunused" (perform numcopies) (performOther gitAnnexBadLocation) (performOther gitAnnexTmpObjectLocation)

perform :: NumCopies -> Key -> CommandPerform
perform numcopies key = maybe droplocal dropremote =<< Remote.byNameWithUUID =<< from
  where
	dropremote r = do
		showAction $ "from " ++ Remote.name r
		Command.Drop.performRemote key Nothing numcopies r
	droplocal = Command.Drop.performLocal key Nothing numcopies Nothing
	from = Annex.getField $ optionName Command.Drop.dropFromOption

performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform
performOther filespec key = do
	f <- fromRepo $ filespec key
	liftIO $ nukeFile f
	next $ return True


code:
{- git-annex command
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.EnableRemote where

import Common.Annex
import Command
import qualified Logs.Remote
import qualified Types.Remote as R
import qualified Command.InitRemote as InitRemote

import qualified Data.Map as M

def :: [Command]
def = [command "enableremote"
	(paramPair paramName $ paramOptional $ paramRepeating paramKeyValue)
	seek SectionSetup "enables use of an existing special remote"]

seek :: CommandSeek
seek = withWords start

start :: [String] -> CommandStart
start [] = unknownNameError "Specify the name of the special remote to enable."
start (name:ws) = go =<< InitRemote.findExisting name
  where
	config = Logs.Remote.keyValToConfig ws

  	go Nothing = unknownNameError "Unknown special remote name."
	go (Just (u, c)) = do
		let fullconfig = config `M.union` c
		t <- InitRemote.findType fullconfig

		showStart "enableremote" name
		next $ perform t u fullconfig

unknownNameError :: String -> Annex a
unknownNameError prefix = do
	names <- InitRemote.remoteNames
	error $ prefix ++ "\n" ++
		if null names
			then "(No special remotes are currently known; perhaps use initremote instead?)"
			else "Known special remotes: " ++ unwords names

perform :: RemoteType -> UUID -> R.RemoteConfig -> CommandPerform
perform t u c = do
	(c', u') <- R.setup t (Just u) Nothing c
	next $ cleanup u' c'

cleanup :: UUID -> R.RemoteConfig -> CommandCleanup
cleanup u c = do
	Logs.Remote.configSet u c
	return True


code:
{- git-annex command
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.ExamineKey where

import Common.Annex
import Command
import qualified Utility.Format
import Command.Find (formatOption, getFormat, showFormatted, keyVars)
import Types.Key

def :: [Command]
def = [noCommit $ noMessages $ withOptions [formatOption, jsonOption] $
	command "examinekey" (paramRepeating paramKey) seek
	SectionPlumbing "prints information from a key"]

seek :: CommandSeek
seek ps = do
	format <- getFormat
	withKeys (start format) ps

start :: Maybe Utility.Format.Format -> Key -> CommandStart
start format key = do
	showFormatted format (key2file key) (keyVars key)
	stop


code:
{- git-annex command
 -
 - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.Find where

import qualified Data.Map as M

import Common.Annex
import Command
import Annex.Content
import Limit
import qualified Annex
import qualified Utility.Format
import Utility.DataUnits
import Types.Key

def :: [Command]
def = [mkCommand $ command "find" paramPaths seek SectionQuery "lists available files"]

mkCommand :: Command -> Command
mkCommand = noCommit . noMessages . withOptions [formatOption, print0Option, jsonOption]

formatOption :: Option
formatOption = fieldOption [] "format" paramFormat "control format of output"

getFormat :: Annex (Maybe Utility.Format.Format)
getFormat = getOptionField formatOption $ return . fmap Utility.Format.gen

print0Option :: Option
print0Option = Option [] ["print0"] (NoArg set)
	"terminate output with null"
  where
	set = Annex.setField (optionName formatOption) "${file}\0"

seek :: CommandSeek
seek ps = do
	format <- getFormat
	withFilesInGit (whenAnnexed $ start format) ps

start :: Maybe Utility.Format.Format -> FilePath -> Key -> CommandStart
start format file key = do
	-- only files inAnnex are shown, unless the user has requested
	-- others via a limit
	whenM (limited <||> inAnnex key) $
		showFormatted format file $ ("file", file) : keyVars key
	stop

showFormatted :: Maybe Utility.Format.Format -> String -> [(String, String)] -> Annex ()
showFormatted format unformatted vars =
	unlessM (showFullJSON vars) $
		case format of
			Nothing -> liftIO $ putStrLn unformatted
			Just formatter -> liftIO $ putStr $
				Utility.Format.format formatter $
					M.fromList vars

keyVars :: Key -> [(String, String)]
keyVars key =
	[ ("key", key2file key)
	, ("backend", keyBackendName key)
	, ("bytesize", size show)
	, ("humansize", size $ roughSize storageUnits True)
	, ("keyname", keyName key)
	, ("hashdirlower", hashDirLower key)
	, ("hashdirmixed", hashDirMixed key)
	, ("mtime", whenavail show $ keyMtime key)
	]
  where
	size c = whenavail c $ keySize key
	whenavail = maybe "unknown"


code:
{- git-annex command
 -
 - Copyright 2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.FindRef where

import Command
import qualified Command.Find as Find

def :: [Command]
def = [Find.mkCommand $ command "findref" paramRef seek SectionPlumbing
	"lists files in a git ref"]

seek :: CommandSeek
seek refs = do
	format <- Find.getFormat
	Find.start format `withFilesInRefs` refs


code:
{- git-annex command
 -
 - Copyright 2010 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Command.Fix where

import Common.Annex
import Command
import qualified Annex.Queue
#ifdef WITH_CLIBS
#ifndef __ANDROID__
import Utility.Touch
#endif
#endif

def :: [Command]
def = [notDirect $ noCommit $ command "fix" paramPaths seek
	SectionMaintenance "fix up symlinks to point to annexed content"]

seek :: CommandSeek
seek = withFilesInGit $ whenAnnexed start

{- Fixes the symlink to an annexed file. -}
start :: FilePath -> Key -> CommandStart
start file key = do
	link <- inRepo $ gitAnnexLink file key
	stopUnless ((/=) (Just link) <$> liftIO (catchMaybeIO $ readSymbolicLink file)) $ do
		showStart "fix" file
		next $ perform file link

perform :: FilePath -> FilePath -> CommandPerform
perform file link = do
	liftIO $ do
#ifdef WITH_CLIBS
#ifndef __ANDROID__
		-- preserve mtime of symlink
		mtime <- catchMaybeIO $ TimeSpec . modificationTime
			<$> getSymbolicLinkStatus file
#endif
#endif
		createDirectoryIfMissing True (parentDir file)
		removeFile file
		createSymbolicLink link file
#ifdef WITH_CLIBS
#ifndef __ANDROID__
		maybe noop (\t -> touch file t False) mtime
#endif
#endif
	next $ cleanup file

cleanup :: FilePath -> CommandCleanup
cleanup file = do
	Annex.Queue.addCommand "add" [Param "--force", Param "--"] [file]
	return True


code:
{- git-annex command
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.Forget where

import Common.Annex
import Command
import qualified Annex.Branch as Branch
import Logs.Transitions
import qualified Annex

import Data.Time.Clock.POSIX

def :: [Command]
def = [withOptions forgetOptions $ command "forget" paramNothing seek
		SectionMaintenance "prune git-annex branch history"]

forgetOptions :: [Option]
forgetOptions = [dropDeadOption]

dropDeadOption :: Option
dropDeadOption = flagOption [] "drop-dead" "drop references to dead repositories"

seek :: CommandSeek
seek ps = do
	dropdead <- getOptionFlag dropDeadOption
	withNothing (start dropdead) ps

start :: Bool -> CommandStart
start dropdead = do
	showStart "forget" "git-annex"
	now <- liftIO getPOSIXTime
	let basets = addTransition now ForgetGitHistory noTransitions
	let ts = if dropdead
		then addTransition now ForgetDeadRemotes basets
		else basets
	next $ perform ts =<< Annex.getState Annex.force

perform :: Transitions -> Bool -> CommandPerform
perform ts True = do
	recordTransitions Branch.change ts
	-- get branch committed before contining with the transition
	Branch.update
	void $ Branch.performTransitions ts True []
	next $ return True
perform _ False = do
	showLongNote "To forget git-annex branch history, you must specify --force. This deletes metadata!"
	stop


code:
{- git-annex command
 -
 - Copyright 2010 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.FromKey where

import Common.Annex
import Command
import qualified Annex.Queue
import Annex.Content
import Types.Key

def :: [Command]
def = [notDirect $ notBareRepo $
	command "fromkey" (paramPair paramKey paramPath) seek
		SectionPlumbing "adds a file using a specific key"]

seek :: CommandSeek
seek = withWords start

start :: [String] -> CommandStart
start (keyname:file:[]) = do
	let key = fromMaybe (error "bad key") $ file2key keyname
	inbackend <- inAnnex key
	unless inbackend $ error $
		"key ("++ keyname ++") is not present in backend"
	showStart "fromkey" file
	next $ perform key file
start _ = error "specify a key and a dest file"

perform :: Key -> FilePath -> CommandPerform
perform key file = do
	link <- inRepo $ gitAnnexLink file key
	liftIO $ createDirectoryIfMissing True (parentDir file)
	liftIO $ createSymbolicLink link file
	next $ cleanup file

cleanup :: FilePath -> CommandCleanup
cleanup file = do
	Annex.Queue.addCommand "add" [Param "--"] [file]
	return True


code:
{- git-annex command
 -
 - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Command.Fsck where

import Common.Annex
import Command
import qualified Annex
import qualified Remote
import qualified Types.Backend
import qualified Types.Key
import qualified Backend
import Annex.Content
import Annex.Content.Direct
import Annex.Direct
import Annex.Perms
import Annex.Link
import Logs.Location
import Logs.Trust
import Config.NumCopies
import Annex.UUID
import Utility.DataUnits
import Utility.FileMode
import Config
import Types.Key
import Types.CleanupActions
import Utility.HumanTime
import Git.FilePath
import Utility.PID

import Data.Time.Clock.POSIX
import Data.Time
import System.Posix.Types (EpochTime)
import System.Locale

def :: [Command]
def = [withOptions fsckOptions $ command "fsck" paramPaths seek
	SectionMaintenance "check for problems"]

fsckFromOption :: Option
fsckFromOption = fieldOption ['f'] "from" paramRemote "check remote"

startIncrementalOption :: Option
startIncrementalOption = flagOption ['S'] "incremental" "start an incremental fsck"

moreIncrementalOption :: Option
moreIncrementalOption = flagOption ['m'] "more" "continue an incremental fsck"

incrementalScheduleOption :: Option
incrementalScheduleOption = fieldOption [] "incremental-schedule" paramTime
	"schedule incremental fscking"

fsckOptions :: [Option]
fsckOptions =
	[ fsckFromOption
	, startIncrementalOption
	, moreIncrementalOption
	, incrementalScheduleOption
	] ++ keyOptions

seek :: CommandSeek
seek ps = do
	from <- getOptionField fsckFromOption Remote.byNameWithUUID
	i <- getIncremental
	withKeyOptions
		(\k -> startKey i k =<< getNumCopies)
		(withFilesInGit $ whenAnnexed $ start from i)
		ps

getIncremental :: Annex Incremental
getIncremental = do
	i <- maybe (return False) (checkschedule . parseDuration)
		=<< Annex.getField (optionName incrementalScheduleOption)
	starti <- Annex.getFlag (optionName startIncrementalOption)
	morei <- Annex.getFlag (optionName moreIncrementalOption)
	case (i, starti, morei) of
		(False, False, False) -> return NonIncremental
		(False, True, False) -> startIncremental
		(False ,False, True) -> ContIncremental <$> getStartTime
		(True, False, False) ->
			maybe startIncremental (return . ContIncremental . Just)
				=<< getStartTime
		_ -> error "Specify only one of --incremental, --more, or --incremental-schedule"
  where
	startIncremental = do
		recordStartTime
		return StartIncremental

	checkschedule Nothing = error "bad --incremental-schedule value"
	checkschedule (Just delta) = do
		Annex.addCleanup FsckCleanup $ do
			v <- getStartTime
			case v of
				Nothing -> noop
				Just started -> do
					now <- liftIO getPOSIXTime
					when (now - realToFrac started >= durationToPOSIXTime delta)
						resetStartTime
		return True

start :: Maybe Remote -> Incremental -> FilePath -> Key -> CommandStart
start from inc file key = do
	v <- Backend.getBackend file key
	case v of
		Nothing -> stop
		Just backend -> do
			numcopies <- getFileNumCopies file
			case from of
				Nothing -> go $ perform key file backend numcopies
				Just r -> go $ performRemote key file backend numcopies r
  where
	go = runFsck inc file key

perform :: Key -> FilePath -> Backend -> NumCopies -> Annex Bool
perform key file backend numcopies = check
	-- order matters
	[ fixLink key file
	, verifyLocationLog key file
	, verifyDirectMapping key file
	, verifyDirectMode key file
	, checkKeySize key
	, checkBackend backend key (Just file)
	, checkKeyNumCopies key file numcopies
	]

{- To fsck a remote, the content is retrieved to a tmp file,
 - and checked locally. -}
performRemote :: Key -> FilePath -> Backend -> NumCopies -> Remote -> Annex Bool
performRemote key file backend numcopies remote =
	dispatch =<< Remote.hasKey remote key
  where
	dispatch (Left err) = do
		showNote err
		return False
	dispatch (Right True) = withtmp $ \tmpfile ->
		ifM (getfile tmpfile)
			( go True (Just tmpfile)
			, go True Nothing
			)
	dispatch (Right False) = go False Nothing
	go present localcopy = check
		[ verifyLocationLogRemote key file remote present
		, checkKeySizeRemote key remote localcopy
		, checkBackendRemote backend key remote localcopy
		, checkKeyNumCopies key file numcopies
		]
	withtmp a = do
		pid <- liftIO getPID
		t <- fromRepo gitAnnexTmpObjectDir
		createAnnexDirectory t
		let tmp = t </> "fsck" ++ show pid ++ "." ++ keyFile key
		let cleanup = liftIO $ catchIO (removeFile tmp) (const noop)
		cleanup
		cleanup `after` a tmp
	getfile tmp =
		ifM (Remote.retrieveKeyFileCheap remote key tmp)
			( return True
			, ifM (Annex.getState Annex.fast)
				( return False
				, Remote.retrieveKeyFile remote key Nothing tmp dummymeter
				)
			)
	dummymeter _ = noop

startKey :: Incremental -> Key -> NumCopies -> CommandStart
startKey inc key numcopies =
	case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of
		Nothing -> stop
		Just backend -> runFsck inc (key2file key) key $
			performKey key backend numcopies

performKey :: Key -> Backend -> NumCopies -> Annex Bool
performKey key backend numcopies = check
	[ verifyLocationLog key (key2file key)
	, checkKeySize key
	, checkBackend backend key Nothing
	, checkKeyNumCopies key (key2file key) numcopies
	]

check :: [Annex Bool] -> Annex Bool
check cs = and <$> sequence cs

{- Checks that the file's link points correctly to the content.
 -
 - In direct mode, there is only a link when the content is not present.
 -}
fixLink :: Key -> FilePath -> Annex Bool
fixLink key file = do
	want <- inRepo $ gitAnnexLink file key
	have <- getAnnexLinkTarget file
	maybe noop (go want) have
	return True
  where
	go want have
		| want /= fromInternalGitPath have = do
			showNote "fixing link"
			liftIO $ createDirectoryIfMissing True (parentDir file)
			liftIO $ removeFile file
			addAnnexLink want file
		| otherwise = noop

{- Checks that the location log reflects the current status of the key,
 - in this repository only. -}
verifyLocationLog :: Key -> String -> Annex Bool
verifyLocationLog key desc = do
	present <- inAnnex key
	direct <- isDirect
	u <- getUUID

	{- Since we're checking that a key's file is present, throw
	 - in a permission fixup here too. -}
	file <- calcRepo $ gitAnnexLocation key
	when (present && not direct) $
		freezeContent file
	whenM (liftIO $ doesDirectoryExist $ parentDir file) $
		freezeContentDir file

	{- In direct mode, modified files will show up as not present,
	 - but that is expected and not something to do anything about. -}
	if direct && not present
		then return True
		else verifyLocationLog' key desc present u (logChange key u)

verifyLocationLogRemote :: Key -> String -> Remote -> Bool -> Annex Bool
verifyLocationLogRemote key desc remote present =
	verifyLocationLog' key desc present (Remote.uuid remote)
		(Remote.logStatus remote key)

verifyLocationLog' :: Key -> String -> Bool -> UUID -> (LogStatus -> Annex ()) -> Annex Bool
verifyLocationLog' key desc present u updatestatus = do
	uuids <- Remote.keyLocations key
	case (present, u `elem` uuids) of
		(True, False) -> do
				fix InfoPresent
				-- There is no data loss, so do not fail.
				return True
		(False, True) -> do
				fix InfoMissing
				warning $
					"** Based on the location log, " ++ desc
					++ "\n** was expected to be present, " ++
					"but its content is missing."
				return False
		_ -> return True
  where
	fix s = do
		showNote "fixing location log"
		updatestatus s

{- Ensures the direct mode mapping file is consistent. Each file
 - it lists for the key should exist, and the specified file should be
 - included in it.
 -}
verifyDirectMapping :: Key -> FilePath -> Annex Bool
verifyDirectMapping key file = do
	whenM isDirect $ do
		fs <- addAssociatedFile key file
		forM_ fs $ \f ->
			unlessM (liftIO $ doesFileExist f) $
				void $ removeAssociatedFile key f
	return True

{- Ensures that files whose content is available are in direct mode. -}
verifyDirectMode :: Key -> FilePath -> Annex Bool
verifyDirectMode key file = do
	whenM (isDirect <&&> isJust <$> isAnnexLink file) $ do
		v <- toDirectGen key file
		case v of
			Nothing -> noop
			Just a -> do
				showNote "fixing direct mode"
				a
	return True

{- The size of the data for a key is checked against the size encoded in
 - the key's metadata, if available.
 -
 - Not checked in direct mode, because files can be changed directly.
  -}
checkKeySize :: Key -> Annex Bool
checkKeySize key = ifM isDirect
	( return True
	, do
		file <- calcRepo $ gitAnnexLocation key
		ifM (liftIO $ doesFileExist file)
			( checkKeySizeOr badContent key file
			, return True
			)
	)

checkKeySizeRemote :: Key -> Remote -> Maybe FilePath -> Annex Bool
checkKeySizeRemote _ _ Nothing = return True
checkKeySizeRemote key remote (Just file) =
	checkKeySizeOr (badContentRemote remote) key file

checkKeySizeOr :: (Key -> Annex String) -> Key -> FilePath -> Annex Bool
checkKeySizeOr bad key file = case Types.Key.keySize key of
	Nothing -> return True
	Just size -> do
		size' <- fromIntegral . fileSize
			<$> liftIO (getFileStatus file)
		comparesizes size size'
  where
	comparesizes a b = do
		let same = a == b
		unless same $ badsize a b
		return same
	badsize a b = do
		msg <- bad key
		warning $ concat
			[ "Bad file size ("
			, compareSizes storageUnits True a b
			, "); "
			, msg
			]

{- Runs the backend specific check on a key's content.
 -
 - In direct mode this is not done if the file has clearly been modified,
 - because modification of direct mode files is allowed. It's still done
 - if the file does not appear modified, to catch disk corruption, etc.
 -}
checkBackend :: Backend -> Key -> Maybe FilePath -> Annex Bool
checkBackend backend key mfile = go =<< isDirect
  where
  	go False = do
		content <- calcRepo $ gitAnnexLocation key
		checkBackendOr badContent backend key content
	go True = maybe nocheck checkdirect mfile
	checkdirect file = ifM (goodContent key file)
		( checkBackendOr' (badContentDirect file) backend key file
			(goodContent key file)
		, nocheck
		)
	nocheck = return True

checkBackendRemote :: Backend -> Key -> Remote -> Maybe FilePath -> Annex Bool
checkBackendRemote backend key remote = maybe (return True) go
  where
	go = checkBackendOr (badContentRemote remote) backend key

checkBackendOr :: (Key -> Annex String) -> Backend -> Key -> FilePath -> Annex Bool
checkBackendOr bad backend key file =
	checkBackendOr' bad backend key file (return True)

checkBackendOr' :: (Key -> Annex String) -> Backend -> Key -> FilePath -> Annex Bool -> Annex Bool
checkBackendOr' bad backend key file postcheck =
	case Types.Backend.fsckKey backend of
		Nothing -> return True
		Just a -> do
			ok <- a key file
			ifM postcheck
				( do
					unless ok $ do
						msg <- bad key
						warning $ "Bad file content; " ++ msg
					return ok
				, return True
				)

checkKeyNumCopies :: Key -> String -> NumCopies -> Annex Bool
checkKeyNumCopies key file numcopies = do
	(untrustedlocations, safelocations) <- trustPartition UnTrusted =<< Remote.keyLocations key
	let present = NumCopies (length safelocations)
	if present < numcopies
		then do
			ppuuids <- Remote.prettyPrintUUIDs "untrusted" untrustedlocations
			warning $ missingNote file present numcopies ppuuids
			return False
		else return True

missingNote :: String -> NumCopies -> NumCopies -> String -> String
missingNote file (NumCopies 0) _ [] =
		"** No known copies exist of " ++ file
missingNote file (NumCopies 0) _ untrusted =
		"Only these untrusted locations may have copies of " ++ file ++
		"\n" ++ untrusted ++
		"Back it up to trusted locations with git-annex copy."
missingNote file present needed [] =
		"Only " ++ show (fromNumCopies present) ++ " of " ++ show (fromNumCopies needed) ++
		" trustworthy copies exist of " ++ file ++
		"\nBack it up with git-annex copy."
missingNote file present needed untrusted =
		missingNote file present needed [] ++
		"\nThe following untrusted locations may also have copies: " ++
		"\n" ++ untrusted

{- Bad content is moved aside. -}
badContent :: Key -> Annex String
badContent key = do
	dest <- moveBad key
	return $ "moved to " ++ dest

{- Bad content is left where it is, but we touch the file, so it'll be
 - committed to a new key. -}
badContentDirect :: FilePath -> Key -> Annex String
badContentDirect file key = do
	void $ liftIO $ catchMaybeIO $ touchFile file
	logStatus key InfoMissing
	return "left in place for you to examine"

badContentRemote :: Remote -> Key -> Annex String
badContentRemote remote key = do
	ok <- Remote.removeKey remote key
	when ok $
		Remote.logStatus remote key InfoMissing
	return $ (if ok then "dropped from " else "failed to drop from ")
		++ Remote.name remote

data Incremental = StartIncremental | ContIncremental (Maybe EpochTime) | NonIncremental
	deriving (Eq, Show)

runFsck :: Incremental -> FilePath -> Key -> Annex Bool -> CommandStart
runFsck inc file key a = ifM (needFsck inc key)
	( do
		showStart "fsck" file
		next $ do
			ok <- a
			when ok $
				recordFsckTime key
			next $ return ok
	, stop
	)

{- Check if a key needs to be fscked, with support for incremental fscks. -}
needFsck :: Incremental -> Key -> Annex Bool
needFsck (ContIncremental Nothing) _ = return True
needFsck (ContIncremental starttime) key = do
	fscktime <- getFsckTime key
	return $ fscktime < starttime
needFsck _ _ = return True

{- To record the time that a key was last fscked, without
 - modifying its mtime, we set the timestamp of its parent directory.
 - Each annexed file is the only thing in its directory, so this is fine.
 -
 - To record that the file was fscked, the directory's sticky bit is set.
 - (None of the normal unix behaviors of the sticky bit should matter, so
 - we can reuse this permission bit.)
 -
 - Note that this relies on the parent directory being deleted when a file
 - is dropped. That way, if it's later added back, the fsck record
 - won't still be present.
 -}
recordFsckTime :: Key -> Annex ()
recordFsckTime key = do
	parent <- parentDir <$> calcRepo (gitAnnexLocation key)
	liftIO $ void $ tryIO $ do
		touchFile parent
#ifndef mingw32_HOST_OS
		setSticky parent
#endif

getFsckTime :: Key -> Annex (Maybe EpochTime)
getFsckTime key = do
	parent <- parentDir <$> calcRepo (gitAnnexLocation key)
	liftIO $ catchDefaultIO Nothing $ do
		s <- getFileStatus parent
		return $ if isSticky $ fileMode s
			then Just $ modificationTime s
			else Nothing

{- Records the start time of an incremental fsck.
 -
 - To guard against time stamp damange (for example, if an annex directory
 - is copied without -a), the fsckstate file contains a time that should
 - be identical to its modification time.
 - (This is not possible to do on Windows, and so the timestamp in
 - the file will only be equal or greater than the modification time.)
 -}
recordStartTime :: Annex ()
recordStartTime = do
	f <- fromRepo gitAnnexFsckState
	createAnnexDirectory $ parentDir f
	liftIO $ do
		nukeFile f
		withFile f WriteMode $ \h -> do
#ifndef mingw32_HOST_OS
			t <- modificationTime <$> getFileStatus f
#else
			t <- getPOSIXTime
#endif
			hPutStr h $ showTime $ realToFrac t
  where
	showTime :: POSIXTime -> String
	showTime = show

resetStartTime :: Annex ()
resetStartTime = liftIO . nukeFile =<< fromRepo gitAnnexFsckState

{- Gets the incremental fsck start time. -}
getStartTime :: Annex (Maybe EpochTime)
getStartTime = do
	f <- fromRepo gitAnnexFsckState
	liftIO $ catchDefaultIO Nothing $ do
		timestamp <- modificationTime <$> getFileStatus f
		let fromstatus = Just (realToFrac timestamp)
		fromfile <- readishTime <$> readFile f
		return $ if matchingtimestamp fromfile fromstatus
			then Just timestamp
			else Nothing
  where
	readishTime :: String -> Maybe POSIXTime
	readishTime s = utcTimeToPOSIXSeconds <$>
		parseTime defaultTimeLocale "%s%Qs" s
	matchingtimestamp fromfile fromstatus =
#ifndef mingw32_HOST_OS
		fromfile == fromstatus
#else
		fromfile >= fromstatus
#endif


code:
{- git-annex fuzz generator
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.FuzzTest where

import Common.Annex
import qualified Annex
import Command
import qualified Git.Config
import Config
import Utility.ThreadScheduler
import Annex.Exception
import Utility.DiskFree

import Data.Time.Clock
import System.Random (getStdRandom, random, randomR)
import Test.QuickCheck
import Control.Concurrent

def :: [Command]
def = [ notBareRepo $ command "fuzztest" paramNothing seek SectionTesting
	"generates fuzz test files"]

seek :: CommandSeek
seek = withNothing start

start :: CommandStart
start = do
	guardTest
	logf <- fromRepo gitAnnexFuzzTestLogFile
	showStart "fuzztest" logf
	logh <-liftIO $ openFile logf WriteMode
	void $ forever $ fuzz logh
	stop

guardTest :: Annex ()
guardTest = unlessM (fromMaybe False . Git.Config.isTrue <$> getConfig key "") $
	error $ unlines
		[ "Running fuzz tests *writes* to and *deletes* files in"
		, "this repository, and pushes those changes to other"
		, "repositories! This is a developer tool, not something"
		, "to play with."
		, ""
		, "Refusing to run fuzz tests, since " ++ keyname ++ " is not set!"
		]
  where
  	key = annexConfig "eat-my-repository"
	(ConfigKey keyname) = key

fuzz :: Handle -> Annex ()
fuzz logh = do
	action <- genFuzzAction
	record logh $ flip Started action
	result <- tryAnnex $ runFuzzAction action
	record logh $ flip Finished $
		either (const False) (const True) result

record :: Handle -> (UTCTime -> TimeStampedFuzzAction) -> Annex ()
record h tmpl = liftIO $ do
	now <- getCurrentTime
	let s = show $ tmpl now
	print s
	hPrint h s
	hFlush h

{- Delay for either a fraction of a second, or a few seconds, or up
 - to 1 minute.
 -
 - The MinutesDelay is used as an opportunity to do housekeeping tasks.
 -}
randomDelay :: Delay -> Annex ()
randomDelay TinyDelay = liftIO $
	threadDelay =<< getStdRandom (randomR (10000, 1000000))
randomDelay SecondsDelay = liftIO $
	threadDelaySeconds =<< Seconds <$> getStdRandom (randomR (1, 10))
randomDelay MinutesDelay = do
	liftIO $ threadDelaySeconds =<< Seconds <$> getStdRandom (randomR (1, 60))
	reserve <- annexDiskReserve <$> Annex.getGitConfig
	free <- liftIO $ getDiskFree "."
	case free of
		Just have | have < reserve -> do
			warning "Low disk space; fuzz test paused."
			liftIO $ threadDelaySeconds (Seconds 60)
			randomDelay MinutesDelay
		_  -> noop

data Delay
	= TinyDelay
	| SecondsDelay
	| MinutesDelay
	deriving (Read, Show, Eq)

instance Arbitrary Delay where
	arbitrary = elements [TinyDelay, SecondsDelay, MinutesDelay]

data FuzzFile = FuzzFile FilePath
	deriving (Read, Show, Eq)

data FuzzDir = FuzzDir FilePath
	deriving (Read, Show, Eq)

instance Arbitrary FuzzFile where
	arbitrary = FuzzFile <$> arbitrary

instance Arbitrary FuzzDir where
	arbitrary = FuzzDir <$> arbitrary

class ToFilePath a where
	toFilePath :: a -> FilePath

instance ToFilePath FuzzFile where
	toFilePath (FuzzFile f) = f

instance ToFilePath FuzzDir where
	toFilePath (FuzzDir d) = d

isFuzzFile :: FilePath -> Bool
isFuzzFile f = "fuzzfile_" `isPrefixOf` takeFileName f

isFuzzDir :: FilePath -> Bool
isFuzzDir d = "fuzzdir_" `isPrefixOf` d

mkFuzzFile :: FilePath -> [FuzzDir] -> FuzzFile
mkFuzzFile file dirs = FuzzFile $ joinPath (map toFilePath dirs) </> ("fuzzfile_" ++ file)

mkFuzzDir :: Int -> FuzzDir
mkFuzzDir n = FuzzDir $ "fuzzdir_" ++ show n

{- File is placed inside a directory hierarchy up to 4 subdirectories deep. -}
genFuzzFile :: IO FuzzFile
genFuzzFile = do
	n <- getStdRandom $ randomR (0, 4)
	dirs <- replicateM n genFuzzDir
	file <- show <$> (getStdRandom random :: IO Int)
	return $ mkFuzzFile file dirs

{- Only 16 distinct subdirectories are used. When nested 4 deep, this
 - yields 69904 total directories max, which is below the default Linux
 - inotify limit of 81920. The goal is not to run the assistant out of
 - inotify descriptors. -}
genFuzzDir :: IO FuzzDir
genFuzzDir = mkFuzzDir <$> (getStdRandom (randomR (1,16)) :: IO Int)

data TimeStampedFuzzAction
	= Started UTCTime FuzzAction
	| Finished UTCTime Bool
	deriving (Read, Show)

data FuzzAction
	= FuzzAdd FuzzFile
	| FuzzDelete FuzzFile
	| FuzzMove FuzzFile FuzzFile
	| FuzzModify FuzzFile
	| FuzzDeleteDir FuzzDir
	| FuzzMoveDir FuzzDir FuzzDir
	| FuzzPause Delay
	deriving (Read, Show, Eq)

instance Arbitrary FuzzAction where
	arbitrary = frequency
		[ (50, FuzzAdd <$> arbitrary)
		, (50, FuzzDelete <$> arbitrary)
		, (10, FuzzMove <$> arbitrary <*> arbitrary)
		, (10, FuzzModify <$> arbitrary)
		, (10, FuzzDeleteDir <$> arbitrary)
		, (10, FuzzMoveDir <$> arbitrary <*> arbitrary)
		, (10, FuzzPause <$> arbitrary)
		]

runFuzzAction :: FuzzAction -> Annex ()
runFuzzAction (FuzzAdd (FuzzFile f)) = liftIO $ do
	createDirectoryIfMissing True $ parentDir f
	n <- getStdRandom random :: IO Int
	writeFile f $ show n ++ "\n"
runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ nukeFile f
runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $
	rename src dest
runFuzzAction (FuzzModify (FuzzFile f)) = whenM isDirect $ liftIO $ do
	n <- getStdRandom random :: IO Int
	appendFile f $ show n ++ "\n"
runFuzzAction (FuzzDeleteDir (FuzzDir d)) = liftIO $
	removeDirectoryRecursive d
runFuzzAction (FuzzMoveDir (FuzzDir src) (FuzzDir dest)) = liftIO $
	rename src dest
runFuzzAction (FuzzPause d) = randomDelay d

genFuzzAction :: Annex FuzzAction
genFuzzAction = do
	tmpl <- liftIO $ Prelude.head <$> sample' (arbitrary :: Gen FuzzAction)
	-- Fix up template action to make sense in the current repo tree.
	case tmpl of
		FuzzAdd _ -> do
			f <- liftIO newFile
			maybe genFuzzAction (return . FuzzAdd) f
		FuzzDelete _ -> do
			f <- liftIO $ existingFile 0 ""
			maybe genFuzzAction (return . FuzzDelete) f
		FuzzMove _ _ -> do
			src <- liftIO $ existingFile 0 ""
			dest <- liftIO newFile
			case (src, dest) of
				(Just s, Just d) -> return $ FuzzMove s d
				_ -> genFuzzAction
		FuzzMoveDir _ _ -> do
			md <- liftIO existingDir
			case md of
				Nothing -> genFuzzAction
				Just d -> do
					newd <- liftIO $ newDir (parentDir $ toFilePath d)
					maybe genFuzzAction (return . FuzzMoveDir d) newd
		FuzzDeleteDir _ -> do
			d <- liftIO existingDir
			maybe genFuzzAction (return . FuzzDeleteDir) d
		FuzzModify _ -> do
			f <- liftIO $ existingFile 0 ""
			maybe genFuzzAction (return . FuzzModify) f
		FuzzPause _ -> return tmpl

existingFile :: Int -> FilePath -> IO (Maybe FuzzFile)
existingFile 0 _ = return Nothing
existingFile n top = do
	dir <- existingDirIncludingTop
	contents <- catchDefaultIO [] (getDirectoryContents dir)
	let files = filter isFuzzFile contents
	if null files
		then do
			let dirs = filter isFuzzDir contents
			if null dirs
				then return Nothing
				else do
					i <- getStdRandom $ randomR (0, length dirs - 1)
					existingFile (n - 1) (top </> dirs !! i)
		else do
			i <- getStdRandom $ randomR (0, length files - 1)
			return $ Just $ FuzzFile $ top </> dir </> files !! i

existingDirIncludingTop :: IO FilePath
existingDirIncludingTop = do
	dirs <- filter isFuzzDir <$> getDirectoryContents "."
	if null dirs
		then return "."
		else do
			n <- getStdRandom $ randomR (0, length dirs)
			return $ ("." : dirs) !! n

existingDir :: IO (Maybe FuzzDir)
existingDir = do
	d <- existingDirIncludingTop
	return $ if isFuzzDir d
		then Just $ FuzzDir d
		else Nothing

newFile :: IO (Maybe FuzzFile)
newFile = go (100 :: Int)
  where
  	go 0 = return Nothing
	go n = do
		f <- genFuzzFile
		ifM (doesnotexist (toFilePath f))
			( return $ Just f
			, go (n - 1)
			)

newDir :: FilePath -> IO (Maybe FuzzDir)
newDir parent = go (100 :: Int)
  where
  	go 0 = return Nothing
	go n = do
		(FuzzDir d) <- genFuzzDir
		ifM (doesnotexist (parent </> d))
			( return $ Just $ FuzzDir d
			, go (n - 1)
			)

doesnotexist :: FilePath -> IO Bool
doesnotexist f = isNothing <$> catchMaybeIO (getSymbolicLinkStatus f)


code:
{- git-annex command
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.GCryptSetup where

import Common.Annex
import Command
import Annex.UUID
import qualified Remote.GCrypt
import qualified Git

def :: [Command]
def = [dontCheck repoExists $ noCommit $
	command "gcryptsetup" paramValue seek
		SectionPlumbing "sets up gcrypt repository"]

seek :: CommandSeek
seek = withStrings start

start :: String -> CommandStart
start gcryptid = next $ next $ do
	u <- getUUID
	when (u /= NoUUID) $
		error "gcryptsetup refusing to run; this repository already has a git-annex uuid!"

	g <- gitRepo
	gu <- Remote.GCrypt.getGCryptUUID True g
	let newgu = genUUIDInNameSpace gCryptNameSpace gcryptid
	if gu == Nothing || gu == Just newgu
		then if Git.repoIsLocalBare g
			then do
				void $ Remote.GCrypt.setupRepo gcryptid g
				return True
			else error "cannot use gcrypt in a non-bare repository"
		else error "gcryptsetup uuid mismatch"


code:
{- git-annex command
 -
 - Copyright 2010, 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.Get where

import Common.Annex
import Command
import qualified Remote
import Annex.Content
import Annex.Transfer
import Config.NumCopies
import Annex.Wanted
import qualified Command.Move

def :: [Command]
def = [withOptions getOptions $ command "get" paramPaths seek
	SectionCommon "make content of annexed files available"]

getOptions :: [Option]
getOptions = fromOption : keyOptions

seek :: CommandSeek
seek ps = do
	from <- getOptionField fromOption Remote.byNameWithUUID
	withKeyOptions
		(startKeys from)
		(withFilesInGit $ whenAnnexed $ start from)
		ps

start :: Maybe Remote -> FilePath -> Key -> CommandStart
start from file key = start' expensivecheck from key (Just file)
  where
	expensivecheck = checkAuto (numCopiesCheck file key (<) <||> wantGet False (Just key) (Just file))

startKeys :: Maybe Remote -> Key -> CommandStart
startKeys from key = start' (return True) from key Nothing

start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> CommandStart
start' expensivecheck from key afile = stopUnless (not <$> inAnnex key) $
	stopUnless expensivecheck $
		case from of
			Nothing -> go $ perform key afile
			Just src ->
				stopUnless (Command.Move.fromOk src key) $
					go $ Command.Move.fromPerform src False key afile
  where
  	go a = do
		showStart' "get" key afile
		next a

perform :: Key -> AssociatedFile -> CommandPerform
perform key afile = stopUnless (getViaTmp key $ getKeyFile key afile) $
	next $ return True -- no cleanup needed

{- Try to find a copy of the file in one of the remotes,
 - and copy it to here. -}
getKeyFile :: Key -> AssociatedFile -> FilePath -> Annex Bool
getKeyFile key afile dest = getKeyFile' key afile dest
	=<< Remote.keyPossibilities key

getKeyFile' :: Key -> AssociatedFile -> FilePath -> [Remote] -> Annex Bool
getKeyFile' key afile dest = dispatch
  where
	dispatch [] = do
		showNote "not available"
		showlocs
		return False
	dispatch remotes = notifyTransfer Download afile $ trycopy remotes remotes
	trycopy full [] _ = do
		Remote.showTriedRemotes full
		showlocs
		return False
	trycopy full (r:rs) witness =
		ifM (probablyPresent r)
			( docopy r witness <||> trycopy full rs witness
			, trycopy full rs witness
			)
	showlocs = Remote.showLocations key []
		"No other repository is known to contain the file."
	-- This check is to avoid an ugly message if a remote is a
	-- drive that is not mounted.
	probablyPresent r
		| Remote.hasKeyCheap r =
			either (const False) id <$> Remote.hasKey r key
		| otherwise = return True
	docopy r = download (Remote.uuid r) key afile noRetry $ \p -> do
		showAction $ "from " ++ Remote.name r
		Remote.retrieveKeyFile r key afile dest p


code:
{- git-annex command
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.Group where

import Common.Annex
import Command
import qualified Remote
import Logs.Group
import Types.Group

import qualified Data.Set as S

def :: [Command]
def = [command "group" (paramPair paramRemote paramDesc) seek
	SectionSetup "add a repository to a group"]

seek :: CommandSeek
seek = withWords start

start :: [String] -> CommandStart
start (name:g:[]) = do
	showStart "group" name
	u <- Remote.nameToUUID name
	next $ setGroup u g
start (name:[]) = do
	u <- Remote.nameToUUID name
	showRaw . unwords . S.toList =<< lookupGroups u
	stop
start _ = error "Specify a repository and a group."

setGroup :: UUID -> Group -> CommandPerform
setGroup uuid g = do
	groupChange uuid (S.insert g)
	next $ return True


code:
{- git-annex command
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.Help where

import Common.Annex
import Command
import qualified Command.Init
import qualified Command.Add
import qualified Command.Drop
import qualified Command.Get
import qualified Command.Move
import qualified Command.Copy
import qualified Command.Sync
import qualified Command.Whereis
import qualified Command.Fsck

import System.Console.GetOpt

def :: [Command]
def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $
	command "help" paramNothing seek SectionQuery "display help"]

seek :: CommandSeek
seek = withWords start

start :: [String] -> CommandStart
start params = do
	liftIO $ start' params
	stop

startNoRepo :: CmdParams -> IO ()
startNoRepo = start'

start' :: [String] -> IO ()
start' ["options"] = showCommonOptions
start' _ = showGeneralHelp

showCommonOptions :: IO ()
showCommonOptions = putStrLn $ usageInfo "Common options:" gitAnnexOptions

showGeneralHelp :: IO ()
showGeneralHelp = putStrLn $ unlines
	[ "The most frequently used git-annex commands are:"
	, unlines $ map cmdline $ concat
		[ Command.Init.def
		, Command.Add.def
		, Command.Drop.def
		, Command.Get.def
		, Command.Move.def
		, Command.Copy.def
		, Command.Sync.def
		, Command.Whereis.def
		, Command.Fsck.def
		]
	, "Run 'git-annex' for a complete command list."
	, "Run 'git-annex command --help' for help on a specific command."
	, "Run `git annex help options' for a list of common options."
	]
  where
	cmdline c = "\t" ++ cmdname c ++ "\t" ++ cmddesc c


code:
{- git-annex command
 -
 - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.Import where

import Common.Annex
import Command
import qualified Annex
import qualified Command.Add
import Utility.CopyFile
import Backend
import Remote
import Types.KeySource

def :: [Command]
def = [withOptions opts $ notBareRepo $ command "import" paramPaths seek
	SectionCommon "move and add files from outside git working copy"]

opts :: [Option]
opts =
	[ duplicateOption
	, deduplicateOption
	, cleanDuplicatesOption
	, skipDuplicatesOption
	]

duplicateOption :: Option
duplicateOption = flagOption [] "duplicate" "do not delete source files"

deduplicateOption :: Option
deduplicateOption = flagOption [] "deduplicate" "delete source files whose content was imported before"

cleanDuplicatesOption :: Option
cleanDuplicatesOption = flagOption [] "clean-duplicates" "delete duplicate source files (import nothing)"

skipDuplicatesOption :: Option
skipDuplicatesOption = flagOption [] "skip-duplicates" "import only new files"

data DuplicateMode = Default | Duplicate | DeDuplicate | CleanDuplicates | SkipDuplicates
	deriving (Eq)

getDuplicateMode :: Annex DuplicateMode
getDuplicateMode = gen
	<$> getflag duplicateOption
	<*> getflag deduplicateOption
	<*> getflag cleanDuplicatesOption
	<*> getflag skipDuplicatesOption
  where
  	getflag = Annex.getFlag . optionName
  	gen False False False False = Default
	gen True False False False = Duplicate
	gen False True False False = DeDuplicate
	gen False False True False = CleanDuplicates
	gen False False False True = SkipDuplicates
	gen _ _ _ _ = error "bad combination of --duplicate, --deduplicate, --clean-duplicates, --skip-duplicates"

seek :: CommandSeek
seek ps = do
	mode <- getDuplicateMode
	withPathContents (start mode) ps

start :: DuplicateMode -> (FilePath, FilePath) -> CommandStart
start mode (srcfile, destfile) =
	ifM (liftIO $ isRegularFile <$> getSymbolicLinkStatus srcfile)
		( do
			isdup <- do
				backend <- chooseBackend destfile
				let ks = KeySource srcfile srcfile Nothing
				v <- genKey ks backend
				case v of
					Just (k, _) -> not . null <$> keyLocations k
					_ -> return False
			case pickaction isdup of
				Nothing -> stop
				Just a -> do
					showStart "import" destfile
					next a
		, stop
		)
  where
	deletedup = do
		showNote "duplicate"
		liftIO $ removeFile srcfile
		next $ return True
	importfile = do
		handleexisting =<< liftIO (catchMaybeIO $ getSymbolicLinkStatus destfile)
		liftIO $ createDirectoryIfMissing True (parentDir destfile)
		liftIO $ if mode == Duplicate || mode == SkipDuplicates
			then void $ copyFileExternal srcfile destfile
			else moveFile srcfile destfile
		Command.Add.perform destfile
	handleexisting Nothing = noop
	handleexisting (Just s)
		| isDirectory s = notoverwriting "(is a directory)"
		| otherwise = ifM (Annex.getState Annex.force) $
			( liftIO $ nukeFile destfile
			, notoverwriting "(use --force to override)"
			)
	notoverwriting why = error $ "not overwriting existing " ++ destfile ++ " " ++ why
	pickaction isdup = case mode of
		DeDuplicate
			| isdup -> Just deletedup
			| otherwise -> Just importfile
		CleanDuplicates
			| isdup -> Just deletedup
			| otherwise -> Nothing
		SkipDuplicates
			| isdup -> Nothing
			| otherwise -> Just importfile
		_ -> Just importfile


code:
{- git-annex command
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Command.ImportFeed where

import Text.Feed.Import
import Text.Feed.Query
import Text.Feed.Types
import qualified Data.Set as S
import qualified Data.Map as M
import Data.Time.Clock
import Data.Time.Format
import System.Locale

import Common.Annex
import qualified Annex
import Command
import qualified Annex.Url as Url
import Logs.Web
import qualified Utility.Format
import Utility.Tmp
import Command.AddUrl (addUrlFile, relaxedOption)
import Annex.Perms
import Backend.URL (fromUrl)
#ifdef WITH_QUVI
import Annex.Quvi
import qualified Utility.Quvi as Quvi
import Command.AddUrl (addUrlFileQuvi)
#endif
import Types.MetaData
import Logs.MetaData
import Annex.MetaData

def :: [Command]
def = [notBareRepo $ withOptions [templateOption, relaxedOption] $
	command "importfeed" (paramRepeating paramUrl) seek
		SectionCommon "import files from podcast feeds"]

templateOption :: Option
templateOption = fieldOption [] "template" paramFormat "template for filenames"

seek :: CommandSeek
seek ps = do
	tmpl <- getOptionField templateOption return
	relaxed <- getOptionFlag relaxedOption
	cache <- getCache tmpl
	withStrings (start relaxed cache) ps

start :: Bool -> Cache -> URLString -> CommandStart
start relaxed cache url = do
	showStart "importfeed" url
	next $ perform relaxed cache url

perform :: Bool -> Cache -> URLString -> CommandPerform
perform relaxed cache url = do
	v <- findDownloads url
	case v of
		[] -> do
			feedProblem url "bad feed content"
			next $ return True
		l -> do
			ok <- and <$> mapM (performDownload relaxed cache) l
			unless ok $
				feedProblem url "problem downloading item"
			next $ cleanup url True

cleanup :: URLString -> Bool -> CommandCleanup
cleanup url ok = do
	when ok $
		clearFeedProblem url
	return ok

data ToDownload = ToDownload
	{ feed :: Feed
	, feedurl :: URLString
	, item :: Item
	, location :: DownloadLocation
	}

data DownloadLocation = Enclosure URLString | QuviLink URLString

data Cache = Cache
	{ knownurls :: S.Set URLString
	, template :: Utility.Format.Format
	}

getCache :: Maybe String -> Annex Cache
getCache opttemplate = ifM (Annex.getState Annex.force)
	( ret S.empty
	, do
		showSideAction "checking known urls"
		ret =<< S.fromList <$> knownUrls
	)
  where
	tmpl = Utility.Format.gen $ fromMaybe defaultTemplate opttemplate
	ret s = return $ Cache s tmpl

findDownloads :: URLString -> Annex [ToDownload]
findDownloads u = go =<< downloadFeed u
  where
	go Nothing = pure []
	go (Just f) = catMaybes <$> mapM (mk f) (feedItems f)

	mk f i = case getItemEnclosure i of
		Just (enclosureurl, _, _) -> return $
			Just $ ToDownload f u i $ Enclosure enclosureurl
		Nothing -> mkquvi f i
#ifdef WITH_QUVI
	mkquvi f i = case getItemLink i of
		Just link -> ifM (quviSupported link)
			( return $ Just $ ToDownload f u i $ QuviLink link
			, return Nothing
			)
		Nothing -> return Nothing
#else
	mkquvi = return Nothing
#endif

{- Feeds change, so a feed download cannot be resumed. -}
downloadFeed :: URLString -> Annex (Maybe Feed)
downloadFeed url = do
	showOutput
	uo <- Url.getUrlOptions
	liftIO $ withTmpFile "feed" $ \f h -> do
		fileEncoding h
		ifM (Url.download url f uo)
			( parseFeedString <$> hGetContentsStrict h
			, return Nothing
			)

performDownload :: Bool -> Cache -> ToDownload -> Annex Bool
performDownload relaxed cache todownload = case location todownload of
	Enclosure url -> checkknown url $
		rundownload url (takeExtension url) $
			addUrlFile relaxed url
	QuviLink pageurl -> do
		let quviurl = setDownloader pageurl QuviDownloader
		checkknown quviurl $ do
			mp <- withQuviOptions Quvi.query [Quvi.quiet, Quvi.httponly] pageurl
			case mp of
				Nothing -> return False
				Just page -> case headMaybe $ Quvi.pageLinks page of
					Nothing -> return False
					Just link -> do
						let videourl = Quvi.linkUrl link
						checkknown videourl $
							rundownload videourl ("." ++ Quvi.linkSuffix link) $
								addUrlFileQuvi relaxed quviurl videourl
  where
  	forced = Annex.getState Annex.force

	{- Avoids downloading any urls that are already known to be
	 - associated with a file in the annex, unless forced. -}
	checkknown url a
		| S.member url (knownurls cache) = ifM forced (a, return True)
		| otherwise = a

	rundownload url extension getter = do
		dest <- makeunique url (1 :: Integer) $
			feedFile (template cache) todownload extension
		case dest of
			Nothing -> return True
			Just f -> do
				showStart "addurl" f
				mk <- getter f
				case mk of
					Just key -> do
						whenM (annexGenMetaData <$> Annex.getGitConfig) $
							addMetaData key $ extractMetaData todownload
						showEndOk
						return True
					Nothing -> do
						showEndFail
						checkFeedBroken (feedurl todownload)

	{- Find a unique filename to save the url to.
	 - If the file exists, prefixes it with a number.
	 - When forced, the file may already exist and have the same
	 - url, in which case Nothing is returned as it does not need
	 - to be re-downloaded. -}
	makeunique url n file = ifM alreadyexists
		( ifM forced
			( ifAnnexed f checksameurl tryanother
			, tryanother
			)
		, return $ Just f
		)
	  where
	  	f = if n < 2
			then file
			else
				let (d, base) = splitFileName file
				in d </> show n ++ "_" ++ base
		tryanother = makeunique url (n + 1) file
		alreadyexists = liftIO $ isJust <$> catchMaybeIO (getSymbolicLinkStatus f)
		checksameurl k = ifM (elem url <$> getUrls k)
			( return Nothing
			, tryanother
			)

defaultTemplate :: String
defaultTemplate = "${feedtitle}/${itemtitle}${extension}"

{- Generates a filename to use for a feed item by filling out the template.
 - The filename may not be unique. -}
feedFile :: Utility.Format.Format -> ToDownload -> String -> FilePath
feedFile tmpl i extension = Utility.Format.format tmpl $
	M.map sanitizeFilePath $ M.fromList $ extractFields i ++
		[ ("extension", extension)
		, extractField "itempubdate" [pubdate $ item i]
		]
  where
#if MIN_VERSION_feed(0,3,9)
	pubdate itm = case getItemPublishDate itm :: Maybe (Maybe UTCTime) of
		Just (Just d) -> Just $
			formatTime defaultTimeLocale "%F" d
		-- if date cannot be parsed, use the raw string
		_ -> replace "/" "-" <$> getItemPublishDateString itm
#else
	pubdate _ = Nothing
#endif

extractMetaData :: ToDownload -> MetaData
#if MIN_VERSION_feed(0,3,9)
extractMetaData i = case getItemPublishDate (item i) :: Maybe (Maybe UTCTime) of
	Just (Just d) -> unionMetaData meta (dateMetaData d meta)
	_ -> meta
#else
extractMetaData i = meta
#endif
  where
	tometa (k, v) = (mkMetaFieldUnchecked k, S.singleton (toMetaValue v))
	meta = MetaData $ M.fromList $ map tometa $ extractFields i

{- Extract fields from the feed and item, that are both used as metadata,
 - and to generate the filename. -}
extractFields :: ToDownload -> [(String, String)]
extractFields i = map (uncurry extractField)
	[ ("feedtitle", [feedtitle])
	, ("itemtitle", [itemtitle])
	, ("feedauthor", [feedauthor])
	, ("itemauthor", [itemauthor])
	, ("itemsummary", [getItemSummary $ item i])
	, ("itemdescription", [getItemDescription $ item i])
	, ("itemrights", [getItemRights $ item i])
	, ("itemid", [snd <$> getItemId (item i)])
	, ("title", [itemtitle, feedtitle])
	, ("author", [itemauthor, feedauthor])
	]
  where
	feedtitle = Just $ getFeedTitle $ feed i
	itemtitle = getItemTitle $ item i
	feedauthor = getFeedAuthor $ feed i
	itemauthor = getItemAuthor $ item i

extractField :: String -> [Maybe String] -> (String, String)
extractField k [] = (k, "none")
extractField k (Just v:_)
	| not (null v) = (k, v)
extractField k (_:rest) = extractField k rest

{- Called when there is a problem with a feed.
 - Throws an error if the feed is broken, otherwise shows a warning. -}
feedProblem :: URLString -> String -> Annex ()
feedProblem url message = ifM (checkFeedBroken url)
	( error $ message ++ " (having repeated problems with feed: " ++ url ++ ")"
	, warning $ "warning: " ++ message
	)

{- A feed is only broken if problems have occurred repeatedly, for at
 - least 23 hours. -}
checkFeedBroken :: URLString -> Annex Bool
checkFeedBroken url = checkFeedBroken' url =<< feedState url
checkFeedBroken' :: URLString -> FilePath -> Annex Bool
checkFeedBroken' url f = do
	prev <- maybe Nothing readish <$> liftIO (catchMaybeIO $ readFile f)
	now <- liftIO getCurrentTime
	case prev of
		Nothing -> do
			createAnnexDirectory (parentDir f)
			liftIO $ writeFile f $ show now
			return False
		Just prevtime -> do
			let broken = diffUTCTime now prevtime > 60 * 60 * 23
			when broken $
				-- Avoid repeatedly complaining about
				-- broken feed.
				clearFeedProblem url
			return broken

clearFeedProblem :: URLString -> Annex ()
clearFeedProblem url = void $ liftIO . tryIO . removeFile =<< feedState url

feedState :: URLString -> Annex FilePath
feedState url = fromRepo . gitAnnexFeedState =<< fromUrl url Nothing


code:
{- git-annex command
 -
 - Copyright 2010 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.InAnnex where

import Common.Annex
import Command
import Annex.Content

def :: [Command]
def = [noCommit $ command "inannex" (paramRepeating paramKey) seek
	SectionPlumbing "checks if keys are present in the annex"]

seek :: CommandSeek
seek = withKeys start

start :: Key -> CommandStart
start key = inAnnexSafe key >>= dispatch
  where
	dispatch (Just True) = stop
	dispatch (Just False) = exit 1
	dispatch Nothing = exit 100
	exit n = liftIO $ exitWith $ ExitFailure n


code:
{- git-annex command
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.Indirect where

import Control.Exception.Extensible

import Common.Annex
import Command
import qualified Git
import qualified Git.Branch
import qualified Git.LsFiles
import Git.FileMode
import Config
import qualified Annex
import Annex.Direct
import Annex.Content
import Annex.Content.Direct
import Annex.CatFile
import Annex.Exception
import Annex.Init
import qualified Command.Add

def :: [Command]
def = [notBareRepo $ noDaemonRunning $
	command "indirect" paramNothing seek
		SectionSetup "switch repository to indirect mode"]

seek :: CommandSeek
seek = withNothing start

start :: CommandStart
start = ifM isDirect
	( do
		unlessM (coreSymlinks <$> Annex.getGitConfig) $
			error "Git is configured to not use symlinks, so you must use direct mode."
		whenM probeCrippledFileSystem $
			error "This repository seems to be on a crippled filesystem, you must use direct mode."
		next perform
	, stop
	)

perform :: CommandPerform
perform = do
	showStart "commit" ""
	whenM stageDirect $ do
		showOutput
		void $ inRepo $ Git.Branch.commitCommand Git.Branch.ManualCommit
			[ Param "-m"
			, Param "commit before switching to indirect mode"
			]
	showEndOk

	-- Note that we set indirect mode early, so that we can use
	-- moveAnnex in indirect mode.
	setDirect False

	top <- fromRepo Git.repoPath
	(l, clean) <- inRepo $ Git.LsFiles.stagedOthersDetails [top]
	forM_ l go
	void $ liftIO clean
	next cleanup
  where
	{- Walk tree from top and move all present direct mode files into
	 - the annex, replacing with symlinks. Also delete direct mode
	 - caches and mappings. -}
	go (f, Just sha, Just mode) | isSymLink mode = do
		r <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus f
		case r of
			Just s
				| isSymbolicLink s -> void $ flip whenAnnexed f $
					\_ k -> do
						removeInodeCache k
						removeAssociatedFiles k
						return Nothing
				| otherwise ->
					maybe noop (fromdirect f)
						=<< catKey sha mode
			_ -> noop
	go _ = noop

	fromdirect f k = do
		showStart "indirect" f
		removeInodeCache k
		removeAssociatedFiles k
		whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do
			v <-tryAnnexIO (moveAnnex k f)
			case v of
				Right _ -> do
					l <- inRepo $ gitAnnexLink f k
					liftIO $ createSymbolicLink l f
				Left e -> catchAnnex (Command.Add.undo f k e)
					warnlocked
		showEndOk

 	warnlocked :: SomeException -> Annex ()
	warnlocked e = do
		warning $ show e
		warning "leaving this file as-is; correct this problem and run git annex add on it"

cleanup :: CommandCleanup
cleanup = do
	showStart "indirect" ""
	showEndOk
	return True