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

{-# LANGUAGE BangPatterns #-}

module Command.Info where

import "mtl" Control.Monad.State.Strict
import qualified Data.Map as M
import Text.JSON
import Data.Tuple
import Data.Ord

import Common.Annex
import qualified Remote
import qualified Command.Unused
import qualified Git
import qualified Annex
import Command
import Utility.DataUnits
import Utility.DiskFree
import Annex.Content
import Types.Key
import Logs.UUID
import Logs.Trust
import Config.NumCopies
import Remote
import Config
import Utility.Percentage
import Logs.Transfer
import Types.TrustLevel
import Types.FileMatcher
import qualified Limit

-- a named computation that produces a statistic
type Stat = StatState (Maybe (String, StatState String))

-- data about a set of keys
data KeyData = KeyData
	{ countKeys :: Integer
	, sizeKeys :: Integer
	, unknownSizeKeys :: Integer
	, backendsKeys :: M.Map String Integer
	}

data NumCopiesStats = NumCopiesStats
	{ numCopiesVarianceMap :: M.Map Variance Integer
	}

newtype Variance = Variance Int
	deriving (Eq, Ord)

instance Show Variance where
	show (Variance n)
		| n >= 0 = "numcopies +" ++ show n
		| otherwise = "numcopies " ++ show n

-- cached info that multiple Stats use
data StatInfo = StatInfo
	{ presentData :: Maybe KeyData
	, referencedData :: Maybe KeyData
	, numCopiesStats :: Maybe NumCopiesStats
	}

-- a state monad for running Stats in
type StatState = StateT StatInfo Annex

def :: [Command]
def = [noCommit $ dontCheck repoExists $ withOptions [jsonOption] $
	command "info" paramPaths seek SectionQuery
	"shows general information about the annex"]

seek :: CommandSeek
seek = withWords start

start :: [FilePath] -> CommandStart
start [] = do
	globalInfo
	stop
start ps = do
	mapM_ localInfo =<< filterM isdir ps
	stop
  where
	isdir = liftIO . catchBoolIO . (isDirectory <$$> getFileStatus)

globalInfo :: Annex ()
globalInfo = do
	stats <- selStats global_fast_stats global_slow_stats
	showCustom "info" $ do
		evalStateT (mapM_ showStat stats) (StatInfo Nothing Nothing Nothing)
		return True

localInfo :: FilePath -> Annex ()
localInfo dir = showCustom (unwords ["info", dir]) $ do
	stats <- selStats (tostats local_fast_stats) (tostats local_slow_stats)
	evalStateT (mapM_ showStat stats) =<< getLocalStatInfo dir
	return True
  where
  	tostats = map (\s -> s dir)

selStats :: [Stat] -> [Stat] -> Annex [Stat]
selStats fast_stats slow_stats = do
	fast <- Annex.getState Annex.fast
	return $ if fast
		then fast_stats
		else fast_stats ++ slow_stats

{- Order is significant. Less expensive operations, and operations
 - that share data go together.
 -}
global_fast_stats :: [Stat]
global_fast_stats =
	[ repository_mode
	, remote_list Trusted
	, remote_list SemiTrusted
	, remote_list UnTrusted
	, transfer_list
	, disk_size
	]
global_slow_stats :: [Stat]
global_slow_stats =
	[ tmp_size
	, bad_data_size
	, local_annex_keys
	, local_annex_size
	, known_annex_files
	, known_annex_size
	, bloom_info
	, backend_usage
	]
local_fast_stats :: [FilePath -> Stat]
local_fast_stats =
	[ local_dir
	, const local_annex_keys
	, const local_annex_size
	, const known_annex_files
	, const known_annex_size
	]
local_slow_stats :: [FilePath -> Stat]
local_slow_stats =
	[ const numcopies_stats
	]

stat :: String -> (String -> StatState String) -> Stat
stat desc a = return $ Just (desc, a desc)

nostat :: Stat
nostat = return Nothing

json :: JSON j => (j -> String) -> StatState j -> String -> StatState String
json serialize a desc = do
	j <- a
	lift $ maybeShowJSON [(desc, j)]
	return $ serialize j

nojson :: StatState String -> String -> StatState String
nojson a _ = a

showStat :: Stat -> StatState ()
showStat s = maybe noop calc =<< s
  where
	calc (desc, a) = do
		(lift . showHeader) desc
		lift . showRaw =<< a

repository_mode :: Stat
repository_mode = stat "repository mode" $ json id $ lift $
	ifM isDirect
		( return "direct", return "indirect" )

remote_list :: TrustLevel -> Stat
remote_list level = stat n $ nojson $ lift $ do
	us <- M.keys <$> (M.union <$> uuidMap <*> remoteMap Remote.name)
	rs <- fst <$> trustPartition level us
	s <- prettyPrintUUIDs n rs
	return $ if null s then "0" else show (length rs) ++ "\n" ++ beginning s
  where
	n = showTrustLevel level ++ " repositories"

local_dir :: FilePath -> Stat
local_dir dir = stat "directory" $ json id $ return dir

local_annex_keys :: Stat
local_annex_keys = stat "local annex keys" $ json show $
	countKeys <$> cachedPresentData

local_annex_size :: Stat
local_annex_size = stat "local annex size" $ json id $
	showSizeKeys <$> cachedPresentData

known_annex_files :: Stat
known_annex_files = stat "annexed files in working tree" $ json show $
	countKeys <$> cachedReferencedData

known_annex_size :: Stat
known_annex_size = stat "size of annexed files in working tree" $ json id $
	showSizeKeys <$> cachedReferencedData

tmp_size :: Stat
tmp_size = staleSize "temporary object directory size" gitAnnexTmpObjectDir

bad_data_size :: Stat
bad_data_size = staleSize "bad keys size" gitAnnexBadDir

bloom_info :: Stat
bloom_info = stat "bloom filter size" $ json id $ do
	localkeys <- countKeys <$> cachedPresentData
	capacity <- fromIntegral <$> lift Command.Unused.bloomCapacity
	let note = aside $
		if localkeys >= capacity
		then "appears too small for this repository; adjust annex.bloomcapacity"
		else showPercentage 1 (percentage capacity localkeys) ++ " full"

	-- Two bloom filters are used at the same time, so double the size
	-- of one.
	size <- roughSize memoryUnits False . (* 2) . fromIntegral . fst <$>
		lift Command.Unused.bloomBitsHashes

	return $ size ++ note

transfer_list :: Stat
transfer_list = stat "transfers in progress" $ nojson $ lift $ do
	uuidmap <- Remote.remoteMap id
	ts <- getTransfers
	return $ if null ts
		then "none"
		else multiLine $
			map (uncurry $ line uuidmap) $ sort ts
  where
	line uuidmap t i = unwords
		[ showLcDirection (transferDirection t) ++ "ing"
		, fromMaybe (key2file $ transferKey t) (associatedFile i)
		, if transferDirection t == Upload then "to" else "from"
		, maybe (fromUUID $ transferUUID t) Remote.name $
			M.lookup (transferUUID t) uuidmap
		]

disk_size :: Stat
disk_size = stat "available local disk space" $ json id $ lift $
	calcfree
		<$> (annexDiskReserve <$> Annex.getGitConfig)
		<*> inRepo (getDiskFree . gitAnnexDir)
  where
	calcfree reserve (Just have) = unwords
		[ roughSize storageUnits False $ nonneg $ have - reserve
		, "(+" ++ roughSize storageUnits False reserve
		, "reserved)"
		]
	calcfree _ _ = "unknown"

	nonneg x
		| x >= 0 = x
		| otherwise = 0

backend_usage :: Stat
backend_usage = stat "backend usage" $ nojson $
	calc
		<$> (backendsKeys <$> cachedReferencedData)
		<*> (backendsKeys <$> cachedPresentData)
  where
	calc x y = multiLine $
		map (\(n, b) -> b ++ ": " ++ show n) $
		reverse $ sort $ map swap $ M.toList $
		M.unionWith (+) x y

numcopies_stats :: Stat
numcopies_stats = stat "numcopies stats" $ nojson $
	calc <$> (maybe M.empty numCopiesVarianceMap <$> cachedNumCopiesStats)
  where
	calc = multiLine
		. map (\(variance, count) -> show variance ++ ": " ++ show count)
		. reverse . sortBy (comparing snd) . M.toList

cachedPresentData :: StatState KeyData
cachedPresentData = do
	s <- get
	case presentData s of
		Just v -> return v
		Nothing -> do
			v <- foldKeys <$> lift (getKeysPresent InRepository)
			put s { presentData = Just v }
			return v

cachedReferencedData :: StatState KeyData
cachedReferencedData = do
	s <- get
	case referencedData s of
		Just v -> return v
		Nothing -> do
			!v <- lift $ Command.Unused.withKeysReferenced
				emptyKeyData addKey
			put s { referencedData = Just v }
			return v

-- currently only available for local info
cachedNumCopiesStats :: StatState (Maybe NumCopiesStats)
cachedNumCopiesStats = numCopiesStats <$> get

getLocalStatInfo :: FilePath -> Annex StatInfo
getLocalStatInfo dir = do
	fast <- Annex.getState Annex.fast
	matcher <- Limit.getMatcher
	(presentdata, referenceddata, numcopiesstats) <-
		Command.Unused.withKeysFilesReferencedIn dir initial
			(update matcher fast)
	return $ StatInfo (Just presentdata) (Just referenceddata) (Just numcopiesstats)
  where
	initial = (emptyKeyData, emptyKeyData, emptyNumCopiesStats)
	update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats) =
		ifM (matcher $ MatchingFile $ FileInfo file file)
			( do
				!presentdata' <- ifM (inAnnex key)
					( return $ addKey key presentdata
					, return presentdata
					)
				let !referenceddata' = addKey key referenceddata
				!numcopiesstats' <- if fast
					then return numcopiesstats
					else updateNumCopiesStats key file numcopiesstats
				return $! (presentdata', referenceddata', numcopiesstats')
			, return vs
			)

emptyKeyData :: KeyData
emptyKeyData = KeyData 0 0 0 M.empty

emptyNumCopiesStats :: NumCopiesStats
emptyNumCopiesStats = NumCopiesStats M.empty

foldKeys :: [Key] -> KeyData
foldKeys = foldl' (flip addKey) emptyKeyData

addKey :: Key -> KeyData -> KeyData
addKey key (KeyData count size unknownsize backends) =
	KeyData count' size' unknownsize' backends'
  where
	{- All calculations strict to avoid thunks when repeatedly
	 - applied to many keys. -}
	!count' = count + 1
	!backends' = M.insertWith' (+) (keyBackendName key) 1 backends
	!size' = maybe size (+ size) ks
	!unknownsize' = maybe (unknownsize + 1) (const unknownsize) ks
	ks = keySize key

updateNumCopiesStats :: Key -> FilePath -> NumCopiesStats -> Annex NumCopiesStats
updateNumCopiesStats key file (NumCopiesStats m) = do
	!variance <- Variance <$> numCopiesCheck file key (-)
	let !m' = M.insertWith' (+) variance 1 m
	let !ret = NumCopiesStats m'
	return ret

showSizeKeys :: KeyData -> String
showSizeKeys d = total ++ missingnote
  where
	total = roughSize storageUnits False $ sizeKeys d
	missingnote
		| unknownSizeKeys d == 0 = ""
		| otherwise = aside $
			"+ " ++ show (unknownSizeKeys d) ++
			" unknown size"

staleSize :: String -> (Git.Repo -> FilePath) -> Stat
staleSize label dirspec = go =<< lift (dirKeys dirspec)
  where
	go [] = nostat
	go keys = onsize =<< sum <$> keysizes keys
	onsize 0 = nostat
	onsize size = stat label $
		json (++ aside "clean up with git-annex unused") $
			return $ roughSize storageUnits False size
	keysizes keys = do
		dir <- lift $ fromRepo dirspec
		liftIO $ forM keys $ \k -> catchDefaultIO 0 $
			fromIntegral . fileSize
				<$> getFileStatus (dir </> keyFile k)

aside :: String -> String
aside s = " (" ++ s ++ ")"

multiLine :: [String] -> String
multiLine = concatMap (\l -> "\n\t" ++ l)


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

module Command.Init where

import Common.Annex
import Command
import Annex.Init

def :: [Command]
def = [dontCheck repoExists $
	command "init" paramDesc seek SectionSetup "initialize git-annex"]

seek :: CommandSeek
seek = withWords start

start :: [String] -> CommandStart
start ws = do
	showStart "init" description
	next $ perform description
  where
	description = unwords ws

perform :: String -> CommandPerform
perform description = do
	initialize $ if null description then Nothing else Just description
	next $ return True

repo_name: kakafarm/git

license: unknown


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

module Command.InitRemote where

import qualified Data.Map as M

import Common.Annex
import Command
import qualified Remote
import qualified Logs.Remote
import qualified Types.Remote as R
import Logs.UUID
import Logs.Trust

import Data.Ord

def :: [Command]
def = [command "initremote"
	(paramPair paramName $ paramOptional $ paramRepeating paramKeyValue)
	seek SectionSetup "creates a special (non-git) remote"]

seek :: CommandSeek
seek = withWords start

start :: [String] -> CommandStart
start [] = error "Specify a name for the remote."
start (name:ws) = ifM (isJust <$> findExisting name)
	( error $ "There is already a special remote named \"" ++ name ++
		"\". (Use enableremote to enable an existing special remote.)"
	, do
		let c = newConfig name
		t <- findType config

		showStart "initremote" name
		next $ perform t name $ M.union config c
	)
  where
	config = Logs.Remote.keyValToConfig ws

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

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

{- See if there's an existing special remote with this name. -}
findExisting :: String -> Annex (Maybe (UUID, R.RemoteConfig))
findExisting name = do
	t <- trustMap
	matches <- sortBy (comparing $ \(u, _c) -> M.lookup u t )
		. findByName name
		<$> Logs.Remote.readRemoteLog
	return $ headMaybe matches

newConfig :: String -> R.RemoteConfig
newConfig name = M.singleton nameKey name

findByName :: String ->  M.Map UUID R.RemoteConfig -> [(UUID, R.RemoteConfig)]
findByName n = filter (matching . snd) . M.toList
  where
	matching c = case M.lookup nameKey c of
		Nothing -> False
		Just n'
			| n' == n -> True
			| otherwise -> False

remoteNames :: Annex [String]
remoteNames = do
	m <- Logs.Remote.readRemoteLog
	return $ mapMaybe (M.lookup nameKey . snd) $ M.toList m

{- find the specified remote type -}
findType :: R.RemoteConfig -> Annex RemoteType
findType config = maybe unspecified specified $ M.lookup typeKey config
  where
	unspecified = error "Specify the type of remote with type="
	specified s = case filter (findtype s) Remote.remoteTypes of
		[] -> error $ "Unknown remote type " ++ s
		(t:_) -> return t
	findtype s i = R.typename i == s

{- The name of a configured remote is stored in its config using this key. -}
nameKey :: String
nameKey = "name"

{- The type of a remote is stored in its config using this key. -}
typeKey :: String
typeKey = "type"


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

module Command.List where

import qualified Data.Set as S
import qualified Data.Map as M
import Data.Function
import Data.Tuple.Utils
import Data.Ord

import Common.Annex
import Command
import Remote
import Logs.Trust
import Logs.UUID
import Annex.UUID
import qualified Annex
import Git.Types (RemoteName)

def :: [Command]
def = [noCommit $ withOptions [allrepos] $ command "list" paramPaths seek
	SectionQuery "show which remotes contain files"]

allrepos :: Option
allrepos = flagOption [] "allrepos" "show all repositories, not only remotes"

seek :: CommandSeek
seek ps = do
	list <- getList
	printHeader list
	withFilesInGit (whenAnnexed $ start list) ps

getList :: Annex [(UUID, RemoteName, TrustLevel)]
getList = ifM (Annex.getFlag $ optionName allrepos)
	( nubBy ((==) `on` fst3) <$> ((++) <$> getRemotes <*> getAllUUIDs)
	, getRemotes
	)
  where
	getRemotes = do
		rs <- remoteList
		ts <- mapM (lookupTrust . uuid) rs
		hereu <- getUUID
		heretrust <- lookupTrust hereu
		return $ (hereu, "here", heretrust) : zip3 (map uuid rs) (map name rs) ts
	getAllUUIDs = do
		rs <- M.toList <$> uuidMap
		rs3 <- forM rs $ \(u, n) -> (,,)
			<$> pure u
			<*> pure n
			<*> lookupTrust u
		return $ sortBy (comparing snd3) $
			filter (\t -> thd3 t /= DeadTrusted) rs3

printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex ()
printHeader l = liftIO $ putStrLn $ header $ map (\(_, n, t) -> (n, t)) l

start :: [(UUID, RemoteName, TrustLevel)] -> FilePath -> Key -> CommandStart
start l file key = do
	ls <- S.fromList <$> keyLocations key
	liftIO $ putStrLn $ format (map (\(u, _, t) -> (t, S.member u ls)) l) file
	stop

type Present = Bool

header :: [(RemoteName, TrustLevel)] -> String
header remotes = unlines (zipWith formatheader [0..] remotes) ++ pipes (length remotes)
  where
    formatheader n (remotename, trustlevel) = pipes n ++ remotename ++ trust trustlevel
    pipes = flip replicate '|'
    trust UnTrusted = " (untrusted)"
    trust _ = ""

format :: [(TrustLevel, Present)] -> FilePath -> String
format remotes file = thereMap ++ " " ++ file
  where
    thereMap = concatMap there remotes
    there (UnTrusted, True) = "x"
    there (_, True) = "X"
    there (_, False) = "_"


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

module Command.Lock where

import Common.Annex
import Command
import qualified Annex.Queue
import qualified Annex

def :: [Command]
def = [notDirect $ command "lock" paramPaths seek SectionCommon
	"undo unlock command"]

seek :: CommandSeek
seek ps = do
	withFilesUnlocked start ps
	withFilesUnlockedToBeCommitted start ps

start :: FilePath -> CommandStart
start file = do
	showStart "lock" file
	unlessM (Annex.getState Annex.force) $
		error "Locking this file would discard any changes you have made to it. Use 'git annex add' to stage your changes. (Or, use --force to override)"
	next $ perform file

perform :: FilePath -> CommandPerform
perform file = do
	Annex.Queue.addCommand "checkout" [Param "--"] [file]
	next $ return True -- no cleanup needed


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

module Command.Log where

import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Time.Clock.POSIX
import Data.Time
import System.Locale
import Data.Char

import Common.Annex
import Command
import Logs
import qualified Logs.Presence
import Annex.CatFile
import qualified Annex.Branch
import qualified Git
import Git.Command
import qualified Remote
import qualified Annex

data RefChange = RefChange
	{ changetime :: POSIXTime
	, oldref :: Git.Ref
	, newref :: Git.Ref
	}

type Outputter = Bool -> POSIXTime -> [UUID] -> Annex ()

def :: [Command]
def = [withOptions options $
	command "log" paramPaths seek SectionQuery "shows location log"]

options :: [Option]
options = passthruOptions ++ [gourceOption]

passthruOptions :: [Option]
passthruOptions = map odate ["since", "after", "until", "before"] ++
	[ fieldOption ['n'] "max-count" paramNumber
		"limit number of logs displayed"
	]
  where
	odate n = fieldOption [] n paramDate $ "show log " ++ n ++ " date"

gourceOption :: Option
gourceOption = flagOption [] "gource" "format output for gource"

seek :: CommandSeek
seek ps = do
	m <- Remote.uuidDescriptions
	zone <- liftIO getCurrentTimeZone
	os <- concat <$> mapM getoption passthruOptions
	gource <- getOptionFlag gourceOption
	withFilesInGit (whenAnnexed $ start m zone os gource) ps
  where
	getoption o = maybe [] (use o) <$>
		Annex.getField (optionName o)
	use o v = [Param ("--" ++ optionName o), Param v]

start
	:: M.Map UUID String
	-> TimeZone
	-> [CommandParam]
	-> Bool
	-> FilePath
	-> Key
	-> CommandStart
start m zone os gource file key = do
	showLog output =<< readLog <$> getLog key os
	-- getLog produces a zombie; reap it
	liftIO reapZombies
	stop
  where
	output
		| gource = gourceOutput lookupdescription file
		| otherwise = normalOutput lookupdescription file zone
	lookupdescription u = fromMaybe (fromUUID u) $ M.lookup u m

showLog :: Outputter -> [RefChange] -> Annex ()
showLog outputter ps = do
	sets <- mapM (getset newref) ps
	previous <- maybe (return genesis) (getset oldref) (lastMaybe ps)
	sequence_ $ compareChanges outputter $ sets ++ [previous]
  where
	genesis = (0, S.empty)
	getset select change = do
		s <- S.fromList <$> get (select change)
		return (changetime change, s)
	get ref = map toUUID . Logs.Presence.getLog . L.unpack <$>
		catObject ref

normalOutput :: (UUID -> String) -> FilePath -> TimeZone -> Outputter
normalOutput lookupdescription file zone present ts us =
	liftIO $ mapM_ (putStrLn . format) us
  where
	time = showTimeStamp zone ts
	addel = if present then "+" else "-"
	format u = unwords [ addel, time, file, "|",
		fromUUID u ++ " -- " ++ lookupdescription u ]

gourceOutput :: (UUID -> String) -> FilePath -> Outputter
gourceOutput lookupdescription file present ts us =
	liftIO $ mapM_ (putStrLn . intercalate "|" . format) us
  where
	time = takeWhile isDigit $ show ts
	addel = if present then "A" else "M"
	format u = [ time, lookupdescription u, addel, file ]

{- Generates a display of the changes (which are ordered with newest first),
 - by comparing each change with the previous change.
 - Uses a formatter to generate a display of items that are added and
 - removed. -}
compareChanges :: Ord a => (Bool -> POSIXTime -> [a] -> b) -> [(POSIXTime, S.Set a)] -> [b]
compareChanges format changes = concatMap diff $ zip changes (drop 1 changes)
  where
	diff ((ts, new), (_, old)) =
		[format True ts added, format False ts removed]
	  where
		added = S.toList $ S.difference new old
		removed = S.toList $ S.difference old new

{- Gets the git log for a given location log file.
 -
 - This is complicated by git log using paths relative to the current
 - directory, even when looking at files in a different branch. A wacky
 - relative path to the log file has to be used.
 -
 - The --remove-empty is a significant optimisation. It relies on location
 - log files never being deleted in normal operation. Letting git stop
 - once the location log file is gone avoids it checking all the way back
 - to commit 0 to see if it used to exist, so generally speeds things up a
 - *lot* for newish files. -}
getLog :: Key -> [CommandParam] -> Annex [String]
getLog key os = do
	top <- fromRepo Git.repoPath
	p <- liftIO $ relPathCwdToFile top
	let logfile = p </> locationLogFile key
	inRepo $ pipeNullSplitZombie $
		[ Params "log -z --pretty=format:%ct --raw --abbrev=40"
		, Param "--remove-empty"
		] ++ os ++
		[ Param $ Git.fromRef Annex.Branch.fullname
		, Param "--"
		, Param logfile
		]

readLog :: [String] -> [RefChange]
readLog = mapMaybe (parse . lines)
  where
	parse (ts:raw:[]) = let (old, new) = parseRaw raw in
		Just RefChange
			{ changetime = parseTimeStamp ts
			, oldref = old
			, newref = new
			}
	parse _ = Nothing

-- Parses something like ":100644 100644 oldsha newsha M"
parseRaw :: String -> (Git.Ref, Git.Ref)
parseRaw l = go $ words l
  where
	go (_:_:oldsha:newsha:_) = (Git.Ref oldsha, Git.Ref newsha)
	go _ = error $ "unable to parse git log output: " ++ l

parseTimeStamp :: String -> POSIXTime
parseTimeStamp = utcTimeToPOSIXSeconds . fromMaybe (error "bad timestamp") .
	parseTime defaultTimeLocale "%s"

showTimeStamp :: TimeZone -> POSIXTime -> String
showTimeStamp zone = show . utcToLocalTime zone . posixSecondsToUTCTime


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

module Command.LookupKey where

import Common.Annex
import Command
import Annex.CatFile
import Types.Key

def :: [Command]
def = [notBareRepo $ noCommit $ noMessages $
	command "lookupkey" (paramRepeating paramFile) seek
		SectionPlumbing "looks up key used for file"]

seek :: CommandSeek
seek = withStrings start

start :: String -> CommandStart
start file = do
	liftIO . maybe exitFailure (putStrLn . key2file) =<< catKeyFile file
	stop


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

module Command.Map where

import Control.Exception.Extensible
import qualified Data.Map as M

import Common.Annex
import Command
import qualified Git
import qualified Git.Url
import qualified Git.Config
import qualified Git.Construct
import qualified Annex
import Annex.UUID
import Logs.UUID
import Logs.Trust
import qualified Remote.Helper.Ssh as Ssh
import qualified Utility.Dot as Dot

-- a link from the first repository to the second (its remote)
data Link = Link Git.Repo Git.Repo

def :: [Command]
def = [dontCheck repoExists $
	command "map" paramNothing seek SectionQuery
		"generate map of repositories"]

seek :: CommandSeek
seek = withNothing start

start :: CommandStart
start = do
	rs <- combineSame <$> (spider =<< gitRepo)

	umap <- uuidMap
	trusted <- trustGet Trusted

	file <- (</>) <$> fromRepo gitAnnexDir <*> pure "map.dot"

	liftIO $ writeFile file (drawMap rs umap trusted)
	next $ next $
		ifM (Annex.getState Annex.fast)
			( return True
			, do
				showLongNote $ "running: dot -Tx11 " ++ file
				showOutput
				liftIO $ boolSystem "dot" [Param "-Tx11", File file]
			)

{- Generates a graph for dot(1). Each repository, and any other uuids, are
 - displayed as a node, and each of its remotes is represented as an edge
 - pointing at the node for the remote.
 -
 - The order nodes are added to the graph matters, since dot will draw
 - the first ones near to the top and left. So it looks better to put
 - the repositories first, followed by uuids that were not matched
 - to a repository.
 -}
drawMap :: [Git.Repo] -> M.Map UUID String -> [UUID] -> String
drawMap rs umap ts = Dot.graph $ repos ++ trusted ++ others
  where
	repos = map (node umap rs) rs
	ruuids = ts ++ map getUncachedUUID rs
	others = map (unreachable . uuidnode) $
		filter (`notElem` ruuids) (M.keys umap)
	trusted = map (trustworthy . uuidnode) ts
	uuidnode u = Dot.graphNode (fromUUID u) $ M.findWithDefault "" u umap

hostname :: Git.Repo -> String
hostname r
	| Git.repoIsUrl r = fromMaybe (Git.repoLocation r) (Git.Url.host r)
	| otherwise = "localhost"

basehostname :: Git.Repo -> String
basehostname r = fromMaybe "" $ headMaybe $ split "." $ hostname r

{- A name to display for a repo. Uses the name from uuid.log if available,
 - or the remote name if not. -}
repoName :: M.Map UUID String -> Git.Repo -> String
repoName umap r
	| repouuid == NoUUID = fallback
	| otherwise = M.findWithDefault fallback repouuid umap
  where
	repouuid = getUncachedUUID r
	fallback = fromMaybe "unknown" $ Git.remoteName r

{- A unique id for the node for a repo. Uses the annex.uuid if available. -}
nodeId :: Git.Repo -> String
nodeId r =
	case getUncachedUUID r of
		NoUUID -> Git.repoLocation r
		UUID u -> u

{- A node representing a repo. -}
node :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> String
node umap fullinfo r = unlines $ n:edges
  where
	n = Dot.subGraph (hostname r) (basehostname r) "lightblue" $
		decorate $ Dot.graphNode (nodeId r) (repoName umap r)
	edges = map (edge umap fullinfo r) (Git.remotes r)
	decorate
		| Git.config r == M.empty = unreachable
		| otherwise = reachable

{- An edge between two repos. The second repo is a remote of the first. -}
edge :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> Git.Repo -> String
edge umap fullinfo from to =
	Dot.graphEdge (nodeId from) (nodeId fullto) edgename
  where
	-- get the full info for the remote, to get its UUID
	fullto = findfullinfo to
	findfullinfo n =
		case filter (same n) fullinfo of
			[] -> n
			(n':_) -> n'
	{- Only name an edge if the name is different than the name
	 - that will be used for the destination node, and is
	 - different from its hostname. (This reduces visual clutter.) -}
	edgename = maybe Nothing calcname $ Git.remoteName to
	calcname n
		| n `elem` [repoName umap fullto, hostname fullto] = Nothing
		| otherwise = Just n

unreachable :: String -> String
unreachable = Dot.fillColor "red"
reachable :: String -> String
reachable = Dot.fillColor "white"
trustworthy :: String -> String
trustworthy = Dot.fillColor "green"

{- Recursively searches out remotes starting with the specified repo. -}
spider :: Git.Repo -> Annex [Git.Repo]
spider r = spider' [r] []
spider' :: [Git.Repo] -> [Git.Repo] -> Annex [Git.Repo]
spider' [] known = return known
spider' (r:rs) known
	| any (same r) known = spider' rs known
	| otherwise = do
		r' <- scan r

		-- The remotes will be relative to r', and need to be
		-- made absolute for later use.
		remotes <- mapM (absRepo r') (Git.remotes r')
		let r'' = r' { Git.remotes = remotes }

		spider' (rs ++ remotes) (r'':known)

{- Converts repos to a common absolute form. -}
absRepo :: Git.Repo -> Git.Repo -> Annex Git.Repo
absRepo reference r
	| Git.repoIsUrl reference = return $ Git.Construct.localToUrl reference r
	| Git.repoIsUrl r = return r
	| otherwise = liftIO $ do
		r' <- Git.Construct.fromAbsPath =<< absPath (Git.repoPath r)
		r'' <- safely $ flip Annex.eval Annex.gitRepo =<< Annex.new r'
		return (fromMaybe r' r'')

{- Checks if two repos are the same. -}
same :: Git.Repo -> Git.Repo -> Bool
same a b
	| both Git.repoIsSsh = matching Git.Url.authority && matching Git.repoPath
	| both Git.repoIsUrl && neither Git.repoIsSsh = matching show
	| neither Git.repoIsSsh = matching Git.repoPath
	| otherwise = False
  where
	matching t = t a == t b
	both t = t a && t b
	neither t = not (t a) && not (t b)

{- reads the config of a remote, with progress display -}
scan :: Git.Repo -> Annex Git.Repo
scan r = do
	showStart "map" $ Git.repoDescribe r
	v <- tryScan r
	case v of
		Just r' -> do
			showEndOk
			return r'
		Nothing -> do
			showOutput
			showEndFail
			return r

{- tries to read the config of a remote, returning it only if it can
 - be accessed -}
tryScan :: Git.Repo -> Annex (Maybe Git.Repo)
tryScan r
	| Git.repoIsSsh r = sshscan
	| Git.repoIsUrl r = return Nothing
	| otherwise = liftIO $ safely $ Git.Config.read r
  where
	pipedconfig cmd params = liftIO $ safely $
		withHandle StdoutHandle createProcessSuccess p $
			Git.Config.hRead r
	  where
		p = proc cmd $ toCommand params

	configlist = Ssh.onRemote r (pipedconfig, Nothing) "configlist" [] []
	manualconfiglist = do
		gc <- Annex.getRemoteGitConfig r
		sshparams <- Ssh.toRepo r gc [Param sshcmd]
		liftIO $ pipedconfig "ssh" sshparams
	  where
		sshcmd = cddir ++ " && " ++
			"git config --null --list"
		dir = Git.repoPath r
		cddir
			| "/~" `isPrefixOf` dir =
				let (userhome, reldir) = span (/= '/') (drop 1 dir)
				in "cd " ++ userhome ++ " && cd " ++ shellEscape (drop 1 reldir)
			| otherwise = "cd " ++ shellEscape dir

	-- First, try sshing and running git config manually,
	-- only fall back to git-annex-shell configlist if that
	-- fails.
	--
	-- This is done for two reasons, first I'd like this
	-- subcommand to be usable on non-git-annex repos.
	-- Secondly, configlist doesn't include information about
	-- the remote's remotes.
	sshscan = do
		sshnote
		v <- manualconfiglist
		case v of
			Nothing -> do
				sshnote
				configlist
			ok -> return ok

	sshnote = do
		showAction "sshing"
		showOutput

{- Spidering can find multiple paths to the same repo, so this is used
 - to combine (really remove) duplicate repos with the same UUID. -}
combineSame :: [Git.Repo] -> [Git.Repo]
combineSame = map snd . nubBy sameuuid . map pair
  where
	sameuuid (u1, _) (u2, _) = u1 == u2 && u1 /= NoUUID
	pair r = (getUncachedUUID r, r)

safely :: IO Git.Repo -> IO (Maybe Git.Repo)
safely a = do
	result <- try a :: IO (Either SomeException Git.Repo)
	case result of
		Left _ -> return Nothing
		Right r' -> return $ Just r'


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

module Command.Merge where

import Common.Annex
import Command
import qualified Annex.Branch
import qualified Git.Branch
import Command.Sync (prepMerge, mergeLocal)

def :: [Command]
def = [command "merge" paramNothing seek SectionMaintenance
	"automatically merge changes from remotes"]

seek :: CommandSeek
seek ps = do
	withNothing mergeBranch ps
	withNothing mergeSynced ps

mergeBranch :: CommandStart
mergeBranch = do
	showStart "merge" "git-annex"
	next $ do
		Annex.Branch.update
		-- commit explicitly, in case no remote branches were merged
		Annex.Branch.commit "update"
		next $ return True

mergeSynced :: CommandStart
mergeSynced = do
	prepMerge
	mergeLocal =<< inRepo Git.Branch.current


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

module Command.MetaData where

import Common.Annex
import qualified Annex
import Command
import Annex.MetaData
import Logs.MetaData

import qualified Data.Set as S
import Data.Time.Clock.POSIX

def :: [Command]
def = [withOptions metaDataOptions $
	command "metadata" paramPaths seek
	SectionMetaData "sets metadata of a file"]

metaDataOptions :: [Option]
metaDataOptions =
	[ setOption
	, tagOption
	, untagOption
	, getOption
	, jsonOption
	] ++ keyOptions

storeModMeta :: ModMeta -> Annex ()
storeModMeta modmeta = Annex.changeState $
	\s -> s { Annex.modmeta = modmeta:Annex.modmeta s }

setOption :: Option
setOption = Option ['s'] ["set"] (ReqArg mkmod "FIELD[+-]=VALUE") "set metadata"
  where
	mkmod = either error storeModMeta . parseModMeta

getOption :: Option
getOption = fieldOption ['g'] "get" paramField "get single metadata field"

tagOption :: Option
tagOption = Option ['t'] ["tag"] (ReqArg mkmod "TAG") "set a tag"
  where
	mkmod = storeModMeta . AddMeta tagMetaField . toMetaValue

untagOption :: Option
untagOption = Option ['u'] ["untag"] (ReqArg mkmod "TAG") "remove a tag"
  where
	mkmod = storeModMeta . AddMeta tagMetaField . mkMetaValue (CurrentlySet False)

seek :: CommandSeek
seek ps = do
	modmeta <- Annex.getState Annex.modmeta
	getfield <- getOptionField getOption $ \ms ->
		return $ either error id . mkMetaField <$> ms
	now <- liftIO getPOSIXTime
	withKeyOptions
		(startKeys now getfield modmeta)
		(withFilesInGit (whenAnnexed $ start now getfield modmeta))
		ps

start :: POSIXTime -> Maybe MetaField -> [ModMeta] -> FilePath -> Key -> CommandStart
start now f ms file = start' (Just file) now f ms

startKeys :: POSIXTime -> Maybe MetaField -> [ModMeta] -> Key -> CommandStart
startKeys = start' Nothing

start' :: AssociatedFile -> POSIXTime -> Maybe MetaField -> [ModMeta] -> Key -> CommandStart
start' afile now Nothing ms k = do
	showStart' "metadata" k afile
	next $ perform now ms k
start' _ _ (Just f) _ k = do
	l <- S.toList . currentMetaDataValues f <$> getCurrentMetaData k
	liftIO $ forM_ l $
		putStrLn . fromMetaValue
	stop

perform :: POSIXTime -> [ModMeta] -> Key -> CommandPerform
perform _ [] k = next $ cleanup k
perform now ms k = do
	oldm <- getCurrentMetaData k
	let m = combineMetaData $ map (modMeta oldm) ms
	addMetaData' k m now
	next $ cleanup k

cleanup :: Key -> CommandCleanup
cleanup k = do
	l <- map unwrapmeta . fromMetaData <$> getCurrentMetaData k
	maybeShowJSON l
	showLongNote $ unlines $ concatMap showmeta l
	return True
  where
	unwrapmeta (f, v) = (fromMetaField f, map fromMetaValue (S.toList v))
	showmeta (f, vs) = map ((f ++ "=") ++) vs


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

module Command.Migrate where

import Common.Annex
import Command
import Backend
import qualified Types.Key
import Types.Backend (canUpgradeKey, fastMigrate)
import Types.KeySource
import Annex.Content
import qualified Command.ReKey
import qualified Command.Fsck

def :: [Command]
def = [notDirect $
	command "migrate" paramPaths seek
		SectionUtility "switch data to different backend"]

seek :: CommandSeek
seek = withFilesInGit $ whenAnnexed start

start :: FilePath -> Key -> CommandStart
start file key = do
	v <- Backend.getBackend file key
	case v of
		Nothing -> stop
		Just oldbackend -> do
			exists <- inAnnex key
			newbackend <- choosebackend =<< chooseBackend file
			if (newbackend /= oldbackend || upgradableKey oldbackend key) && exists
				then do
					showStart "migrate" file
					next $ perform file key oldbackend newbackend
				else stop
  where
	choosebackend Nothing = Prelude.head <$> orderedList
	choosebackend (Just backend) = return backend

{- Checks if a key is upgradable to a newer representation.
 -
 - Reasons for migration:
 -  - Ideally, all keys have file size metadata. Old keys may not.
 -  - Something has changed in the backend, such as a bug fix.
 -}
upgradableKey :: Backend -> Key -> Bool
upgradableKey backend key = isNothing (Types.Key.keySize key) || backendupgradable
  where
	backendupgradable = maybe False (\a -> a key) (canUpgradeKey backend)

{- Store the old backend's key in the new backend
 - The old backend's key is not dropped from it, because there may
 - be other files still pointing at that key.
 -
 - To ensure that the data we have for the old key is valid, it's
 - fscked here. First we generate the new key. This ensures that the
 - data cannot get corrupted after the fsck but before the new key is
 - generated.
 -}
perform :: FilePath -> Key -> Backend -> Backend -> CommandPerform
perform file oldkey oldbackend newbackend = go =<< genkey
  where
  	go Nothing = stop
	go (Just (newkey, knowngoodcontent))
		| knowngoodcontent = finish newkey
		| otherwise = stopUnless checkcontent $ finish newkey
	checkcontent = Command.Fsck.checkBackend oldbackend oldkey $ Just file
	finish newkey = stopUnless (Command.ReKey.linkKey oldkey newkey) $
		next $ Command.ReKey.cleanup file oldkey newkey
	genkey = case maybe Nothing (\fm -> fm oldkey newbackend) (fastMigrate oldbackend) of
		Just newkey -> return $ Just (newkey, True)
		Nothing -> do
			content <- calcRepo $ gitAnnexLocation oldkey
			let source = KeySource
				{ keyFilename = file
				, contentLocation = content
				, inodeCache = Nothing
				}
			v <- genKey source (Just newbackend)
			return $ case v of
				Just (newkey, _) -> Just (newkey, False)
				_ -> Nothing


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

module Command.Mirror where

import Common.Annex
import Command
import qualified Command.Move
import qualified Command.Drop
import qualified Command.Get
import qualified Remote
import Annex.Content
import qualified Annex
import Config.NumCopies

def :: [Command]
def = [withOptions (fromToOptions ++ keyOptions) $
	command "mirror" paramPaths seek
		SectionCommon "mirror content of files to/from another repository"]

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

start :: Maybe Remote -> Maybe Remote -> FilePath -> Key -> CommandStart
start to from file key = startKey to from (Just file) key

startKey :: Maybe Remote -> Maybe Remote -> Maybe FilePath -> Key -> CommandStart
startKey to from afile key = do
	noAuto
	case (from, to) of
		(Nothing, Nothing) -> error "specify either --from or --to"
		(Nothing, Just r) -> mirrorto r
		(Just r, Nothing) -> mirrorfrom r
		_ -> error "only one of --from or --to can be specified"
  where
	noAuto = whenM (Annex.getState Annex.auto) $
		error "--auto is not supported for mirror"
	mirrorto r = ifM (inAnnex key)
		( Command.Move.toStart r False afile key
		, do
			numcopies <- getnumcopies
			Command.Drop.startRemote afile numcopies key r
		)
	mirrorfrom r = do
		haskey <- Remote.hasKey r key
		case haskey of
			Left _ -> stop
			Right True -> Command.Get.start' (return True) Nothing key afile
			Right False -> ifM (inAnnex key)
				( do
					numcopies <- getnumcopies
					Command.Drop.startLocal afile numcopies key Nothing
				, stop
				)
	getnumcopies = maybe getNumCopies getFileNumCopies afile


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

module Command.Move where

import Common.Annex
import Command
import qualified Command.Drop
import qualified Annex
import Annex.Content
import qualified Remote
import Annex.UUID
import Annex.Transfer
import Logs.Presence

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

moveOptions :: [Option]
moveOptions = fromToOptions ++ keyOptions

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

start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> Key -> CommandStart
start to from move file key = start' to from move (Just file) key

startKey :: Maybe Remote -> Maybe Remote -> Bool -> Key -> CommandStart
startKey to from move = start' to from move Nothing

start' :: Maybe Remote -> Maybe Remote -> Bool -> AssociatedFile -> Key -> CommandStart
start' to from move afile key = do
	noAuto
	case (from, to) of
		(Nothing, Nothing) -> error "specify either --from or --to"
		(Nothing, Just dest) -> toStart dest move afile key
		(Just src, Nothing) -> fromStart src move afile key
		_ -> error "only one of --from or --to can be specified"
  where
	noAuto = when move $ whenM (Annex.getState Annex.auto) $ error
		"--auto is not supported for move"

showMoveAction :: Bool -> Key -> AssociatedFile -> Annex ()
showMoveAction move = showStart' (if move then "move" else "copy")

{- Moves (or copies) the content of an annexed file to a remote.
 -
 - If the remote already has the content, it is still removed from
 - the current repository.
 -
 - Note that unlike drop, this does not honor numcopies.
 - A file's content can be moved even if there are insufficient copies to
 - allow it to be dropped.
 -}
toStart :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart
toStart dest move afile key = do
	u <- getUUID
	ishere <- inAnnex key
	if not ishere || u == Remote.uuid dest
		then stop -- not here, so nothing to do
		else toStart' dest move afile key

toStart' :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart
toStart' dest move afile key = do
	fast <- Annex.getState Annex.fast
	if fast && not move && not (Remote.hasKeyCheap dest)
		then ifM (expectedPresent dest key)
			( stop
			, go True (pure $ Right False)
			)
		else go False (Remote.hasKey dest key)
  where
	go fastcheck isthere = do
		showMoveAction move key afile
		next $ toPerform dest move key afile fastcheck =<< isthere

expectedPresent :: Remote -> Key -> Annex Bool
expectedPresent dest key = do
	remotes <- Remote.keyPossibilities key
	return $ dest `elem` remotes

toPerform :: Remote -> Bool -> Key -> AssociatedFile -> Bool -> Either String Bool -> CommandPerform
toPerform dest move key afile fastcheck isthere = moveLock move key $
	case isthere of
		Left err -> do
			showNote err
			stop
		Right False -> do
			showAction $ "to " ++ Remote.name dest
			ok <- notifyTransfer Upload afile $
				upload (Remote.uuid dest) key afile noRetry $
					Remote.storeKey dest key afile
			if ok
				then do
					Remote.logStatus dest key InfoPresent
					finish
				else do
					when fastcheck $
						warning "This could have failed because --fast is enabled."
					stop
		Right True -> do
			unlessM (expectedPresent dest key) $
				Remote.logStatus dest key InfoPresent
			finish
  where
	finish
		| move = do
			removeAnnex key
			next $ Command.Drop.cleanupLocal key
		| otherwise = next $ return True

{- Moves (or copies) the content of an annexed file from a remote
 - to the current repository.
 -
 - If the current repository already has the content, it is still removed
 - from the remote.
 -}
fromStart :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart
fromStart src move afile key
	| move = go
	| otherwise = stopUnless (not <$> inAnnex key) go
  where
	go = stopUnless (fromOk src key) $ do
		showMoveAction move key afile
		next $ fromPerform src move key afile

fromOk :: Remote -> Key -> Annex Bool
fromOk src key = go =<< Annex.getState Annex.force
  where
	go True = either (const $ return True) return =<< haskey
	go False
		| Remote.hasKeyCheap src =
			either (const expensive) return =<< haskey
		| otherwise = expensive
	haskey = Remote.hasKey src key
	expensive = do
		u <- getUUID
		remotes <- Remote.keyPossibilities key
		return $ u /= Remote.uuid src && elem src remotes

fromPerform :: Remote -> Bool -> Key -> AssociatedFile -> CommandPerform
fromPerform src move key afile = moveLock move key $
	ifM (inAnnex key)
		( handle move True
		, handle move =<< go
		)
  where
	go = notifyTransfer Download afile $
		download (Remote.uuid src) key afile noRetry $ \p -> do
			showAction $ "from " ++ Remote.name src
			getViaTmp key $ \t -> Remote.retrieveKeyFile src key afile t p
	handle _ False = stop -- failed
	handle False True = next $ return True -- copy complete
	handle True True = do -- finish moving
		ok <- Remote.removeKey src key
		next $ Command.Drop.cleanupRemote key src ok

{- Locks a key in order for it to be moved.
 - No lock is needed when a key is being copied. -}
moveLock :: Bool -> Key -> Annex a -> Annex a
moveLock True key a = lockContent key a
moveLock False _ a = a


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

module Command.NotifyChanges where

import Common.Annex
import Command
import Utility.DirWatcher
import Utility.DirWatcher.Types
import qualified Git
import Git.Sha
import RemoteDaemon.Transport.Ssh.Types

import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM

def :: [Command]
def = [noCommit $ command "notifychanges" paramNothing seek SectionPlumbing
	"sends notification when git refs are changed"]

seek :: CommandSeek
seek = withNothing start

start :: CommandStart
start = do
	-- This channel is used to accumulate notifcations,
	-- because the DirWatcher might have multiple threads that find
	-- changes at the same time.
	chan <- liftIO newTChanIO

	g <- gitRepo
	let refdir = Git.localGitDir g </> "refs"
	liftIO $ createDirectoryIfMissing True refdir

	let notifyhook = Just $ notifyHook chan
	let hooks = mkWatchHooks
		{ addHook = notifyhook
		, modifyHook = notifyhook
		}

	void $ liftIO $ watchDir refdir (const False) True hooks id

	let sender = do
		send READY
		forever $ send . CHANGED =<< drain chan

	-- No messages need to be received from the caller,
	-- but when it closes the connection, notice and terminate.
	let receiver = forever $ void $ getLine
	void $ liftIO $ concurrently sender receiver
	stop

notifyHook :: TChan Git.Sha -> FilePath -> Maybe FileStatus -> IO ()
notifyHook chan reffile _
	| ".lock" `isSuffixOf` reffile = noop
	| otherwise = void $ do
		sha <- catchDefaultIO Nothing $
			extractSha <$> readFile reffile
		maybe noop (atomically . writeTChan chan) sha

-- When possible, coalesce ref writes that occur closely together
-- in time. Delay up to 0.05 seconds to get more ref writes.
drain :: TChan Git.Sha -> IO [Git.Sha]
drain chan = do
	r <- atomically $ readTChan chan
	threadDelay 50000
	rs <- atomically $ drain' chan
	return (r:rs)

drain' :: TChan Git.Sha -> STM [Git.Sha]
drain' chan = loop []
  where
	loop rs = maybe (return rs) (\r -> loop (r:rs)) =<< tryReadTChan chan

send :: Notification -> IO ()
send n = do
	putStrLn $ unwords $ formatMessage n
	hFlush stdout


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

module Command.NumCopies where

import Common.Annex
import qualified Annex
import Command
import Config.NumCopies
import Types.Messages

def :: [Command]
def = [command "numcopies" paramNumber seek
	SectionSetup "configure desired number of copies"]

seek :: CommandSeek
seek = withWords start

start :: [String] -> CommandStart
start [] = startGet
start [s] = do
	case readish s of
		Nothing -> error $ "Bad number: " ++ s
		Just n
			| n > 0 -> startSet n
			| n == 0 -> ifM (Annex.getState Annex.force)
				( startSet n
				, error "Setting numcopies to 0 is very unsafe. You will lose data! If you really want to do that, specify --force."
				)
			| otherwise -> error "Number cannot be negative!"
start _ = error "Specify a single number."

startGet :: CommandStart
startGet = next $ next $ do
	Annex.setOutput QuietOutput
	v <- getGlobalNumCopies
	case v of
		Just n -> liftIO $ putStrLn $ show $ fromNumCopies n
		Nothing -> do
			liftIO $ putStrLn $ "global numcopies is not set"
			old <- deprecatedNumCopies
			case old of
				Nothing -> liftIO $ putStrLn "(default is 1)"
				Just n -> liftIO $ putStrLn $ "(deprecated git config annex.numcopies is set to " ++ show (fromNumCopies n) ++ " locally)"
	return True

startSet :: Int -> CommandStart
startSet n = do
	showStart "numcopies" (show n)
	next $ next $ do
		setGlobalNumCopies $ NumCopies n
		return True


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

{-# LANGUAGE CPP #-}

module Command.PreCommit where

import Common.Annex
import Command
import Config
import qualified Command.Add
import qualified Command.Fix
import Annex.Direct
import Annex.Hook
import Annex.View
import Annex.View.ViewedFile
import Annex.Perms
import Annex.Exception
import Logs.View
import Logs.MetaData
import Types.View
import Types.MetaData

#ifdef mingw32_HOST_OS
import Utility.WinLock
#endif

import qualified Data.Set as S

def :: [Command]
def = [command "pre-commit" paramPaths seek SectionPlumbing
	"run by git pre-commit hook"]

seek :: CommandSeek
seek ps = lockPreCommitHook $ ifM isDirect
	( do
		-- update direct mode mappings for committed files
		withWords startDirect ps
		runAnnexHook preCommitAnnexHook
	, do
		-- fix symlinks to files being committed
		withFilesToBeCommitted (whenAnnexed Command.Fix.start) ps
		-- inject unlocked files into the annex
		withFilesUnlockedToBeCommitted startIndirect ps
		runAnnexHook preCommitAnnexHook
		-- committing changes to a view updates metadata
		mv <- currentView
		case mv of
			Nothing -> noop
			Just v -> withViewChanges
				(addViewMetaData v)
				(removeViewMetaData v)
	)

startIndirect :: FilePath -> CommandStart
startIndirect f = next $ do
	unlessM (callCommandAction $ Command.Add.start f) $
		error $ "failed to add " ++ f ++ "; canceling commit"
	next $ return True

startDirect :: [String] -> CommandStart
startDirect _ = next $ next $ preCommitDirect

addViewMetaData :: View -> ViewedFile -> Key -> CommandStart
addViewMetaData v f k = do
	showStart "metadata" f
	next $ next $ changeMetaData k $ fromView v f

removeViewMetaData :: View -> ViewedFile -> Key -> CommandStart
removeViewMetaData v f k = do
	showStart "metadata" f
	next $ next $ changeMetaData k $ unsetMetaData $ fromView v f

changeMetaData :: Key -> MetaData -> CommandCleanup
changeMetaData k metadata = do
	showMetaDataChange metadata
	addMetaData k metadata
	return True

showMetaDataChange :: MetaData -> Annex ()
showMetaDataChange = showLongNote . unlines . concatMap showmeta . fromMetaData
  where
	showmeta (f, vs) = map (showmetavalue f) $ S.toList vs
	showmetavalue f v = fromMetaField f ++ showset v ++ "=" ++ fromMetaValue v
	showset v
		| isSet v = "+"
		| otherwise = "-"

{- Takes exclusive lock; blocks until available. -}
lockPreCommitHook :: Annex a -> Annex a
lockPreCommitHook a = do
	lockfile <- fromRepo gitAnnexPreCommitLock
	createAnnexDirectory $ takeDirectory lockfile
	mode <- annexFileMode
	bracketIO (lock lockfile mode) unlock (const a)
  where
#ifndef mingw32_HOST_OS
	lock lockfile mode = do
		l <- liftIO $ noUmask mode $ createFile lockfile mode
		liftIO $ waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0)
		return l
	unlock = closeFd
#else
	lock lockfile _mode = liftIO $ waitToLock $  lockExclusive lockfile
	unlock = dropLock
#endif


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

module Command.ReKey where

import Common.Annex
import Command
import qualified Annex
import Types.Key
import Annex.Content
import qualified Command.Add
import Logs.Web
import Logs.Location
import Utility.CopyFile

def :: [Command]
def = [notDirect $ command "rekey"
	(paramOptional $ paramRepeating $ paramPair paramPath paramKey)
	seek SectionPlumbing "change keys used for files"]

seek :: CommandSeek
seek = withPairs start

start :: (FilePath, String) -> CommandStart
start (file, keyname) = ifAnnexed file go stop
  where
	newkey = fromMaybe (error "bad key") $ file2key keyname
	go oldkey
		| oldkey == newkey = stop
		| otherwise = do
			showStart "rekey" file
			next $ perform file oldkey newkey

perform :: FilePath -> Key -> Key -> CommandPerform
perform file oldkey newkey = do
	present <- inAnnex oldkey
	_ <- if present
		then linkKey oldkey newkey
		else do
			unlessM (Annex.getState Annex.force) $
				error $ file ++ " is not available (use --force to override)"
			return True
	next $ cleanup file oldkey newkey

{- Make a hard link to the old key content (when supported),
 - to avoid wasting disk space. -}
linkKey :: Key -> Key -> Annex Bool
linkKey oldkey newkey = getViaTmpUnchecked newkey $ \tmp -> do
	src <- calcRepo $ gitAnnexLocation oldkey
	liftIO $ ifM (doesFileExist tmp)
		( return True
		, createLinkOrCopy src tmp
		)

cleanup :: FilePath -> Key -> Key -> CommandCleanup
cleanup file oldkey newkey = do
	-- If the old key had some associated urls, record them for
	-- the new key as well.
	urls <- getUrls oldkey
	unless (null urls) $
		mapM_ (setUrlPresent newkey) urls

	-- Update symlink to use the new key.
	liftIO $ removeFile file
	Command.Add.addLink file newkey Nothing
	logStatus newkey InfoPresent
	return True


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

module Command.RecvKey where

import Common.Annex
import Command
import CmdLine
import Annex.Content
import Annex
import Utility.Rsync
import Logs.Transfer
import Command.SendKey (fieldTransfer)
import qualified CmdLine.GitAnnexShell.Fields as Fields
import qualified Types.Key
import qualified Types.Backend
import qualified Backend

def :: [Command]
def = [noCommit $ command "recvkey" paramKey seek
	SectionPlumbing "runs rsync in server mode to receive content"]

seek :: CommandSeek
seek = withKeys start

start :: Key -> CommandStart
start key = ifM (inAnnex key)
	( error "key is already present in annex"
	, fieldTransfer Download key $ \_p ->
		ifM (getViaTmp key go)
			( do
				-- forcibly quit after receiving one key,
				-- and shutdown cleanly
				_ <- shutdown True
				return True
			, return False
			)
	)
  where
	go tmp = do
		opts <- filterRsyncSafeOptions . maybe [] words
			<$> getField "RsyncOptions"
		ok <- liftIO $ rsyncServerReceive (map Param opts) tmp

		-- The file could have been received with permissions that
		-- do not allow reading it, so this is done before the
		-- directcheck.
		freezeContent tmp

		if ok
			then ifM (isJust <$> Fields.getField Fields.direct)
				( directcheck tmp
				, return True
				)
			else return False
	{- If the sending repository uses direct mode, the file
	 - it sends could be modified as it's sending it. So check
	 - that the right size file was received, and that the key/value
	 - Backend is happy with it. -}
	directcheck tmp = do
		oksize <- case Types.Key.keySize key of
		        Nothing -> return True
		        Just size -> do
				size' <- fromIntegral . fileSize
       	        	        	<$> liftIO (getFileStatus tmp)
				return $ size == size'
		if oksize
			then case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of
				Nothing -> do
					warning "recvkey: received key from direct mode repository using unknown backend; cannot check; discarding"
					return False
				Just backend -> maybe (return True) runfsck
					(Types.Backend.fsckKey backend)
			else do
				warning "recvkey: received key with wrong size; discarding"
				return False
	  where
	  	runfsck check = ifM (check key tmp)
			( return True
			, do
				warning "recvkey: received key from direct mode repository seems to have changed as it was transferred; discarding"
				return False
			)


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

module Command.Reinit where

import Common.Annex
import Command
import Annex.Init
import Annex.UUID
import Types.UUID
import qualified Remote

def :: [Command]
def = [dontCheck repoExists $
	command "reinit" (paramUUID ++ " or " ++ paramDesc) seek SectionUtility ""]

seek :: CommandSeek
seek = withWords start

start :: [String] -> CommandStart
start ws = do
	showStart "reinit" s
	next $ perform s
  where
	s = unwords ws

perform :: String -> CommandPerform
perform s = do
	u <- if isUUID s
		then return $ toUUID s
		else Remote.nameToUUID s
	storeUUID u
	initialize'
	next $ return True


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

module Command.Reinject where

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

def :: [Command]
def = [command "reinject" (paramPair "SRC" "DEST") seek
	SectionUtility "sets content of annexed file"]

seek :: CommandSeek
seek = withWords start

start :: [FilePath] -> CommandStart
start (src:dest:[])
	| src == dest = stop
	| otherwise =
		ifAnnexed src
			(error $ "cannot used annexed file as src: " ++ src)
			go
  where
	go = do
		showStart "reinject" dest
		next $ whenAnnexed (perform src) dest
start _ = error "specify a src file and a dest file"

perform :: FilePath -> FilePath -> Key -> CommandPerform
perform src dest key = do
	{- Check the content before accepting it. -}
	v <- Backend.getBackend dest key
	case v of
		Nothing -> stop
		Just backend ->
			ifM (Command.Fsck.checkKeySizeOr reject key src
				<&&> Command.Fsck.checkBackendOr reject backend key src)
				( do
					unlessM move $ error "mv failed!"
					next $ cleanup key
				, error "not reinjecting"
				)
  where
	-- the file might be on a different filesystem,
	-- so mv is used rather than simply calling
	-- moveToObjectDir; disk space is also
	-- checked this way.
	move = getViaTmp key $ \tmp ->
		liftIO $ boolSystem "mv" [File src, File tmp]
	reject = const $ return "wrong file?"

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


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

module Command.RemoteDaemon where

import Common.Annex
import Command
import RemoteDaemon.Core

def :: [Command]
def = [noCommit $ command "remotedaemon" paramNothing seek SectionPlumbing
	"detects when remotes have changed, and fetches from them"]

seek :: CommandSeek
seek = withNothing start

start :: CommandStart
start = do
	liftIO runForeground
	stop


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

module Command.Repair where

import Common.Annex
import Command
import qualified Annex
import qualified Git.Repair
import qualified Annex.Branch
import qualified Git.Ref
import Git.Types
import Annex.Version

def :: [Command]
def = [noCommit $ dontCheck repoExists $
	command "repair" paramNothing seek SectionMaintenance "recover broken git repository"]

seek :: CommandSeek
seek = withNothing start

start :: CommandStart
start = next $ next $ runRepair =<< Annex.getState Annex.force

runRepair :: Bool -> Annex Bool
runRepair forced = do
	(ok, modifiedbranches) <- inRepo $
		Git.Repair.runRepair isAnnexSyncBranch forced
	-- This command can be run in git repos not using git-annex,
	-- so avoid git annex branch stuff in that case.
	whenM (isJust <$> getVersion) $
		repairAnnexBranch modifiedbranches
	return ok

{- After git repository repair, the .git/annex/index file could
 - still be broken, by pointing to bad objects, or might just be corrupt on
 - its own. Since this index file is not used to stage things
 - for long durations of time, it can safely be deleted if it is broken.
 -
 - Otherwise, if the git-annex branch was modified by the repair,
 - commit the index file to the git-annex branch.
 - This way, if the git-annex branch got rewound to an old version by
 - the repository repair, or was completely deleted, this will get it back
 - to a good state. Note that in the unlikely case where the git-annex
 - branch was rewound to a state that, had new changes from elsewhere not
 - yet reflected in the index, this does properly merge those into the
 - index before committing.
 -}
repairAnnexBranch :: [Branch] -> Annex ()
repairAnnexBranch modifiedbranches
	| Annex.Branch.fullname `elem` modifiedbranches = ifM okindex
		( commitindex
		, do
			nukeindex
			missingbranch
		)
	| otherwise = ifM okindex
		( noop
		, do
			nukeindex
			ifM (null <$> inRepo (Git.Ref.matching [Annex.Branch.fullname]))
				( missingbranch
				, liftIO $ putStrLn "No data was lost."
				)
		)
  where
	okindex = Annex.Branch.withIndex $ inRepo $ Git.Repair.checkIndex
	commitindex = do
		Annex.Branch.forceCommit "committing index after git repository repair"
		liftIO $ putStrLn "Successfully recovered the git-annex branch using .git/annex/index"
	nukeindex = do
		inRepo $ nukeFile . gitAnnexIndex
		liftIO $ putStrLn "Had to delete the .git/annex/index file as it was corrupt."
	missingbranch = liftIO $ putStrLn "Since the git-annex branch is not up-to-date anymore. It would be a very good idea to run: git annex fsck --fast"

trackingOrSyncBranch :: Ref -> Bool
trackingOrSyncBranch b = Git.Repair.isTrackingBranch b || isAnnexSyncBranch b

isAnnexSyncBranch :: Ref -> Bool
isAnnexSyncBranch b = "refs/synced/" `isPrefixOf` fromRef b


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

module Command.ResolveMerge where

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

def :: [Command]
def = [command "resolvemerge" paramNothing seek SectionPlumbing
	"resolve merge conflicts"]

seek :: CommandSeek
seek ps = withNothing start ps

start :: CommandStart
start = do
	showStart "resolvemerge" ""
	us <- fromMaybe nobranch <$> inRepo Git.Branch.current
	d <- fromRepo Git.localGitDir
	let merge_head = d </> "MERGE_HEAD"
	them <- fromMaybe (error nomergehead) . extractSha
		<$> liftIO (readFile merge_head)
	ifM (resolveMerge (Just us) them)
		( do
			void $ commitResolvedMerge Git.Branch.ManualCommit
			next $ next $ return True
		, error "Merge conflict could not be automatically resolved."
		)
  where
	nobranch = error "No branch is currently checked out."
	nomergehead = error "No SHA found in .git/merge_head"


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

module Command.RmUrl where

import Common.Annex
import Command
import Logs.Web

def :: [Command]
def = [notBareRepo $
	command "rmurl" (paramPair paramFile paramUrl) seek
		SectionCommon "record file is not available at url"]

seek :: CommandSeek
seek = withPairs start

start :: (FilePath, String) -> CommandStart
start (file, url) = flip whenAnnexed file $ \_ key -> do
	showStart "rmurl" file
	next $ next $ cleanup url key

cleanup :: String -> Key -> CommandCleanup
cleanup url key = do
	setUrlMissing key url
	return True


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

module Command.Schedule where

import Common.Annex
import qualified Annex
import Command
import qualified Remote
import Logs.Schedule
import Types.ScheduledActivity
import Types.Messages

import qualified Data.Set as S

def :: [Command]
def = [command "schedule" (paramPair paramRemote (paramOptional paramExpression)) seek
	SectionSetup "get or set scheduled jobs"]

seek :: CommandSeek
seek = withWords start

start :: [String] -> CommandStart
start = parse
  where
  	parse (name:[]) = go name performGet
	parse (name:expr:[]) = go name $ \uuid -> do
		showStart "schedile" name
		performSet expr uuid
	parse _ = error "Specify a repository."

	go name a = do
		u <- Remote.nameToUUID name
		next $ a u

performGet :: UUID -> CommandPerform
performGet uuid = do
	Annex.setOutput QuietOutput
	s <- scheduleGet uuid
	liftIO $ putStrLn $ intercalate "; " $
		map fromScheduledActivity $ S.toList s
	next $ return True

performSet :: String -> UUID -> CommandPerform
performSet expr uuid = case parseScheduledActivities expr of
	Left e -> error $ "Parse error: " ++ e
	Right l -> do
		scheduleSet uuid l
		next $ return True


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

module Command.Semitrust where

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

def :: [Command]
def = [command "semitrust" (paramRepeating paramRemote) seek
	SectionSetup "return repository to default trust level"]

seek :: CommandSeek
seek = trustCommand "semitrust" SemiTrusted


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

module Command.SendKey where

import Common.Annex
import Command
import Annex.Content
import Annex
import Utility.Rsync
import Annex.Transfer
import qualified CmdLine.GitAnnexShell.Fields as Fields
import Utility.Metered

def :: [Command]
def = [noCommit $ command "sendkey" paramKey seek
	SectionPlumbing "runs rsync in server mode to send content"]

seek :: CommandSeek
seek = withKeys start

start :: Key -> CommandStart
start key = do
	opts <- filterRsyncSafeOptions . maybe [] words
		<$> getField "RsyncOptions"
	ifM (inAnnex key)
		( fieldTransfer Upload key $ \_p ->
			sendAnnex key rollback $ liftIO . rsyncServerSend (map Param opts)
		, do
			warning "requested key is not present"
			liftIO exitFailure
		)
  where
	{- No need to do any rollback; when sendAnnex fails, a nonzero
	 - exit will be propigated, and the remote will know the transfer
	 - failed. -}
	rollback = noop

fieldTransfer :: Direction -> Key -> (MeterUpdate -> Annex Bool) -> CommandStart
fieldTransfer direction key a = do
	afile <- Fields.getField Fields.associatedFile
	ok <- maybe (a $ const noop)
		(\u -> runTransfer (Transfer direction (toUUID u) key) afile noRetry a)
		=<< Fields.getField Fields.remoteUUID
	liftIO $ exitBool ok


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

module Command.Status where

import Common.Annex
import Command
import Annex.CatFile
import Annex.Content.Direct
import Config
import qualified Git.LsFiles as LsFiles
import qualified Git.Ref
import qualified Git

def :: [Command]
def = [notBareRepo $ noCommit $ noMessages $ withOptions [jsonOption] $
	command "status" paramPaths seek SectionCommon
		"show the working tree status"]

seek :: CommandSeek
seek = withWords start

start :: [FilePath] -> CommandStart
start [] = do
	-- Like git status, when run without a directory, behave as if
	-- given the path to the top of the repository.
	currdir <- liftIO getCurrentDirectory
	top <- fromRepo Git.repoPath
	start' [relPathDirToFile currdir top]
start locs = start' locs

start' :: [FilePath] -> CommandStart
start' locs = do
	(l, cleanup) <- inRepo $ LsFiles.modifiedOthers locs
	getstatus <- ifM isDirect
		( return statusDirect
		, return $ Just <$$> statusIndirect
		)
	forM_ l $ \f -> maybe noop (showFileStatus f) =<< getstatus f
	void $ liftIO cleanup
	stop

data Status
	= NewFile
	| DeletedFile
	| ModifiedFile

showStatus :: Status -> String
showStatus NewFile = "?"
showStatus DeletedFile = "D"
showStatus ModifiedFile = "M"

showFileStatus :: FilePath -> Status -> Annex ()
showFileStatus f s  = unlessM (showFullJSON [("status", ss), ("file", f)]) $
	liftIO $ putStrLn $ ss ++ " " ++ f
  where
	ss = showStatus s

statusDirect :: FilePath -> Annex (Maybe Status)
statusDirect f = checkstatus =<< liftIO (catchMaybeIO $ getFileStatus f)
  where
	checkstatus Nothing = return $ Just DeletedFile
	checkstatus (Just s)
		-- Git thinks that present direct mode files modifed,
		-- so have to check.
		| not (isSymbolicLink s) = checkkey s =<< catKeyFile f
		| otherwise = Just <$> checkNew f

	checkkey s (Just k) = ifM (sameFileStatus k s)
		( return Nothing
		, return $ Just ModifiedFile
		)
	checkkey _ Nothing = Just <$> checkNew f

statusIndirect :: FilePath -> Annex Status
statusIndirect f = ifM (liftIO $ isJust <$> catchMaybeIO (getFileStatus f))
	( checkNew f
	, return DeletedFile
	)
  where

checkNew :: FilePath -> Annex Status
checkNew f = ifM (isJust <$> catObjectDetails (Git.Ref.fileRef f))
	( return ModifiedFile
	, return NewFile
	)


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

module Command.Sync where

import Common.Annex
import Command
import qualified Annex
import qualified Annex.Branch
import qualified Remote
import qualified Types.Remote as Remote
import Annex.Direct
import Annex.Hook
import qualified Git.Command
import qualified Git.LsFiles as LsFiles
import qualified Git.Branch
import qualified Git.Ref
import qualified Git
import qualified Remote.Git
import Config
import Annex.Wanted
import Annex.Content
import Command.Get (getKeyFile')
import qualified Command.Move
import Logs.Location
import Annex.Drop
import Annex.UUID
import Annex.AutoMerge
import Annex.Ssh

import Control.Concurrent.MVar

def :: [Command]
def = [withOptions syncOptions $
	command "sync" (paramOptional (paramRepeating paramRemote))
	seek SectionCommon "synchronize local repository with remotes"]

syncOptions :: [Option]
syncOptions = [ contentOption ]

contentOption :: Option
contentOption = flagOption [] "content" "also transfer file contents"

seek :: CommandSeek
seek rs = do
	prepMerge

	-- There may not be a branch checked out until after the commit,
	-- or perhaps after it gets merged from the remote.
	-- So only look it up once it's needed, and if once there is a
	-- branch, cache it.
	mvar <- liftIO newEmptyMVar
	let getbranch = ifM (liftIO $ isEmptyMVar mvar)
		( do
			branch <- inRepo Git.Branch.current
			when (isJust branch) $
				liftIO $ putMVar mvar branch
			return branch
		, liftIO $ readMVar mvar
		)
	let withbranch a = a =<< getbranch

	remotes <- syncRemotes rs
	let gitremotes = filter Remote.gitSyncableRemote remotes
	let dataremotes = filter (not . remoteAnnexIgnore . Remote.gitconfig) remotes

	-- Syncing involves many actions, any of which can independently
	-- fail, without preventing the others from running.
	seekActions $ return $ concat
		[ [ commit ]
		, [ withbranch mergeLocal ]
		, map (withbranch . pullRemote) gitremotes
		,  [ mergeAnnex ]
		]
	whenM (Annex.getFlag $ optionName contentOption) $
		whenM (seekSyncContent dataremotes) $
			-- Transferring content can take a while,
			-- and other changes can be pushed to the git-annex
			-- branch on the remotes in the meantime, so pull
			-- and merge again to avoid our push overwriting
			-- those changes.
			seekActions $ return $ concat
				[ map (withbranch . pullRemote) gitremotes
				, [ commitAnnex, mergeAnnex ]
				]
	seekActions $ return $ concat
		[ [ withbranch pushLocal ]
		, map (withbranch . pushRemote) gitremotes
		]

{- Merging may delete the current directory, so go to the top
 - of the repo. This also means that sync always acts on all files in the
 - repository, not just on a subdirectory. -}
prepMerge :: Annex ()
prepMerge = liftIO . setCurrentDirectory =<< fromRepo Git.repoPath

syncBranch :: Git.Ref -> Git.Ref
syncBranch = Git.Ref.under "refs/heads/synced" . fromDirectBranch

remoteBranch :: Remote -> Git.Ref -> Git.Ref
remoteBranch remote = Git.Ref.underBase $ "refs/remotes/" ++ Remote.name remote

syncRemotes :: [String] -> Annex [Remote]
syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted )
  where
	pickfast = (++) <$> listed <*> (filterM good =<< fastest <$> available)
	wanted
		| null rs = filterM good =<< concat . Remote.byCost <$> available
		| otherwise = listed
	listed = catMaybes <$> mapM (Remote.byName . Just) rs
	available = filter (remoteAnnexSync . Remote.gitconfig)
		. filter (not . Remote.isXMPPRemote)
		<$> Remote.remoteList
	good r
		| Remote.gitSyncableRemote r = Remote.Git.repoAvail $ Remote.repo r
		| otherwise = return True
	fastest = fromMaybe [] . headMaybe . Remote.byCost

commit :: CommandStart
commit = next $ next $ ifM isDirect
	( do
		showStart "commit" ""
		void stageDirect
		void preCommitDirect
		commitStaged Git.Branch.ManualCommit commitmessage
	, do
		showStart "commit" ""
		Annex.Branch.commit "update"
		inRepo $ Git.Branch.commitQuiet Git.Branch.ManualCommit
			[ Param "-a"
			, Param "-m"
			, Param commitmessage
			]
		return True
	)
  where
	commitmessage = "git-annex automatic sync"

commitStaged :: Git.Branch.CommitMode -> String -> Annex Bool
commitStaged commitmode commitmessage = go =<< inRepo Git.Branch.currentUnsafe
  where
	go Nothing = return False
	go (Just branch) = do
		runAnnexHook preCommitAnnexHook
		parent <- inRepo $ Git.Ref.sha branch
		void $ inRepo $ Git.Branch.commit commitmode False commitmessage branch
			(maybeToList parent)
		return True

mergeLocal :: Maybe Git.Ref -> CommandStart
mergeLocal Nothing = stop
mergeLocal (Just branch) = go =<< needmerge
  where
	syncbranch = syncBranch branch
	needmerge = ifM isBareRepo
		( return False
		, do
			unlessM (inRepo $ Git.Ref.exists syncbranch) $
				inRepo $ updateBranch syncbranch
			inRepo $ Git.Branch.changed branch syncbranch
		)
	go False = stop
	go True = do
		showStart "merge" $ Git.Ref.describe syncbranch
		next $ next $ autoMergeFrom syncbranch (Just branch) Git.Branch.ManualCommit

pushLocal :: Maybe Git.Ref -> CommandStart
pushLocal b = do
	updateSyncBranch b
	stop

updateSyncBranch :: Maybe Git.Ref -> Annex ()
updateSyncBranch Nothing = noop
updateSyncBranch (Just branch) = do
	-- Update the sync branch to match the new state of the branch
	inRepo $ updateBranch $ syncBranch branch
	-- In direct mode, we're operating on some special direct mode
	-- branch, rather than the intended branch, so update the indended
	-- branch.
	whenM isDirect $
		inRepo $ updateBranch $ fromDirectBranch branch

updateBranch :: Git.Ref -> Git.Repo -> IO ()
updateBranch syncbranch g =
	unlessM go $ error $ "failed to update " ++ Git.fromRef syncbranch
  where
	go = Git.Command.runBool
		[ Param "branch"
		, Param "-f"
		, Param $ Git.fromRef $ Git.Ref.base syncbranch
		] g

pullRemote :: Remote -> Maybe Git.Ref -> CommandStart
pullRemote remote branch = do
	showStart "pull" (Remote.name remote)
	next $ do
		showOutput
		stopUnless fetch $
			next $ mergeRemote remote branch
  where
	fetch = inRepoWithSshCachingTo (Remote.repo remote) $ Git.Command.runBool
		[Param "fetch", Param $ Remote.name remote]

{- The remote probably has both a master and a synced/master branch.
 - Which to merge from? Well, the master has whatever latest changes
 - were committed (or pushed changes, if this is a bare remote),
 - while the synced/master may have changes that some
 - other remote synced to this remote. So, merge them both. -}
mergeRemote :: Remote -> Maybe Git.Ref -> CommandCleanup
mergeRemote remote b = case b of
	Nothing -> do
		branch <- inRepo Git.Branch.currentUnsafe
		and <$> mapM (merge Nothing) (branchlist branch)
	Just thisbranch ->
		and <$> (mapM (merge (Just thisbranch)) =<< tomerge (branchlist b))
  where
	merge thisbranch br = autoMergeFrom (remoteBranch remote br) thisbranch Git.Branch.ManualCommit
	tomerge = filterM (changed remote)
	branchlist Nothing = []
	branchlist (Just branch) = [branch, syncBranch branch]

pushRemote :: Remote -> Maybe Git.Ref -> CommandStart
pushRemote _remote Nothing = stop
pushRemote remote (Just branch) = go =<< needpush
  where
	needpush
		| remoteAnnexReadOnly (Remote.gitconfig remote) = return False
		| otherwise = anyM (newer remote) [syncBranch branch, Annex.Branch.name]
	go False = stop
	go True = do
		showStart "push" (Remote.name remote)
		next $ next $ do
			showOutput
			ok <- inRepoWithSshCachingTo (Remote.repo remote) $
				pushBranch remote branch
			unless ok $ do
				warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ]
				showLongNote "(non-fast-forward problems can be solved by setting receive.denyNonFastforwards to false in the remote's git config)"
			return ok

{- Pushes a regular branch like master to a remote. Also pushes the git-annex
 - branch.
 -
 - If the remote is a bare git repository, it's best to push the regular
 - branch directly to it, so that cloning/pulling will get it.
 - On the other hand, if it's not bare, pushing to the checked out branch
 - will fail, and this is why we push to its syncBranch.
 -
 - Git offers no way to tell if a remote is bare or not, so both methods
 - are tried.
 -
 - The direct push is likely to spew an ugly error message, so stderr is
 - elided. Since git progress display goes to stderr too, the sync push
 - is done first, and actually sends the data. Then the direct push is
 - tried, with stderr discarded, to update the branch ref on the remote.
 -
 - The sync push forces the update of the remote synced/git-annex branch.
 - This is necessary if a transition has rewritten the git-annex branch.
 - Normally any changes to the git-annex branch get pulled and merged before
 - this push, so this forcing is unlikely to overwrite new data pushed
 - in from another repository that is also syncing.
 -
 - But overwriting of data on synced/git-annex can happen, in a race.
 - The only difference caused by using a forced push in that case is that
 - the last repository to push wins the race, rather than the first to push.
 -
 - The sync push will fail to overwrite if receive.denyNonFastforwards is
 - set on the remote.
 -}
pushBranch :: Remote -> Git.Ref -> Git.Repo -> IO Bool
pushBranch remote branch g = tryIO (directpush g) `after` syncpush g
  where
	syncpush = Git.Command.runBool $ pushparams
		[ Git.Branch.forcePush $ refspec Annex.Branch.name
		, refspec branch
		]
	directpush = Git.Command.runQuiet $ pushparams
		[Git.fromRef $ Git.Ref.base $ fromDirectBranch branch]
	pushparams branches =
		[ Param "push"
		, Param $ Remote.name remote
		] ++ map Param branches
	refspec b = concat
		[ Git.fromRef $ Git.Ref.base b
		,  ":"
		, Git.fromRef $ Git.Ref.base $ syncBranch b
		]

commitAnnex :: CommandStart
commitAnnex = do
	Annex.Branch.commit "update"
	stop

mergeAnnex :: CommandStart
mergeAnnex = do
	void Annex.Branch.forceUpdate
	stop

changed :: Remote -> Git.Ref -> Annex Bool
changed remote b = do
	let r = remoteBranch remote b
	ifM (inRepo $ Git.Ref.exists r)
		( inRepo $ Git.Branch.changed b r
		, return False
		)

newer :: Remote -> Git.Ref -> Annex Bool
newer remote b = do
	let r = remoteBranch remote b
	ifM (inRepo $ Git.Ref.exists r)
		( inRepo $ Git.Branch.changed r b
		, return True
		)

{- If it's preferred content, and we don't have it, get it from one of the
 - listed remotes (preferring the cheaper earlier ones).
 -
 - Send it to each remote that doesn't have it, and for which it's
 - preferred content.
 -
 - Drop it locally if it's not preferred content (honoring numcopies).
 -
 - Drop it from each remote that has it, where it's not preferred content
 - (honoring numcopies).
 -
 - If any file movements were generated, returns true.
 -}
seekSyncContent :: [Remote] -> Annex Bool
seekSyncContent rs = do
	mvar <- liftIO newEmptyMVar
	mapM_ (go mvar) =<< seekHelper LsFiles.inRepo []
	liftIO $ not <$> isEmptyMVar mvar
  where
	go mvar f = ifAnnexed f
		(\v -> void (liftIO (tryPutMVar mvar ())) >> syncFile rs f v)
		noop

syncFile :: [Remote] -> FilePath -> Key -> Annex ()
syncFile rs f k = do
	locs <- loggedLocations k
	let (have, lack) = partition (\r -> Remote.uuid r `elem` locs) rs

	got <- anyM id =<< handleget have
	putrs <- catMaybes . snd . unzip <$> (sequence =<< handleput lack)

	u <- getUUID
	let locs' = concat [[u | got], putrs, locs]

	-- Using callCommandAction rather than commandAction for drops,
	-- because a failure to drop does not mean the sync failed.
	handleDropsFrom locs' rs "unwanted" True k (Just f)
		Nothing callCommandAction
  where
  	wantget have = allM id
		[ pure (not $ null have)
		, not <$> inAnnex k
		, wantGet True (Just k) (Just f)
		]
	handleget have = ifM (wantget have)
		( return [ get have ]
		, return []
		)
	get have = commandAction $ do
		showStart "get" f
		next $ next $ getViaTmp k $ \dest -> getKeyFile' k (Just f) dest have

	wantput r
		| Remote.readonly r || remoteAnnexReadOnly (Remote.gitconfig r) = return False
		| otherwise = wantSend True (Just k) (Just f) (Remote.uuid r)
	handleput lack = ifM (inAnnex k)
		( map put <$> filterM wantput lack
		, return []
		)
	put dest = do
		ok <- commandAction $ do
			showStart "copy" f
			Command.Move.toStart' dest False (Just f) k
		return (ok, if ok then Just (Remote.uuid dest) else Nothing)


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

module Command.Test where

import Common
import Command
import Messages

def :: [Command]
def = [ noRepo startIO $ dontCheck repoExists $
	command "test" paramNothing seek SectionTesting
		"run built-in test suite"]

seek :: CommandSeek
seek = withWords start

{- We don't actually run the test suite here because of a dependency loop.
 - The main program notices when the command is test and runs it; this
 - function is never run if that works.
 -
 - However, if git-annex is built without the test suite, just print a
 - warning, and do not exit nonzero. This is so git-annex test can be run
 - in debian/rules despite some architectures not being able to build the
 - test suite.
 -}
start :: [String] -> CommandStart
start ps = do
	liftIO $ startIO ps
	stop

startIO :: CmdParams -> IO ()
startIO _ = warningIO "git-annex was built without its test suite; not testing"


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

module Command.TestRemote where

import Common
import Command
import qualified Annex
import qualified Remote
import qualified Types.Remote as Remote
import Types
import Types.Key (key2file, keyBackendName, keySize)
import Types.Backend (getKey, fsckKey)
import Types.KeySource
import Annex.Content
import Backend
import qualified Backend.Hash
import Utility.Tmp
import Utility.Metered
import Utility.DataUnits
import Utility.CopyFile
import Messages
import Types.Messages
import Remote.Helper.Chunked
import Locations

import Test.Tasty
import Test.Tasty.Runners
import Test.Tasty.HUnit
import Control.Exception
import Control.Concurrent
import Control.Concurrent.Async
import "crypto-api" Crypto.Random
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
import Data.Time.Clock
import Data.Tuple.Utils

def :: [Command]
def = [ withOptions [sizeOption] $
		command "testremote" paramRemote seek SectionTesting
			"test transfers to/from a remote"]

sizeOption :: Option
sizeOption = fieldOption [] "size" paramSize "base key size (default 1MiB)"

seek :: CommandSeek
seek ps = do
	basesz <- fromInteger . fromMaybe (1024 * 1024)
		<$> getOptionField sizeOption (pure . getsize)
	withWords (start basesz) ps
  where
	getsize v = v >>= readSize dataUnits

start :: Int -> [String] -> CommandStart
start basesz ws = do
	let name = unwords ws
	showStart "testremote" name
	r <- either error id <$> Remote.byName' name
	showSideAction "generating test keys"
	ks <- mapM randKey (keySizes basesz)
	rs <- catMaybes <$> mapM (adjustChunkSize r) (chunkSizes basesz)
	rs' <- concat <$> mapM encryptionVariants rs
	next $ perform rs' ks

perform :: [Remote] -> [Key] -> CommandPerform
perform rs ks = do
	st <- Annex.getState id
	let tests = testGroup "Remote Tests" $
		[ testGroup (desc r k) (test st r k) | k <- ks, r <- rs ]
	ok <- case tryIngredients [consoleTestReporter] mempty tests of
		Nothing -> error "No tests found!?"
		Just act -> liftIO act
	next $ cleanup rs ks ok
  where
	desc r' k = intercalate "; " $ map unwords
		[ [ "key size", show (keySize k) ]
		, [ show (chunkConfig (Remote.config r')) ]
		, ["encryption", fromMaybe "none" (M.lookup "encryption" (Remote.config r'))]
		]

adjustChunkSize :: Remote -> Int -> Annex (Maybe Remote)
adjustChunkSize r chunksize = adjustRemoteConfig r
	(M.insert "chunk" (show chunksize))

-- Variants of a remote with no encryption, and with simple shared
-- encryption. Gpg key based encryption is not tested.
encryptionVariants :: Remote -> Annex [Remote]
encryptionVariants r = do
	noenc <- adjustRemoteConfig r (M.insert "encryption" "none")
	sharedenc <- adjustRemoteConfig r $
		M.insert "encryption" "shared" .
		M.insert "highRandomQuality" "false"
	return $ catMaybes [noenc, sharedenc]

-- Regenerate a remote with a modified config.
adjustRemoteConfig :: Remote -> (Remote.RemoteConfig -> Remote.RemoteConfig) -> Annex (Maybe Remote)
adjustRemoteConfig r adjustconfig = Remote.generate (Remote.remotetype r)
	(Remote.repo r)
	(Remote.uuid r)
	(adjustconfig (Remote.config r))
	(Remote.gitconfig r)

test :: Annex.AnnexState -> Remote -> Key -> [TestTree]
test st r k =
	[ check "removeKey when not present" remove
	, present False
	, testCase "storeKey is atomic" $ do
		v <- runcheck $ storeKeyIsAtomic r k
		case v of
			Nothing -> warningIO "storeKey succeeded, but in too little time to verify that it was atomic. Increase --size to check."
			Just b -> b @? "failed"
	, present True
	, check "storeKey when already present" store
	, present True
	, check "retrieveKeyFile" $ do
		removeAnnex k
		get
	, check "fsck downloaded object" fsck
	, check "retrieveKeyFile resume from 33%" $ do
		loc <- Annex.calcRepo (gitAnnexLocation k)
		tmp <- prepTmp k
		partial <- liftIO $ bracket (openBinaryFile loc ReadMode) hClose $ \h -> do
			sz <- hFileSize h
			L.hGet h $ fromInteger $ sz `div` 3
		liftIO $ L.writeFile tmp partial
		removeAnnex k
		get
	, check "fsck downloaded object" fsck
	, check "retrieveKeyFile resume from 0" $ do
		tmp <- prepTmp k
		liftIO $ writeFile tmp ""
		removeAnnex k
		get
	, check "fsck downloaded object" fsck
	, check "retrieveKeyFile resume from end" $ do
		loc <- Annex.calcRepo (gitAnnexLocation k)
		tmp <- prepTmp k
		void $ liftIO $ copyFileExternal loc tmp
		removeAnnex k
		get
	, check "fsck downloaded object" fsck
	, check "removeKey when present" remove
	, present False
	]
  where
	check desc a = testCase desc $ runcheck a @? "failed"
	runcheck a = Annex.eval st (Annex.setOutput QuietOutput >> a)
	present b = check ("present " ++ show b) $
		(== Right b) <$> Remote.hasKey r k
	fsck = case maybeLookupBackendName (keyBackendName k) of
		Nothing -> return True
		Just b -> case fsckKey b of
			Nothing -> return True
			Just fscker -> fscker k (key2file k)
	get = getViaTmp k $ \dest ->
		Remote.retrieveKeyFile r k Nothing dest nullMeterUpdate
	store = Remote.storeKey r k Nothing nullMeterUpdate
	remove = Remote.removeKey r k

-- Test that storeKey does not cause hasKey to report the keys is
-- present until it's fully stored the object.
--
-- Method: Start a watching thread which checks hasKey repeatedly
-- and records the results along with the timestamp when hasKey was called.
-- Once the storeKey is done (and it must succeed), analize the record.
--
-- Some part of it will be after storeKey had fully sent the object,
-- so will show the object was present. So, throw out the last
-- half of the record, as well as throwing out any records
-- that are within 1 second of the end.
storeKeyIsAtomic :: Remote -> Key -> Annex (Maybe Bool)
storeKeyIsAtomic r k = do
	stopsignal <- liftIO newEmptyMVar

	-- To run the checker in a separate thread, need a new Annex state.
	st <- liftIO . Annex.new =<< Annex.fromRepo id
	c <- liftIO $ async $ checker st stopsignal []

	starttime <- liftIO getCurrentTime
	unlessM (Remote.storeKey r k Nothing nullMeterUpdate) $
		error "storeKey failed"
	liftIO $ do
		endtime <- getCurrentTime
		putMVar stopsignal ()
		record <- wait c
		return $ analize starttime endtime record
  where
	checker st stopsignal l = do
		starttime <- getCurrentTime
		(haskey, st') <- Annex.run st $
			(== Right True) <$> Remote.hasKey r k
		endtime <- getCurrentTime
		let l' = (haskey, starttime, endtime) : l
		threadDelay 10000 -- 1/100th of a second
		ifM (isEmptyMVar stopsignal)
			( checker st' stopsignal l'
			, return (reverse l')
			)

	analize starttime endtime record
		| null startrecord = Nothing
		| otherwise = Just $ all (not . fst3) startrecord
	  where
		middle = ((endtime `diffUTCTime` starttime) / 2) `addUTCTime` starttime
		nearend = (-1) `addUTCTime` endtime
		startrecord = filter (\(_, st, et) -> st < middle && et < nearend) record

cleanup :: [Remote] -> [Key] -> Bool -> CommandCleanup
cleanup rs ks ok = do
	forM_ rs $ \r -> forM_ ks (Remote.removeKey r)
	forM_ ks removeAnnex
	return ok

chunkSizes :: Int -> [Int]
chunkSizes base =
	[ 0 -- no chunking
	, base `div` 100
	, base `div` 1000
	, base
	]

keySizes :: Int -> [Int]
keySizes base = filter (>= 0)
	[ 0 -- empty key is a special case when chunking
	, base
	, base + 1
	, base - 1
	, base * 2
	]

randKey :: Int -> Annex Key
randKey sz = withTmpFile "randkey" $ \f h -> do
	gen <- liftIO (newGenIO :: IO SystemRandom)
	case genBytes sz gen of
		Left e -> error $ "failed to generate random key: " ++ show e
		Right (rand, _) -> liftIO $ B.hPut h rand
	liftIO $ hClose h
	let ks = KeySource
		{ keyFilename = f
		, contentLocation = f
		, inodeCache = Nothing
		}
	k <- fromMaybe (error "failed to generate random key")
		<$> getKey Backend.Hash.testKeyBackend ks
	moveAnnex k f
	return k


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

module Command.TransferInfo where

import Common.Annex
import Command
import Annex.Content
import Logs.Transfer
import Types.Key
import qualified CmdLine.GitAnnexShell.Fields as Fields
import Utility.Metered

def :: [Command]
def = [noCommit $ command "transferinfo" paramKey seek SectionPlumbing
	"updates sender on number of bytes of content received"]

seek :: CommandSeek
seek = withWords start

{- Security:
 -
 - The transfer info file contains the user-supplied key, but
 - the built-in guards prevent slashes in it from showing up in the filename.
 - It also contains the UUID of the remote. But slashes are also filtered
 - out of that when generating the filename.
 -
 - Checks that the key being transferred is inAnnex, to prevent
 - malicious spamming of bogus keys. Does not check that a transfer
 - of the key is actually in progress, because this could be started
 - concurrently with sendkey, and win the race.
 -}
start :: [String] -> CommandStart
start (k:[]) = do
	case file2key k of
		Nothing -> error "bad key"
		(Just key) -> whenM (inAnnex key) $ do
			file <- Fields.getField Fields.associatedFile
			u <- maybe (error "missing remoteuuid") toUUID
				<$> Fields.getField Fields.remoteUUID
			let t = Transfer
				{ transferDirection = Upload
				, transferUUID = u
				, transferKey = key
				}
			info <- liftIO $ startTransferInfo file
			(update, tfile, _) <- mkProgressUpdater t info
			liftIO $ mapM_ void
				[ tryIO $ forever $ do
					bytes <- readUpdate
					maybe (error "transferinfo protocol error")
						(update . toBytesProcessed) bytes
				, tryIO $ removeFile tfile
				, exitSuccess
				]
	stop
start _ = error "wrong number of parameters"

readUpdate :: IO (Maybe Integer)
readUpdate = readish <$> getLine


code:
{- git-annex plumbing command (for use by old assistant, and users)
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.TransferKey where

import Common.Annex
import Command
import Annex.Content
import Logs.Location
import Annex.Transfer
import qualified Remote
import Types.Remote

def :: [Command]
def = [withOptions transferKeyOptions $
	noCommit $ command "transferkey" paramKey seek SectionPlumbing
		"transfers a key from or to a remote"]

transferKeyOptions :: [Option]
transferKeyOptions = fileOption : fromToOptions

fileOption :: Option
fileOption = fieldOption [] "file" paramFile "the associated file"

seek :: CommandSeek
seek ps = do
	to <- getOptionField toOption Remote.byNameWithUUID
	from <- getOptionField fromOption Remote.byNameWithUUID
	file <- getOptionField fileOption return
	withKeys (start to from file) ps

start :: Maybe Remote -> Maybe Remote -> AssociatedFile -> Key -> CommandStart
start to from file key =
	case (from, to) of
		(Nothing, Just dest) -> next $ toPerform dest key file
		(Just src, Nothing) -> next $ fromPerform src key file
		_ -> error "specify either --from or --to"

toPerform :: Remote -> Key -> AssociatedFile -> CommandPerform
toPerform remote key file = go Upload file $
	upload (uuid remote) key file forwardRetry $ \p -> do
		ok <- Remote.storeKey remote key file p
		when ok $
			Remote.logStatus remote key InfoPresent
		return ok

fromPerform :: Remote -> Key -> AssociatedFile -> CommandPerform
fromPerform remote key file = go Upload file $
	download (uuid remote) key file forwardRetry $ \p ->
		getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p

go :: Direction -> AssociatedFile -> (NotifyWitness -> Annex Bool) -> CommandPerform
go direction file a = notifyTransfer direction file a >>= liftIO . exitBool


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

{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}

module Command.TransferKeys where

import Common.Annex
import Command
import Annex.Content
import Logs.Location
import Annex.Transfer
import qualified Remote
import Types.Key
import Utility.SimpleProtocol (ioHandles)
import Git.Types (RemoteName)

data TransferRequest = TransferRequest Direction Remote Key AssociatedFile

def :: [Command]
def = [command "transferkeys" paramNothing seek
	SectionPlumbing "transfers keys"]

seek :: CommandSeek
seek = withNothing start

start :: CommandStart
start = do
	(readh, writeh) <- liftIO ioHandles
	runRequests readh writeh runner
	stop
  where
	runner (TransferRequest direction remote key file)
		| direction == Upload = notifyTransfer direction file $
			upload (Remote.uuid remote) key file forwardRetry $ \p -> do
				ok <- Remote.storeKey remote key file p
				when ok $
					Remote.logStatus remote key InfoPresent
				return ok
		| otherwise = notifyTransfer direction file $
			download (Remote.uuid remote) key file forwardRetry $ \p ->
				getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p

runRequests
	:: Handle
	-> Handle
	-> (TransferRequest -> Annex Bool)
	-> Annex ()
runRequests readh writeh a = do
	liftIO $ do
		hSetBuffering readh NoBuffering
		fileEncoding readh
		fileEncoding writeh
	go =<< readrequests
  where
  	go (d:rn:k:f:rest) = do
		case (deserialize d, deserialize rn, deserialize k, deserialize f) of
			(Just direction, Just remotename, Just key, Just file) -> do
				mremote <- Remote.byName' remotename
				case mremote of
					Left _ -> sendresult False
					Right remote -> sendresult =<< a
						(TransferRequest direction remote key file)
			_ -> sendresult False
		go rest
	go [] = noop
	go [""] = noop
	go v = error $ "transferkeys protocol error: " ++ show v

	readrequests = liftIO $ split fieldSep <$> hGetContents readh
	sendresult b = liftIO $ do
		hPutStrLn writeh $ serialize b
		hFlush writeh

sendRequest :: Transfer -> TransferInfo -> Handle -> IO ()
sendRequest t info h = do
	hPutStr h $ intercalate fieldSep
		[ serialize (transferDirection t)
		, maybe (serialize (fromUUID (transferUUID t)))
			(serialize . Remote.name)
			(transferRemote info)
		, serialize (transferKey t)
		, serialize (associatedFile info)
		, "" -- adds a trailing null
		]
	hFlush h

readResponse :: Handle -> IO Bool
readResponse h = fromMaybe False . deserialize <$> hGetLine h

fieldSep :: String
fieldSep = "\0"

class TCSerialized a where
	serialize :: a -> String
	deserialize :: String -> Maybe a

instance TCSerialized Bool where
	serialize True = "1"
	serialize False = "0"
	deserialize "1" = Just True
	deserialize "0" = Just False
	deserialize _ = Nothing

instance TCSerialized Direction where
	serialize Upload = "u"
	serialize Download = "d"
	deserialize "u" = Just Upload
	deserialize "d" = Just Download
	deserialize _ = Nothing

instance TCSerialized AssociatedFile where
	serialize (Just f) = f
	serialize Nothing = ""
	deserialize "" = Just Nothing
	deserialize f = Just $ Just f

instance TCSerialized RemoteName where
	serialize n = n
	deserialize n = Just n

instance TCSerialized Key where
	serialize = key2file
	deserialize = file2key


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

module Command.Trust where

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

import qualified Data.Set as S

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

seek :: CommandSeek
seek = trustCommand "trust" Trusted

trustCommand :: String -> TrustLevel -> CommandSeek
trustCommand cmd level = withWords start
  where
	start ws = do
		let name = unwords ws
		showStart cmd name
		u <- Remote.nameToUUID name
		next $ perform u
	perform uuid = do
		trustSet uuid level
		when (level == DeadTrusted) $
			groupSet uuid S.empty
		l <- lookupTrust uuid
		when (l /= level) $
			warning $ "This remote's trust level is locally overridden to " ++ showTrustLevel l ++ " via git config."
		next $ return True