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

{-# LANGUAGE CPP #-}

module Command.Unannex where

import Common.Annex
import Command
import Config
import qualified Annex
import Annex.Content
import Annex.Content.Direct
import qualified Git.Command
import qualified Git.Branch
import qualified Git.Ref
import qualified Git.DiffTree as DiffTree
import Utility.CopyFile
import Command.PreCommit (lockPreCommitHook)

def :: [Command]
def = [command "unannex" paramPaths seek SectionUtility
		"undo accidential add command"]

seek :: CommandSeek
seek = wrapUnannex . (withFilesInGit $ whenAnnexed start)

wrapUnannex :: Annex a -> Annex a
wrapUnannex a = ifM isDirect
	( a
	{- Run with the pre-commit hook disabled, to avoid confusing
	 - behavior if an unannexed file is added back to git as
	 - a normal, non-annexed file and then committed.
	 - Otherwise, the pre-commit hook would think that the file
	 - has been unlocked and needs to be re-annexed.
	 -
	 - At the end, make a commit removing the unannexed files.
	 -}
	, ifM cleanindex
		( lockPreCommitHook $ commit `after` a
		, error "Cannot proceed with uncommitted changes staged in the index. Recommend you: git commit"
		)
	)
  where
	commit = inRepo $ Git.Branch.commitCommand Git.Branch.ManualCommit
		[ Param "-q"
		, Param "--allow-empty"
		, Param "--no-verify"
		, Param "-m", Param "content removed from git annex"
		]
	cleanindex = do
		(diff, cleanup) <- inRepo $ DiffTree.diffIndex Git.Ref.headRef
		if null diff
			then void (liftIO cleanup) >> return True
			else void (liftIO cleanup) >> return False

start :: FilePath -> Key -> CommandStart
start file key = stopUnless (inAnnex key) $ do
	showStart "unannex" file
	next $ ifM isDirect
		( performDirect file key
		, performIndirect file key)

performIndirect :: FilePath -> Key -> CommandPerform
performIndirect file key = do
	liftIO $ removeFile file
	inRepo $ Git.Command.run [Params "rm --cached --force --quiet --", File file]
	next $ cleanupIndirect file key

cleanupIndirect :: FilePath -> Key -> CommandCleanup
cleanupIndirect file key = do
	src <- calcRepo $ gitAnnexLocation key
	ifM (Annex.getState Annex.fast)
		( do
			-- Only make a hard link if the annexed file does not
			-- already have other hard links pointing at it.
			-- This avoids unannexing (and uninit) ending up
			-- hard linking files together, which would be
			-- surprising.
			s <- liftIO $ getFileStatus src
			if linkCount s > 1
				then copyfrom src
				else hardlinkfrom src
		, copyfrom src
		)
  where
	copyfrom src =
		thawContent file `after` liftIO (copyFileExternal src file)
	hardlinkfrom src =
#ifndef mingw32_HOST_OS
		-- creating a hard link could fall; fall back to copying
		ifM (liftIO $ catchBoolIO $ createLink src file >> return True)
			( return True
			, copyfrom src
			)
#else
		copyfrom src
#endif

performDirect :: FilePath -> Key -> CommandPerform
performDirect file key = do
	-- --force is needed when the file is not committed
	inRepo $ Git.Command.run [Params "rm --cached --force --quiet --", File file]
	next $ cleanupDirect file key

{- The direct mode file is not touched during unannex, so the content
 - is already where it needs to be, so this does not need to do anything
 - except remove it from the associated file map (which also updates
 - the location log if this was the last copy), and, if this was the last
 - associated file, remove the inode cache. -}
cleanupDirect :: FilePath -> Key -> CommandCleanup
cleanupDirect file key = do
	fs <- removeAssociatedFile key file
	when (null fs) $
		removeInodeCache key
	return True


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

module Command.Ungroup where

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

import qualified Data.Set as S

def :: [Command]
def = [command "ungroup" (paramPair paramRemote paramDesc) seek
	SectionSetup "remove a repository from a group"]

seek :: CommandSeek
seek = withWords start

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

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

repo_name: kakafarm/git

license: unknown


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

module Command.Uninit where

import Common.Annex
import qualified Annex
import Command
import qualified Git
import qualified Git.Command
import qualified Command.Unannex
import qualified Annex.Branch
import Annex.Content
import Annex.Init
import Utility.FileMode

import System.IO.HVFS
import System.IO.HVFS.Utils

def :: [Command]
def = [addCheck check $ command "uninit" paramPaths seek
	SectionUtility "de-initialize git-annex and clean out repository"]

check :: Annex ()
check = do
	b <- current_branch
	when (b == Annex.Branch.name) $ error $
		"cannot uninit when the " ++ Git.fromRef b ++ " branch is checked out"
	top <- fromRepo Git.repoPath
	currdir <- liftIO getCurrentDirectory
	whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $
		error "can only run uninit from the top of the git repository"
  where
	current_branch = Git.Ref . Prelude.head . lines <$> revhead
	revhead = inRepo $ Git.Command.pipeReadStrict
		[Params "rev-parse --abbrev-ref HEAD"]

seek :: CommandSeek
seek ps = do
	withFilesNotInGit False (whenAnnexed startCheckIncomplete) ps
	Annex.changeState $ \s -> s { Annex.fast = True }
	withFilesInGit (whenAnnexed Command.Unannex.start) ps
	finish

{- git annex symlinks that are not checked into git could be left by an
 - interrupted add. -}
startCheckIncomplete :: FilePath -> Key -> CommandStart
startCheckIncomplete file _ = error $ unlines
	[ file ++ " points to annexed content, but is not checked into git."
	, "Perhaps this was left behind by an interrupted git annex add?"
	, "Not continuing with uninit; either delete or git annex add the file and retry."
	]

finish :: Annex ()
finish = do
	annexdir <- fromRepo gitAnnexDir
	annexobjectdir <- fromRepo gitAnnexObjectDir
	leftovers <- removeUnannexed =<< getKeysPresent InAnnex
	liftIO $ prepareRemoveAnnexDir annexdir
	if null leftovers
		then liftIO $ removeDirectoryRecursive annexdir
		else error $ unlines
			[ "Not fully uninitialized"
			, "Some annexed data is still left in " ++ annexobjectdir
			, "This may include deleted files, or old versions of modified files."
			, ""
			, "If you don't care about preserving the data, just delete the"
			, "directory."
			, ""
			, "Or, you can move it to another location, in case it turns out"
			, "something in there is important."
			, ""
			, "Or, you can run `git annex unused` followed by `git annex dropunused`"
			, "to remove data that is not used by any tag or branch, which might"
			, "take care of all the data."
			, ""
			, "Then run `git annex uninit` again to finish."
			]
	uninitialize
	-- avoid normal shutdown
	saveState False
	inRepo $ Git.Command.run
		[Param "branch", Param "-D", Param $ Git.fromRef Annex.Branch.name]
	liftIO exitSuccess

{- Turn on write bits in all remaining files in the annex directory, in
 - preparation for removal. -}
prepareRemoveAnnexDir :: FilePath -> IO ()
prepareRemoveAnnexDir annexdir =
	recurseDir SystemFS annexdir >>= mapM_ (void . tryIO . allowWrite)

{- Keys that were moved out of the annex have a hard link still in the
 - annex, with > 1 link count, and those can be removed.
 -
 - Returns keys that cannot be removed. -}
removeUnannexed :: [Key] -> Annex [Key]
removeUnannexed = go []
  where
  	go c [] = return c
	go c (k:ks) = ifM (inAnnexCheck k $ liftIO . enoughlinks)
		( do
			removeAnnex k
			go c ks
		, go (k:c) ks
		)
	enoughlinks f = catchBoolIO $ do
		s <- getFileStatus f
		return $ linkCount s > 1


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

module Command.Unlock where

import Common.Annex
import Command
import Annex.Content
import Utility.CopyFile

def :: [Command]
def =
	[ c "unlock" "unlock files for modification"
	, c "edit" "same as unlock"
	]
  where
	c n = notDirect . command n paramPaths seek SectionCommon

seek :: CommandSeek
seek = withFilesInGit $ whenAnnexed start

{- The unlock subcommand replaces the symlink with a copy of the file's
 - content. -}
start :: FilePath -> Key -> CommandStart
start file key = do
	showStart "unlock" file
	next $ perform file key

perform :: FilePath -> Key -> CommandPerform
perform dest key = do
	unlessM (inAnnex key) $ error "content not present"
	unlessM (checkDiskSpace Nothing key 0) $ error "cannot unlock"

	src <- calcRepo $ gitAnnexLocation key
	tmpdest <- fromRepo $ gitAnnexTmpObjectLocation key
	liftIO $ createDirectoryIfMissing True (parentDir tmpdest)
	showAction "copying"
	ifM (liftIO $ copyFileExternal src tmpdest)
		( do
			liftIO $ do
				removeFile dest
				moveFile tmpdest dest
			thawContent dest
			next $ return True
		, error "copy failed!"
		)


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

module Command.Untrust where

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

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

seek :: CommandSeek
seek = trustCommand "untrust" UnTrusted


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

{-# LANGUAGE BangPatterns #-}

module Command.Unused where

import qualified Data.Set as S
import Control.Monad.ST
import qualified Data.Map as M

import Common.Annex
import Command
import Logs.Unused
import Annex.Content
import Logs.Location
import Logs.Transfer
import qualified Annex
import qualified Git
import qualified Git.Command
import qualified Git.Ref
import qualified Git.Branch
import qualified Git.LsFiles as LsFiles
import qualified Git.DiffTree as DiffTree
import qualified Backend
import qualified Remote
import qualified Annex.Branch
import Annex.CatFile
import Types.Key
import Git.FilePath
import Logs.View (is_branchView)
import Utility.Bloom

def :: [Command]
def = [withOptions [unusedFromOption] $ command "unused" paramNothing seek
	SectionMaintenance "look for unused file content"]

unusedFromOption :: Option
unusedFromOption = fieldOption ['f'] "from" paramRemote "remote to check for unused content"

seek :: CommandSeek
seek = withNothing start

{- Finds unused content in the annex. -}
start :: CommandStart
start = do
	from <- Annex.getField $ optionName unusedFromOption
	let (name, action) = case from of
		Nothing -> (".", checkUnused)
		Just "." -> (".", checkUnused)
		Just "here" -> (".", checkUnused)
		Just n -> (n, checkRemoteUnused n)
	showStart "unused" name
	next action

checkUnused :: CommandPerform
checkUnused = chain 0
	[ check "" unusedMsg $ findunused =<< Annex.getState Annex.fast
	, check "bad" staleBadMsg $ staleKeysPrune gitAnnexBadDir False
	, check "tmp" staleTmpMsg $ staleKeysPrune gitAnnexTmpObjectDir True
	]
  where
	findunused True = do
		showNote "fast mode enabled; only finding stale files"
		return []
	findunused False = do
		showAction "checking for unused data"
		-- InAnnex, not InRepository because if a direct mode
		-- file exists, it is obviously not unused.
		excludeReferenced =<< getKeysPresent InAnnex
	chain _ [] = next $ return True
	chain v (a:as) = do
		v' <- a v
		chain v' as

checkRemoteUnused :: String -> CommandPerform
checkRemoteUnused name = go =<< fromJust <$> Remote.byNameWithUUID (Just name)
  where
	go r = do
		showAction "checking for unused data"
		_ <- check "" (remoteUnusedMsg r) (remoteunused r) 0
		next $ return True
	remoteunused r = excludeReferenced <=< loggedKeysFor $ Remote.uuid r

check :: FilePath -> ([(Int, Key)] -> String) -> Annex [Key] -> Int -> Annex Int
check file msg a c = do
	l <- a
	let unusedlist = number c l
	unless (null l) $ showLongNote $ msg unusedlist
	updateUnusedLog file $ M.fromList unusedlist
	return $ c + length l

number :: Int -> [a] -> [(Int, a)]
number _ [] = []
number n (x:xs) = (n+1, x) : number (n+1) xs

table :: [(Int, Key)] -> [String]
table l = "  NUMBER  KEY" : map cols l
  where
	cols (n,k) = "  " ++ pad 6 (show n) ++ "  " ++ key2file k
	pad n s = s ++ replicate (n - length s) ' '

staleTmpMsg :: [(Int, Key)] -> String
staleTmpMsg t = unlines $
	["Some partially transferred data exists in temporary files:"]
	++ table t ++ [dropMsg Nothing]

staleBadMsg :: [(Int, Key)] -> String
staleBadMsg t = unlines $
	["Some corrupted files have been preserved by fsck, just in case:"]
	++ table t ++ [dropMsg Nothing]

unusedMsg :: [(Int, Key)] -> String
unusedMsg u = unusedMsg' u
	["Some annexed data is no longer used by any files:"]
	[dropMsg Nothing]
unusedMsg' :: [(Int, Key)] -> [String] -> [String] -> String
unusedMsg' u header trailer = unlines $
	header ++
	table u ++
	["(To see where data was previously used, try: git log --stat -S'KEY')"] ++
	trailer

remoteUnusedMsg :: Remote -> [(Int, Key)] -> String
remoteUnusedMsg r u = unusedMsg' u
	["Some annexed data on " ++ name ++ " is not used by any files:"]
	[dropMsg $ Just r]
  where
	name = Remote.name r

dropMsg :: Maybe Remote -> String
dropMsg Nothing = dropMsg' ""
dropMsg (Just r) = dropMsg' $ " --from " ++ Remote.name r
dropMsg' :: String -> String
dropMsg' s = "\nTo remove unwanted data: git-annex dropunused" ++ s ++ " NUMBER\n"

{- Finds keys in the list that are not referenced in the git repository.
 -
 - Strategy:
 -
 - * Build a bloom filter of all keys referenced by symlinks. This
 -   is the fastest one to build and will filter out most keys.
 - * If keys remain, build a second bloom filter of keys referenced by
 -   all branches.
 - * The list is streamed through these bloom filters lazily, so both will
 -   exist at the same time. This means that twice the memory is used,
 -   but they're relatively small, so the added complexity of using a
 -   mutable bloom filter does not seem worthwhile.
 - * Generating the second bloom filter can take quite a while, since
 -   it needs enumerating all keys in all git branches. But, the common
 -   case, if the second filter is needed, is for some keys to be globally
 -   unused, and in that case, no short-circuit is possible.
 -   Short-circuiting if the first filter filters all the keys handles the
 -   other common case.
 -}
excludeReferenced :: [Key] -> Annex [Key]
excludeReferenced ks = runfilter firstlevel ks >>= runfilter secondlevel
  where
	runfilter _ [] = return [] -- optimisation
	runfilter a l = bloomFilter show l <$> genBloomFilter show a
	firstlevel = withKeysReferencedM
	secondlevel = withKeysReferencedInGit

{- Finds items in the first, smaller list, that are not
 - present in the second, larger list.
 -
 - Constructing a single set, of the list that tends to be
 - smaller, appears more efficient in both memory and CPU
 - than constructing and taking the S.difference of two sets. -}
exclude :: Ord a => [a] -> [a] -> [a]
exclude [] _ = [] -- optimisation
exclude smaller larger = S.toList $ remove larger $ S.fromList smaller
  where
	remove a b = foldl (flip S.delete) b a

{- A bloom filter capable of holding half a million keys with a
 - false positive rate of 1 in 1000 uses around 8 mb of memory,
 - so will easily fit on even my lowest memory systems.
 -}
bloomCapacity :: Annex Int
bloomCapacity = fromMaybe 500000 . annexBloomCapacity <$> Annex.getGitConfig
bloomAccuracy :: Annex Int
bloomAccuracy = fromMaybe 1000 . annexBloomAccuracy <$> Annex.getGitConfig
bloomBitsHashes :: Annex (Int, Int)
bloomBitsHashes = do
	capacity <- bloomCapacity
	accuracy <- bloomAccuracy
	return $ suggestSizing capacity (1/ fromIntegral accuracy)

{- Creates a bloom filter, and runs an action, such as withKeysReferenced,
 - to populate it.
 -
 - The action is passed a callback that it can use to feed values into the
 - bloom filter.
 -
 - Once the action completes, the mutable filter is frozen
 - for later use.
 -}
genBloomFilter :: Hashable t => (v -> t) -> ((v -> Annex ()) -> Annex b) -> Annex (Bloom t)
genBloomFilter convert populate = do
	(numbits, numhashes) <- bloomBitsHashes
	bloom <- lift $ newMB (cheapHashes numhashes) numbits
	_ <- populate $ \v -> lift $ insertMB bloom (convert v)
	lift $ unsafeFreezeMB bloom
  where
	lift = liftIO . stToIO

bloomFilter :: Hashable t => (v -> t) -> [v] -> Bloom t -> [v]
bloomFilter convert l bloom = filter (\k -> convert k `notElemB` bloom) l

{- Given an initial value, folds it with each key referenced by
 - symlinks in the git repo. -}
withKeysReferenced :: v -> (Key -> v -> v) -> Annex v
withKeysReferenced initial a = withKeysReferenced' Nothing initial folda
  where
	folda k _ v = return $ a k v

{- Runs an action on each referenced key in the git repo. -}
withKeysReferencedM :: (Key -> Annex ()) -> Annex ()
withKeysReferencedM a = withKeysReferenced' Nothing () calla
  where
	calla k _ _ = a k

{- Folds an action over keys and files referenced in a particular directory. -}
withKeysFilesReferencedIn :: FilePath -> v -> (Key -> FilePath -> v -> Annex v) -> Annex v
withKeysFilesReferencedIn = withKeysReferenced' . Just

withKeysReferenced' :: Maybe FilePath -> v -> (Key -> FilePath -> v -> Annex v) -> Annex v
withKeysReferenced' mdir initial a = do
	(files, clean) <- getfiles
	r <- go initial files
	liftIO $ void clean
	return r
  where
	getfiles = case mdir of
		Nothing -> ifM isBareRepo
			( return ([], return True)
			, do
				top <- fromRepo Git.repoPath
				inRepo $ LsFiles.allFiles [top]
			)
		Just dir -> inRepo $ LsFiles.inRepo [dir]
	go v [] = return v
	go v (f:fs) = do
		x <- Backend.lookupFile f
		case x of
			Nothing -> go v fs
			Just k -> do
				!v' <- a k f v
				go v' fs

withKeysReferencedInGit :: (Key -> Annex ()) -> Annex ()
withKeysReferencedInGit a = do
	current <- inRepo Git.Branch.currentUnsafe
	shaHead <- maybe (return Nothing) (inRepo . Git.Ref.sha) current
	showref >>= mapM_ (withKeysReferencedInGitRef a) .
			relevantrefs (shaHead, current)
  where
	showref = inRepo $ Git.Command.pipeReadStrict [Param "show-ref"]
	relevantrefs headRef = addHead headRef .
		filter ourbranches .
		map (separate (== ' ')) .
		lines
	nubRefs = map (Git.Ref . snd) . nubBy (\(x, _) (y, _) -> x == y)
	ourbranchend = '/' : Git.fromRef Annex.Branch.name
	ourbranches (_, b) = not (ourbranchend `isSuffixOf` b)
		&& not ("refs/synced/" `isPrefixOf` b)
		&& not (is_branchView (Git.Ref b))
	addHead headRef refs = case headRef of
		-- if HEAD diverges from all branches (except the branch it
		-- points to), run the actions on staged keys (and keys
		-- that are only present in the work tree if the repo is
		-- non bare)
		(Just (Git.Ref x), Just (Git.Ref b))
			| all (\(x',b') -> x /= x' || b == b') refs ->
				Git.Ref.headRef
				: nubRefs (filter ((/= x) . fst) refs)
		_ -> nubRefs refs

{- Runs an action on keys referenced in the given Git reference which
 - differ from those referenced in the index. -}
withKeysReferencedInGitRef :: (Key -> Annex ()) -> Git.Ref -> Annex ()
withKeysReferencedInGitRef a ref = do
	showAction $ "checking " ++ Git.Ref.describe ref
	bare <- isBareRepo
	(ts,clean) <- inRepo $ if bare
			then DiffTree.diffIndex ref
			else DiffTree.diffWorkTree ref
	let lookAtWorkingTree = not bare && ref == Git.Ref.headRef
	forM_ ts $ tKey lookAtWorkingTree >=> maybe noop a
	liftIO $ void clean
  where
	tKey True = Backend.lookupFile . getTopFilePath . DiffTree.file
	tKey False = fileKey . takeFileName . decodeBS <$$>
		catFile ref . getTopFilePath . DiffTree.file

{- Looks in the specified directory for bad/tmp keys, and returns a list
 - of those that might still have value, or might be stale and removable.
 -
 - Also, stale keys that can be proven to have no value are deleted.
 -}
staleKeysPrune :: (Git.Repo -> FilePath) -> Bool -> Annex [Key]
staleKeysPrune dirspec nottransferred = do
	contents <- dirKeys dirspec

	dups <- filterM inAnnex contents
	let stale = contents `exclude` dups

	dir <- fromRepo dirspec
	liftIO $ forM_ dups $ \t -> removeFile $ dir </> keyFile t

	if nottransferred
		then do
			inprogress <- S.fromList . map (transferKey . fst)
				<$> getTransfers
			return $ filter (`S.notMember` inprogress) stale
		else return stale

data UnusedMaps = UnusedMaps
	{ unusedMap :: UnusedMap
	, unusedBadMap :: UnusedMap
	, unusedTmpMap :: UnusedMap
	}

withUnusedMaps :: (UnusedMaps -> Int -> CommandStart) -> CommandSeek
withUnusedMaps a params = do
	unused <- readUnusedMap ""
	unusedbad <- readUnusedMap "bad"
	unusedtmp <- readUnusedMap "tmp"
	let m = unused `M.union` unusedbad `M.union` unusedtmp
	let unusedmaps = UnusedMaps unused unusedbad unusedtmp
	seekActions $ return $ map (a unusedmaps) $
		concatMap (unusedSpec m) params

unusedSpec :: UnusedMap -> String -> [Int]
unusedSpec m spec
	| spec == "all" = if M.null m
		then []
		else [fst (M.findMin m)..fst (M.findMax m)]
	| "-" `isInfixOf` spec = range $ separate (== '-') spec
	| otherwise = maybe badspec (: []) (readish spec)
  where
	range (a, b) = case (readish a, readish b) of
		(Just x, Just y) -> [x..y]
		_ -> badspec
	badspec = error $ "Expected number or range, not \"" ++ spec ++ "\""

{- Seek action for unused content. Finds the number in the maps, and
 - calls one of 3 actions, depending on the type of unused file. -}
startUnused :: String
	-> (Key -> CommandPerform)
	-> (Key -> CommandPerform)
	-> (Key -> CommandPerform)
	-> UnusedMaps -> Int -> CommandStart
startUnused message unused badunused tmpunused maps n = search
	[ (unusedMap maps, unused)
	, (unusedBadMap maps, badunused)
	, (unusedTmpMap maps, tmpunused)
	]
  where
	search [] = error $ show n ++ " not valid (run git annex unused for list)"
	search ((m, a):rest) =
		case M.lookup n m of
			Nothing -> search rest
			Just key -> do
				showStart message (show n)
				next $ a key


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

module Command.Upgrade where

import Common.Annex
import Command
import Upgrade

def :: [Command]
def = [dontCheck repoExists $ -- because an old version may not seem to exist
	command "upgrade" paramNothing seek
		SectionMaintenance "upgrade repository layout"]

seek :: CommandSeek
seek = withNothing start

start :: CommandStart
start = do
	showStart "upgrade" "."
	r <- upgrade False
	next $ next $ return r


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

module Command.VAdd where

import Common.Annex
import Command
import Annex.View
import Command.View (checkoutViewBranch)

def :: [Command]
def = [notBareRepo $ notDirect $ command "vadd" (paramRepeating "FIELD=GLOB")
	seek SectionMetaData "add subdirs to current view"]

seek :: CommandSeek
seek = withWords start

start :: [String] -> CommandStart
start params = do
	showStart "vadd" ""
	withCurrentView $ \view -> do
		let (view', change) = refineView view $
			map parseViewParam $ reverse params
		case change of
			Unchanged -> do
				showNote "unchanged"
				next $ next $ return True
			Narrowing -> next $ next $ do
				if visibleViewSize view' == visibleViewSize view
					then error "That would not add an additional level of directory structure to the view. To filter the view, use vfilter instead of vadd."
					else checkoutViewBranch view' narrowView
			Widening -> error "Widening view to match more files is not currently supported."


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

module Command.VCycle where

import Common.Annex
import Command
import Annex.View
import Types.View
import Logs.View
import Command.View (checkoutViewBranch)

def :: [Command]
def = [notBareRepo $ notDirect $
	command "vcycle" paramNothing seek SectionUtility
	"switch view to next layout"]

seek :: CommandSeek
seek = withNothing start

start ::CommandStart
start = go =<< currentView
  where
	go Nothing = error "Not in a view."
	go (Just v) = do
		showStart "vcycle" ""
		let v' = v { viewComponents = vcycle [] (viewComponents v) }
		if v == v'
			then do
				showNote "unchanged"
				next $ next $ return True
			else next $ next $ checkoutViewBranch v' narrowView

	vcycle rest (c:cs)
		| viewVisible c = rest ++ cs ++ [c]
		| otherwise = vcycle (c:rest) cs
	vcycle rest c = rest ++ c


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

module Command.VFilter where

import Common.Annex
import Command
import Annex.View
import Command.View (paramView, checkoutViewBranch)

def :: [Command]
def = [notBareRepo $ notDirect $
	command "vfilter" paramView seek SectionMetaData "filter current view"]

seek :: CommandSeek
seek = withWords start

start :: [String] -> CommandStart
start params = do
	showStart "vfilter" ""
	withCurrentView $ \view -> do
		let view' = filterView view $
			map parseViewParam $ reverse params
		next $ next $ if visibleViewSize view' > visibleViewSize view
			then error "That would add an additional level of directory structure to the view, rather than filtering it. If you want to do that, use vadd instead of vfilter."
			else checkoutViewBranch view' narrowView


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

module Command.VPop where

import Common.Annex
import Command
import qualified Git
import qualified Git.Command
import qualified Git.Ref
import Types.View
import Logs.View
import Command.View (checkoutViewBranch)

def :: [Command]
def = [notBareRepo $ notDirect $
	command "vpop" (paramOptional paramNumber) seek SectionMetaData
	"switch back to previous view"]

seek :: CommandSeek
seek = withWords start

start :: [String] -> CommandStart
start ps = go =<< currentView
  where
	go Nothing = error "Not in a view."
	go (Just v) = do
		showStart "vpop" (show num)
		removeView v
		(oldvs, vs) <- splitAt (num - 1) . filter (sameparentbranch v)
			<$> recentViews
		mapM_ removeView oldvs
		case vs of
			(oldv:_) -> next $ next $ do
				showOutput
				checkoutViewBranch oldv (return . branchView)
			_ -> next $ next $ do
				showOutput
				inRepo $ Git.Command.runBool
					[ Param "checkout"
					, Param $ Git.fromRef $ Git.Ref.base $
						viewParentBranch v
					]
	sameparentbranch a b = viewParentBranch a == viewParentBranch b

	num = fromMaybe 1 $ readish =<< headMaybe ps


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

module Command.Version where

import Common.Annex
import Command
import qualified Build.SysConfig as SysConfig
import Annex.Version
import BuildFlags
import qualified Types.Backend as B
import qualified Types.Remote as R
import qualified Remote
import qualified Backend

def :: [Command]
def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $
	command "version" paramNothing seek SectionQuery "show version info"]

seek :: CommandSeek
seek = withNothing start

start :: CommandStart
start = do
	v <- getVersion
	liftIO $ do
		showPackageVersion
		info "local repository version" $ fromMaybe "unknown" v
		info "supported repository version" supportedVersion
		info "upgrade supported from repository versions" $
			unwords upgradableVersions
	stop

startNoRepo :: CmdParams -> IO ()
startNoRepo _ = showPackageVersion

showPackageVersion :: IO ()
showPackageVersion = do
	info "git-annex version" SysConfig.packageversion
	info "build flags" $ unwords buildFlags
	info "key/value backends" $ unwords $ map B.name Backend.list
	info "remote types" $ unwords $ map R.typename Remote.remoteTypes

info :: String -> String -> IO ()
info k v = putStrLn $ k ++ ": " ++ v


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

module Command.Vicfg where

import qualified Data.Map as M
import qualified Data.Set as S
import System.Environment (getEnv)
import Data.Tuple (swap)
import Data.Char (isSpace)

import Common.Annex
import Command
import Annex.Perms
import Types.TrustLevel
import Types.Group
import Logs.Trust
import Logs.Group
import Logs.PreferredContent
import Logs.Schedule
import Types.StandardGroups
import Types.ScheduledActivity
import Remote

def :: [Command]
def = [command "vicfg" paramNothing seek
	SectionSetup "edit git-annex's configuration"]

seek :: CommandSeek
seek = withNothing start

start :: CommandStart
start = do
	f <- fromRepo gitAnnexTmpCfgFile
	createAnnexDirectory $ parentDir f
	cfg <- getCfg
	descs <- uuidDescriptions
	liftIO $ writeFile f $ genCfg cfg descs
	vicfg cfg f
	stop

vicfg :: Cfg -> FilePath -> Annex ()
vicfg curcfg f = do
	vi <- liftIO $ catchDefaultIO "vi" $ getEnv "EDITOR"
	-- Allow EDITOR to be processed by the shell, so it can contain options.
	unlessM (liftIO $ boolSystem "sh" [Param "-c", Param $ unwords [vi, shellEscape f]]) $
		error $ vi ++ " exited nonzero; aborting"
	r <- parseCfg curcfg <$> liftIO (readFileStrict f)
	liftIO $ nukeFile f
	case r of
		Left s -> do
			liftIO $ writeFile f s
			vicfg curcfg f
		Right newcfg -> setCfg curcfg newcfg

data Cfg = Cfg
	{ cfgTrustMap :: TrustMap
	, cfgGroupMap :: M.Map UUID (S.Set Group)
	, cfgPreferredContentMap :: M.Map UUID PreferredContentExpression
	, cfgRequiredContentMap :: M.Map UUID PreferredContentExpression
	, cfgGroupPreferredContentMap :: M.Map Group PreferredContentExpression
	, cfgScheduleMap :: M.Map UUID [ScheduledActivity]
	}

getCfg :: Annex Cfg
getCfg = Cfg
	<$> trustMapRaw -- without local trust overrides
	<*> (groupsByUUID <$> groupMap)
	<*> preferredContentMapRaw
	<*> requiredContentMapRaw
	<*> groupPreferredContentMapRaw
	<*> scheduleMap

setCfg :: Cfg -> Cfg -> Annex ()
setCfg curcfg newcfg = do
	let diff = diffCfg curcfg newcfg
	mapM_ (uncurry trustSet) $ M.toList $ cfgTrustMap diff
	mapM_ (uncurry groupSet) $ M.toList $ cfgGroupMap diff
	mapM_ (uncurry preferredContentSet) $ M.toList $ cfgPreferredContentMap diff
	mapM_ (uncurry requiredContentSet) $ M.toList $ cfgRequiredContentMap diff
	mapM_ (uncurry groupPreferredContentSet) $ M.toList $ cfgGroupPreferredContentMap diff
	mapM_ (uncurry scheduleSet) $ M.toList $ cfgScheduleMap diff

diffCfg :: Cfg -> Cfg -> Cfg
diffCfg curcfg newcfg = Cfg
	{ cfgTrustMap = diff cfgTrustMap
	, cfgGroupMap = diff cfgGroupMap
	, cfgPreferredContentMap = diff cfgPreferredContentMap
	, cfgRequiredContentMap = diff cfgRequiredContentMap
	, cfgGroupPreferredContentMap = diff cfgGroupPreferredContentMap
	, cfgScheduleMap = diff cfgScheduleMap
	}
  where
	diff f = M.differenceWith (\x y -> if x == y then Nothing else Just x)
		(f newcfg) (f curcfg)

genCfg :: Cfg -> M.Map UUID String -> String
genCfg cfg descs = unlines $ intercalate [""]
	[ intro
	, trust
	, groups
	, preferredcontent
	, grouppreferredcontent
	, standardgroups
	, requiredcontent
	, schedule
	]
  where
	intro =
		[ com "git-annex configuration"
		, com ""
		, com "Changes saved to this file will be recorded in the git-annex branch."
		, com ""
		, com "Lines in this file have the format:"
		, com "  setting field = value"
		]

	trust = settings cfg descs cfgTrustMap
		[ com "Repository trust configuration"
		, com "(Valid trust levels: " ++ trustlevels ++ ")"
		]
		(\(t, u) -> line "trust" u $ showTrustLevel t)
		(\u -> lcom $ line "trust" u $ showTrustLevel SemiTrusted)
	  where
		trustlevels = unwords $ map showTrustLevel [Trusted .. DeadTrusted]

	groups = settings cfg descs cfgGroupMap
		[ com "Repository groups"
		, com $ "(Standard groups: " ++ grouplist ++ ")"
		, com "(Separate group names with spaces)"
		]
		(\(s, u) -> line "group" u $ unwords $ S.toList s)
		(\u -> lcom $ line "group" u "")
	  where
	  	grouplist = unwords $ map fromStandardGroup [minBound..]

	preferredcontent = settings cfg descs cfgPreferredContentMap
		[ com "Repository preferred contents"
		, com "(Set to \"standard\" to use a repository's group's preferred contents)"
		]
		(\(s, u) -> line "wanted" u s)
		(\u -> line "wanted" u "")

	requiredcontent = settings cfg descs cfgRequiredContentMap
		[ com "Repository required contents" ]
		(\(s, u) -> line "required" u s)
		(\u -> line "required" u "")

	grouppreferredcontent = settings' cfg allgroups cfgGroupPreferredContentMap
		[ com "Group preferred contents"
		, com "(Used by repositories with \"groupwanted\" in their preferred contents)"
		]
		(\(s, g) -> gline g s)
		(\g -> gline g "")
	  where
	  	gline g value = [ unwords ["groupwanted", g, "=", value] ]
		allgroups = S.unions $ stdgroups : M.elems (cfgGroupMap cfg)
		stdgroups = S.fromList $ map fromStandardGroup [minBound..maxBound]

	standardgroups =
		[ com "Standard preferred contents"
		, com "(Used by wanted or groupwanted expressions containing \"standard\")"
		, com "(For reference only; built-in and cannot be changed!)"
		]
		++ map gline [minBound..maxBound]
	  where
		gline g = com $ unwords
			[ "standard"
			, fromStandardGroup g, "=", standardPreferredContent g
			]

	schedule = settings cfg descs cfgScheduleMap
		[ com "Scheduled activities"
		, com "(Separate multiple activities with \"; \")"
		]
		(\(l, u) -> line "schedule" u $ fromScheduledActivities l)
		(\u -> line "schedule" u "")

	line setting u value =
		[ com $ "(for " ++ fromMaybe "" (M.lookup u descs) ++ ")"
		, unwords [setting, fromUUID u, "=", value]
		]

settings :: Ord v => Cfg -> M.Map UUID String -> (Cfg -> M.Map UUID v) -> [String] -> ((v, UUID) -> [String]) -> (UUID -> [String]) -> [String]
settings cfg descs = settings' cfg (M.keysSet descs)

settings' :: (Ord v, Ord f) => Cfg -> S.Set f -> (Cfg -> M.Map f v) -> [String] -> ((v, f) -> [String]) -> (f -> [String]) -> [String]
settings' cfg s field desc showvals showdefaults = concat
	[ desc
	, concatMap showvals $ sort $ map swap $ M.toList $ field cfg
	, concatMap (lcom . showdefaults) missing
	]
  where
	missing = S.toList $ s `S.difference` M.keysSet (field cfg)

lcom :: [String] -> [String]
lcom = map (\l -> if "#" `isPrefixOf` l then l else '#' : l)

{- If there's a parse error, returns a new version of the file,
 - with the problem lines noted. -}
parseCfg :: Cfg -> String -> Either String Cfg
parseCfg curcfg = go [] curcfg . lines
  where
	go c cfg []
		| null (mapMaybe fst c) = Right cfg
		| otherwise = Left $ unlines $
			badheader ++ concatMap showerr (reverse c)
	go c cfg (l:ls) = case parse (dropWhile isSpace l) cfg of
		Left msg -> go ((Just msg, l):c) cfg ls
		Right cfg' -> go ((Nothing, l):c) cfg' ls

	parse l cfg
		| null l = Right cfg
		| "#" `isPrefixOf` l = Right cfg
		| null setting || null f = Left "missing field"
		| otherwise = handle cfg f setting value'
	  where
		(setting, rest) = separate isSpace l
		(r, value) = separate (== '=') rest
		value' = trimspace value
		f = reverse $ trimspace $ reverse $ trimspace r
		trimspace = dropWhile isSpace

	handle cfg f setting value
		| setting == "trust" = case readTrustLevel value of
			Nothing -> badval "trust value" value
			Just t ->
				let m = M.insert u t (cfgTrustMap cfg)
				in Right $ cfg { cfgTrustMap = m }
		| setting == "group" =
			let m = M.insert u (S.fromList $ words value) (cfgGroupMap cfg)
			in Right $ cfg { cfgGroupMap = m }
		| setting == "wanted" =
			case checkPreferredContentExpression value of
				Just e -> Left e
				Nothing ->
					let m = M.insert u value (cfgPreferredContentMap cfg)
					in Right $ cfg { cfgPreferredContentMap = m }
		| setting == "required" =
			case checkPreferredContentExpression value of
				Just e -> Left e
				Nothing ->
					let m = M.insert u value (cfgRequiredContentMap cfg)
					in Right $ cfg { cfgRequiredContentMap = m }
		| setting == "groupwanted" =
			case checkPreferredContentExpression value of
				Just e -> Left e
				Nothing ->
					let m = M.insert f value (cfgGroupPreferredContentMap cfg)
					in Right $ cfg { cfgGroupPreferredContentMap = m }
		| setting == "schedule" = case parseScheduledActivities value of
			Left e -> Left e
			Right l ->
				let m = M.insert u l (cfgScheduleMap cfg)
				in Right $ cfg { cfgScheduleMap = m }
		| otherwise = badval "setting" setting
	  where
		u = toUUID f

	showerr (Just msg, l) = [parseerr ++ msg, l]
	showerr (Nothing, l)
		-- filter out the header and parse error lines
		-- from any previous parse failure
		| any (`isPrefixOf` l) (parseerr:badheader) = []
		| otherwise = [l]

	badval desc val = Left $ "unknown " ++ desc ++ " \"" ++ val ++ "\""
	badheader =
		[ com "** There was a problem parsing your input!"
		, com "** Search for \"Parse error\" to find the bad lines."
		, com "** Either fix the bad lines, or delete them (to discard your changes)."
		]
	parseerr = com "** Parse error in next line: "

com :: String -> String
com s = "# " ++ s


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

module Command.View where

import Common.Annex
import Command
import qualified Git
import qualified Git.Command
import qualified Git.Ref
import qualified Git.Branch
import Types.View
import Annex.View
import Logs.View

def :: [Command]
def = [notBareRepo $ notDirect $
	command "view" paramView seek SectionMetaData "enter a view branch"]

seek :: CommandSeek
seek = withWords start

start :: [String] -> CommandStart
start [] = error "Specify metadata to include in view"
start params = do
	showStart "view" ""
	view <- mkView params
	go view  =<< currentView
  where
	go view Nothing = next $ perform view
	go view (Just v)
		| v == view = stop
		| otherwise = error "Already in a view. Use the vfilter and vadd commands to further refine this view."

perform :: View -> CommandPerform
perform view = do
	showSideAction "searching"
	next $ checkoutViewBranch view applyView

paramView :: String
paramView = paramPair (paramRepeating "TAG") (paramRepeating "FIELD=VALUE")

mkView :: [String] -> Annex View
mkView params = go =<< inRepo Git.Branch.current
  where
	go Nothing = error "not on any branch!"
	go (Just b) = return $ fst $ refineView (View b []) $
		map parseViewParam $ reverse params

checkoutViewBranch :: View -> (View -> Annex Git.Branch) -> CommandCleanup
checkoutViewBranch view mkbranch = do
	oldcwd <- liftIO getCurrentDirectory

	{- Change to top of repository before creating view branch. -}
	liftIO . setCurrentDirectory =<< fromRepo Git.repoPath
	branch <- mkbranch view

	showOutput
	ok <- inRepo $ Git.Command.runBool
		[ Param "checkout"
		, Param (Git.fromRef $ Git.Ref.base branch)
		]
	when ok $ do
		setView view
		{- A git repo can easily have empty directories in it,
		 - and this pollutes the view, so remove them. -}
		liftIO $ removeemptydirs "."
		unlessM (liftIO $ doesDirectoryExist oldcwd) $ do
			top <- fromRepo Git.repoPath
			showLongNote (cwdmissing top)
	return ok
  where
	removeemptydirs top = mapM_ (tryIO . removeDirectory)
		=<< dirTreeRecursiveSkipping (".git" `isSuffixOf`) top
	cwdmissing top = unlines
		[ "This view does not include the subdirectory you are currently in."
		, "Perhaps you should:  cd " ++ top
		]


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

module Command.Wanted where

import Common.Annex
import qualified Annex
import Command
import qualified Remote
import Logs.PreferredContent
import Types.Messages

import qualified Data.Map as M

def :: [Command]
def = [command "wanted" (paramPair paramRemote (paramOptional paramExpression)) seek
	SectionSetup "get or set preferred content expression"]

seek :: CommandSeek
seek = withWords start

start :: [String] -> CommandStart
start = parse
  where
  	parse (name:[]) = go name performGet
	parse (name:expr:[]) = go name $ \uuid -> do
		showStart "wanted" 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
	m <- preferredContentMapRaw
	liftIO $ putStrLn $ fromMaybe "" $ M.lookup uuid m
	next $ return True

performSet :: String -> UUID -> CommandPerform
performSet expr uuid = case checkPreferredContentExpression expr of
	Just e -> error $ "Parse error: " ++ e
	Nothing -> do
		preferredContentSet uuid expr
		next $ return True


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

module Command.Watch where

import Common.Annex
import Assistant
import Command
import Utility.HumanTime

def :: [Command]
def = [notBareRepo $ withOptions [foregroundOption, stopOption] $
	command "watch" paramNothing seek SectionCommon "watch for changes"]

seek :: CommandSeek
seek ps = do
	stopdaemon <- getOptionFlag stopOption
	foreground <- getOptionFlag foregroundOption
	withNothing (start False foreground stopdaemon Nothing) ps

foregroundOption :: Option
foregroundOption = flagOption [] "foreground" "do not daemonize"

stopOption :: Option
stopOption = flagOption [] "stop" "stop daemon"

start :: Bool -> Bool -> Bool -> Maybe Duration -> CommandStart
start assistant foreground stopdaemon startdelay = do
	if stopdaemon
		then stopDaemon
		else startDaemon assistant foreground startdelay Nothing Nothing Nothing -- does not return
	stop


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

{-# LANGUAGE CPP #-}

module Command.WebApp where

import Common.Annex
import Command
import Assistant
import Assistant.Common
import Assistant.NamedThread
import Assistant.Threads.WebApp
import Assistant.WebApp
import Assistant.Install
import Annex.Environment
import Utility.WebApp
import Utility.Daemon (checkDaemon)
#ifdef __ANDROID__
import Utility.Env
#endif
import Annex.Init
import qualified Git
import qualified Git.Config
import qualified Git.CurrentRepo
import qualified Annex
import Config.Files
import Upgrade
import Annex.Version

import Control.Concurrent
import Control.Concurrent.STM
import Network.Socket (HostName)
import System.Environment (getArgs)

def :: [Command]
def = [ withOptions [listenOption] $
	noCommit $ noRepo startNoRepo $ dontCheck repoExists $ notBareRepo $
	command "webapp" paramNothing seek SectionCommon "launch webapp"]

listenOption :: Option
listenOption = fieldOption [] "listen" paramAddress
	"accept connections to this address"

seek :: CommandSeek
seek ps = do
	listenhost <- getOptionField listenOption return
	withNothing (start listenhost) ps

start :: Maybe HostName -> CommandStart
start = start' True

start' :: Bool -> Maybe HostName -> CommandStart
start' allowauto listenhost = do
	liftIO ensureInstalled
	ifM isInitialized
		( maybe notinitialized (go <=< needsUpgrade) =<< getVersion
		, if allowauto
			then liftIO $ startNoRepo []
			else notinitialized
		)
	stop
  where
	go cannotrun = do
		browser <- fromRepo webBrowser
		f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim
		listenhost' <- if isJust listenhost
			then pure listenhost
			else annexListen <$> Annex.getGitConfig
		ifM (checkpid <&&> checkshim f)
			( if isJust listenhost
				then error "The assistant is already running, so --listen cannot be used."
				else do
					url <- liftIO . readFile
						=<< fromRepo gitAnnexUrlFile
					liftIO $ if isJust listenhost'
						then putStrLn url
						else liftIO $ openBrowser browser f url Nothing Nothing
			, do
				startDaemon True True Nothing cannotrun listenhost' $ Just $
					\origout origerr url htmlshim ->
						if isJust listenhost'
							then maybe noop (`hPutStrLn` url) origout
							else openBrowser browser htmlshim url origout origerr
			)
	checkpid = do
		pidfile <- fromRepo gitAnnexPidFile
		liftIO $ isJust <$> checkDaemon pidfile
	checkshim f = liftIO $ doesFileExist f
	notinitialized = do
		g <- Annex.gitRepo
		liftIO $ cannotStartIn (Git.repoLocation g) "repository has not been initialized by git-annex"
		liftIO $ firstRun listenhost

{- When run without a repo, start the first available listed repository in
 - the autostart file. If none, it's our first time being run! -}
startNoRepo :: CmdParams -> IO ()
startNoRepo _ = do
	-- FIXME should be able to reuse regular getopt, but
	-- it currently runs in the Annex monad.
	args <- getArgs
	let listenhost = headMaybe $ map (snd . separate (== '=')) $
		filter ("--listen=" `isPrefixOf`) args

	go listenhost =<< liftIO (filterM doesDirectoryExist =<< readAutoStartFile)
  where
	go listenhost [] = firstRun listenhost
	go listenhost (d:ds) = do
		v <- tryNonAsync $ do
			setCurrentDirectory d
			Annex.new =<< Git.CurrentRepo.get
		case v of
			Left e -> do
				cannotStartIn d (show e)
				go listenhost ds
			Right state -> void $ Annex.eval state $ do
				whenM (fromRepo Git.repoIsLocalBare) $
					error $ d ++ " is a bare git repository, cannot run the webapp in it"
				callCommandAction $
					start' False listenhost

cannotStartIn :: FilePath -> String -> IO ()
cannotStartIn d reason = warningIO $ "unable to start webapp in repository " ++ d ++ ": " ++ reason

{- Run the webapp without a repository, which prompts the user, makes one,
 - changes to it, starts the regular assistant, and redirects the
 - browser to its url.
 -
 - This is a very tricky dance -- The first webapp calls the signaler,
 - which signals the main thread when it's ok to continue by writing to a
 - MVar. The main thread starts the second webapp, and uses its callback
 - to write its url back to the MVar, from where the signaler retrieves it,
 - returning it to the first webapp, which does the redirect.
 -
 - Note that it's important that mainthread never terminates! Much
 - of this complication is due to needing to keep the mainthread running.
 -}
firstRun :: Maybe HostName -> IO ()
firstRun listenhost = do
	checkEnvironmentIO
	{- Without a repository, we cannot have an Annex monad, so cannot
	 - get a ThreadState. Using undefined is only safe because the
	 - webapp checks its noAnnex field before accessing the
	 - threadstate. -}
	let st = undefined
	{- Get a DaemonStatus without running in the Annex monad. -}
	dstatus <- atomically . newTMVar =<< newDaemonStatus
	d <- newAssistantData st dstatus
	urlrenderer <- newUrlRenderer
	v <- newEmptyMVar
	let callback a = Just $ a v
	runAssistant d $ do
		startNamedThread urlrenderer $
			webAppThread d urlrenderer True Nothing
				(callback signaler)
				listenhost
				(callback mainthread)
		waitNamedThreads
  where
	signaler v = do
		putMVar v ""
		takeMVar v
	mainthread v url htmlshim
		| isJust listenhost = do
			putStrLn url
			hFlush stdout
			go
		| otherwise = do
			browser <- maybe Nothing webBrowser
				<$> catchDefaultIO Nothing Git.Config.global
			openBrowser browser htmlshim url Nothing Nothing
			go
	  where
		go = do
			_wait <- takeMVar v
			state <- Annex.new =<< Git.CurrentRepo.get
			Annex.eval state $
				startDaemon True True Nothing Nothing listenhost $ Just $
					sendurlback v
	sendurlback v _origout _origerr url _htmlshim = do
		recordUrl url
		putMVar v url

recordUrl :: String -> IO ()
#ifdef __ANDROID__
{- The Android app has a menu item that opens the url recorded
 - in this file. -}
recordUrl url = writeFile "/sdcard/git-annex.home/.git-annex-url" url
#else
recordUrl _ = noop
#endif

openBrowser :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO ()
#ifndef __ANDROID__
openBrowser mcmd htmlshim _realurl outh errh = runbrowser
#else
openBrowser mcmd htmlshim realurl outh errh = do
	recordUrl url
	{- Android's `am` command does not work reliably across the
	 - wide range of Android devices. Intead, FIFO should be set to
	 - the filename of a fifo that we can write the URL to. -}
	v <- getEnv "FIFO"
	case v of
		Nothing -> runbrowser
		Just f -> void $ forkIO $ do
			fd <- openFd f WriteOnly Nothing defaultFileFlags
			void $ fdWrite fd url
			closeFd fd
#endif
  where
	p = case mcmd of
		Just cmd -> proc cmd [htmlshim]
		Nothing ->
#ifndef mingw32_HOST_OS
			browserProc url
#else
			{- Windows hack to avoid using the full path,
			 - which might contain spaces that cause problems
			 - for browserProc. -}
			(browserProc (takeFileName htmlshim))
				{ cwd = Just (takeDirectory htmlshim) }
#endif
#ifdef __ANDROID__
	{- Android does not support file:// urls, but neither is
	 - the security of the url in the process table important
	 - there, so just use the real url. -}
	url = realurl
#else
	url = fileUrl htmlshim
#endif
	runbrowser = do
		hPutStrLn (fromMaybe stdout outh) $ "Launching web browser on " ++ url
		hFlush stdout
		environ <- cleanEnvironment
		(_, _, _, pid) <- createProcess p
			{ env = environ
			, std_out = maybe Inherit UseHandle outh
			, std_err = maybe Inherit UseHandle errh
			}
		exitcode <- waitForProcess pid
		unless (exitcode == ExitSuccess) $
			hPutStrLn (fromMaybe stderr errh) "failed to start web browser"

{- web.browser is a generic git config setting for a web browser program -}
webBrowser :: Git.Repo -> Maybe FilePath
webBrowser = Git.Config.getMaybe "web.browser"

fileUrl :: FilePath -> String
fileUrl file = "file://" ++ file


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

module Command.Whereis where

import qualified Data.Map as M

import Common.Annex
import Command
import Remote
import Logs.Trust

def :: [Command]
def = [noCommit $ withOptions (jsonOption : keyOptions) $
	command "whereis" paramPaths seek SectionQuery
		"lists repositories that have file content"]

seek :: CommandSeek
seek ps = do
	m <- remoteMap id
	withKeyOptions
		(startKeys m)
		(withFilesInGit $ whenAnnexed $ start m)
		ps

start :: M.Map UUID Remote -> FilePath -> Key -> CommandStart
start remotemap file key = start' remotemap key (Just file)

startKeys :: M.Map UUID Remote -> Key -> CommandStart
startKeys remotemap key = start' remotemap key Nothing

start' :: M.Map UUID Remote -> Key -> AssociatedFile -> CommandStart
start' remotemap key afile = do
	showStart' "whereis" key afile
	next $ perform remotemap key

perform :: M.Map UUID Remote -> Key -> CommandPerform
perform remotemap key = do
	locations <- keyLocations key
	(untrustedlocations, safelocations) <- trustPartition UnTrusted locations
	let num = length safelocations
	showNote $ show num ++ " " ++ copiesplural num
	pp <- prettyPrintUUIDs "whereis" safelocations
	unless (null safelocations) $ showLongNote pp
	pp' <- prettyPrintUUIDs "untrusted" untrustedlocations
	unless (null untrustedlocations) $ showLongNote $ untrustedheader ++ pp'
	forM_ (mapMaybe (`M.lookup` remotemap) locations) $
		performRemote key
	if null safelocations then stop else next $ return True
  where
	copiesplural 1 = "copy"
	copiesplural _ = "copies"
	untrustedheader = "The following untrusted locations may also have copies:\n"

performRemote :: Key -> Remote -> Annex ()
performRemote key remote = maybe noop go $ whereisKey remote
  where
	go a = do
		ls <- a key
		unless (null ls) $ showLongNote $ unlines $
			map (\l -> name remote ++ ": " ++ l) ls


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

module Command.XMPPGit where

import Common.Annex
import Command
import Assistant.XMPP.Git

def :: [Command]
def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $
	command "xmppgit" paramNothing seek
		SectionPlumbing "git to XMPP relay"]

seek :: CommandSeek
seek = withWords start

start :: [String] -> CommandStart
start _ = do
	liftIO gitRemoteHelper
	liftIO xmppGitRelay
	stop

startNoRepo :: CmdParams -> IO ()
startNoRepo _ = xmppGitRelay

{- A basic implementation of the git-remote-helpers protocol. -}
gitRemoteHelper :: IO ()
gitRemoteHelper = do
	expect "capabilities"
	respond ["connect"]
	expect "connect git-receive-pack"
	respond []
  where
	expect s = do
		cmd <- getLine
		unless (cmd == s) $
			error $ "git-remote-helpers protocol error: expected: " ++ s ++ ", but got: " ++ cmd
	respond l = do
		mapM_ putStrLn l
		putStrLn ""
		hFlush stdout


code:
{-# LANGUAGE PackageImports, CPP #-}

module Common (module X) where

import Control.Monad as X
import Control.Monad.IfElse as X
import Control.Applicative as X
import "mtl" Control.Monad.State.Strict as X (liftIO)
import Control.Exception.Extensible as X (IOException)

import Data.Maybe as X
import Data.List as X hiding (head, tail, init, last)
import Data.String.Utils as X hiding (join)
import Data.Monoid as X

import System.FilePath as X
import System.Directory as X
import System.IO as X hiding (FilePath)
#ifndef mingw32_HOST_OS
import System.Posix.IO as X
#endif
import System.Exit as X

import Utility.Misc as X
import Utility.Exception as X
import Utility.SafeCommand as X
import Utility.Process as X
import Utility.Path as X
import Utility.Directory as X
import Utility.Monad as X
import Utility.Data as X
import Utility.Applicative as X
import Utility.FileSystemEncoding as X
import Utility.PosixFiles as X
import Utility.Network as X

import Utility.PartialPrelude as X


code:
module Common.Annex (module X) where

import Common as X
import Types as X
import Types.UUID as X (toUUID, fromUUID)
import Annex as X (gitRepo, inRepo, fromRepo, calcRepo)
import Locations as X
import Messages as X


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

module Config where

import Common.Annex
import qualified Git
import qualified Git.Config
import qualified Git.Command
import qualified Annex
import Config.Cost
import Types.Availability

type UnqualifiedConfigKey = String
data ConfigKey = ConfigKey String

instance Show ConfigKey where
	show (ConfigKey s) = s

{- Looks up a setting in git config. -}
getConfig :: ConfigKey -> String -> Annex String
getConfig (ConfigKey key) def = fromRepo $ Git.Config.get key def

getConfigMaybe :: ConfigKey -> Annex (Maybe String)
getConfigMaybe (ConfigKey key) = fromRepo $ Git.Config.getMaybe key

{- Changes a git config setting in both internal state and .git/config -}
setConfig :: ConfigKey -> String -> Annex ()
setConfig (ConfigKey key) value = do
	inRepo $ Git.Command.run [Param "config", Param key, Param value]
	reloadConfig

reloadConfig :: Annex ()
reloadConfig = Annex.changeGitRepo =<< inRepo Git.Config.reRead

{- Unsets a git config setting. (Leaves it in state currently.) -}
unsetConfig :: ConfigKey -> Annex ()
unsetConfig ck@(ConfigKey key) = ifM (isJust <$> getConfigMaybe ck)
	( inRepo $ Git.Command.run
		[Param "config", Param "--unset", Param key]
	, noop -- avoid unsetting something not set; that would fail
	)

{- A per-remote config setting in git config. -}
remoteConfig :: Git.Repo -> UnqualifiedConfigKey -> ConfigKey
remoteConfig r key = ConfigKey $
	"remote." ++ fromMaybe "" (Git.remoteName r) ++ ".annex-" ++ key

{- A global annex setting in git config. -}
annexConfig :: UnqualifiedConfigKey -> ConfigKey
annexConfig key = ConfigKey $ "annex." ++ key

{- Calculates cost for a remote. Either the specific default, or as configured
 - by remote.<name>.annex-cost, or if remote.<name>.annex-cost-command
 - is set and prints a number, that is used. -}
remoteCost :: RemoteGitConfig -> Cost -> Annex Cost
remoteCost c def = fromMaybe def <$> remoteCost' c

remoteCost' :: RemoteGitConfig -> Annex (Maybe Cost)
remoteCost' c = case remoteAnnexCostCommand c of
	Just cmd | not (null cmd) -> liftIO $
		readish <$> readProcess "sh" ["-c", cmd]
	_ -> return $ remoteAnnexCost c

setRemoteCost :: Git.Repo -> Cost -> Annex ()
setRemoteCost r c = setConfig (remoteConfig r "cost") (show c)

setRemoteAvailability :: Git.Repo -> Availability -> Annex ()
setRemoteAvailability r c = setConfig (remoteConfig r "availability") (show c)

isDirect :: Annex Bool
isDirect = annexDirect <$> Annex.getGitConfig

crippledFileSystem :: Annex Bool
crippledFileSystem = annexCrippledFileSystem <$> Annex.getGitConfig

setCrippledFileSystem :: Bool -> Annex ()
setCrippledFileSystem b = do
	setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b)
	Annex.changeGitConfig $ \c -> c { annexCrippledFileSystem = b }


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

module Config.Cost where

{- We use a float for a cost to ensure that there is a cost in
 - between any two other costs. -}
type Cost = Float

{- Some predefined default costs.
 - Users setting costs in config files can be aware of these,
 - and pick values relative to them. So don't change. -}
cheapRemoteCost :: Cost
cheapRemoteCost = 100
nearlyCheapRemoteCost :: Cost
nearlyCheapRemoteCost = 110
semiExpensiveRemoteCost :: Cost
semiExpensiveRemoteCost = 175
expensiveRemoteCost :: Cost
expensiveRemoteCost = 200
veryExpensiveRemoteCost :: Cost
veryExpensiveRemoteCost = 1000

{- Adjusts a remote's cost to reflect it being encrypted. -}
encryptedRemoteCostAdj :: Cost
encryptedRemoteCostAdj = 50

{- Given an ordered list of costs, and the position of one of the items
 - the list, inserts a new cost into the list, in between the item
 - and the item after it.
 -
 - If two or move items have the same cost, their costs are adjusted
 - to make room. The costs of other items in the list are left
 - unchanged.
 -
 - To insert the new cost before any other in the list, specify a negative
 - position. To insert the new cost at the end of the list, specify a
 - position longer than the list.
 -}
insertCostAfter :: [Cost] -> Int -> [Cost]
insertCostAfter [] _ = []
insertCostAfter l pos
	| pos < 0 = costBetween 0 (l !! 0) : l
	| nextpos > maxpos = l ++ [1 + l !! maxpos]
	| item == nextitem =
		let (_dup:new:l') = insertCostAfter lastsegment 0
		in firstsegment ++ [costBetween item new, new] ++ l'
	| otherwise =
		firstsegment ++ [costBetween item nextitem ] ++ lastsegment
  where
  	nextpos = pos + 1
	maxpos = length l - 1

	item = l !! pos
	nextitem = l !! nextpos

	(firstsegment, lastsegment) = splitAt (pos + 1) l

costBetween :: Cost -> Cost -> Cost
costBetween x y
	| x == y = x
	| x > y = -- avoid fractions unless needed
		let mid = y + (x - y) / 2
		    mid' = fromIntegral (floor mid :: Int)
		in if mid' > y then mid' else mid
	| otherwise = costBetween y x

{- Make sure the remote cost numbers work out. -}
prop_cost_sane :: Bool
prop_cost_sane = False `notElem`
	[ expensiveRemoteCost > 0
	, cheapRemoteCost < nearlyCheapRemoteCost
	, nearlyCheapRemoteCost < semiExpensiveRemoteCost
	, semiExpensiveRemoteCost < expensiveRemoteCost
	, cheapRemoteCost + encryptedRemoteCostAdj > nearlyCheapRemoteCost
	, nearlyCheapRemoteCost + encryptedRemoteCostAdj < semiExpensiveRemoteCost
	, nearlyCheapRemoteCost + encryptedRemoteCostAdj < expensiveRemoteCost
	]


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

module Config.Files where

import Common
import Utility.Tmp
import Utility.FreeDesktop

{- ~/.config/git-annex/file -}
userConfigFile :: FilePath -> IO FilePath
userConfigFile file = do
	dir <- userConfigDir
	return $ dir </> "git-annex" </> file

autoStartFile :: IO FilePath
autoStartFile = userConfigFile "autostart"

{- Returns anything listed in the autostart file (which may not exist). -}
readAutoStartFile :: IO [FilePath]
readAutoStartFile = do
	f <- autoStartFile
	nub . map dropTrailingPathSeparator . lines
		<$> catchDefaultIO "" (readFile f)

modifyAutoStartFile :: ([FilePath] -> [FilePath]) -> IO ()
modifyAutoStartFile func = do
	dirs <- readAutoStartFile
	let dirs' = nubBy equalFilePath $ func dirs
	when (dirs' /= dirs) $ do
		f <- autoStartFile
		createDirectoryIfMissing True (parentDir f)
		viaTmp writeFile f $ unlines dirs'

{- Adds a directory to the autostart file. If the directory is already
 - present, it's moved to the top, so it will be used as the default
 - when opening the webapp. -}
addAutoStartFile :: FilePath -> IO ()
addAutoStartFile path = modifyAutoStartFile $ (:) path

{- Removes a directory from the autostart file. -}
removeAutoStartFile :: FilePath -> IO ()
removeAutoStartFile path = modifyAutoStartFile $
	filter (not . equalFilePath path)

{- The path to git-annex is written here; which is useful when cabal
 - has installed it to some awful non-PATH location. -}
programFile :: IO FilePath
programFile = userConfigFile "program"

{- Returns a command to run for git-annex. -}
readProgramFile :: IO FilePath
readProgramFile = do
	programfile <- programFile
	p <- catchDefaultIO cmd $
		fromMaybe cmd . headMaybe . lines <$> readFile programfile
	ifM (inPath p)
		( return p
		, ifM (inPath cmd)
			( return cmd
			, error $ "cannot find git-annex program in PATH or in the location listed in " ++ programfile
			)
		)
  where
  	cmd = "git-annex"


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

module Config.NumCopies (
	module Types.NumCopies,
	module Logs.NumCopies,
	getFileNumCopies,
	getGlobalFileNumCopies,
	getNumCopies,
	numCopiesCheck,
	deprecatedNumCopies,
	defaultNumCopies
) where

import Common.Annex
import qualified Annex
import Types.NumCopies
import Logs.NumCopies
import Logs.Trust
import Annex.CheckAttr
import qualified Remote

defaultNumCopies :: NumCopies
defaultNumCopies = NumCopies 1

fromSources :: [Annex (Maybe NumCopies)] -> Annex NumCopies
fromSources = fromMaybe defaultNumCopies <$$> getM id

{- The git config annex.numcopies is deprecated. -}
deprecatedNumCopies :: Annex (Maybe NumCopies)
deprecatedNumCopies = annexNumCopies <$> Annex.getGitConfig

{- Value forced on the command line by --numcopies. -}
getForcedNumCopies :: Annex (Maybe NumCopies)
getForcedNumCopies = Annex.getState Annex.forcenumcopies

{- Numcopies value from any of the non-.gitattributes configuration
 - sources. -}
getNumCopies :: Annex NumCopies
getNumCopies = fromSources
	[ getForcedNumCopies
	, getGlobalNumCopies
	, deprecatedNumCopies
	]

{- Numcopies value for a file, from any configuration source, including the
 - deprecated git config. -}
getFileNumCopies :: FilePath -> Annex NumCopies
getFileNumCopies f = fromSources
	[ getForcedNumCopies
	, getFileNumCopies' f
	, deprecatedNumCopies
	]

{- This is the globally visible numcopies value for a file. So it does
 - not include local configuration in the git config or command line
 - options. -}
getGlobalFileNumCopies :: FilePath  -> Annex NumCopies
getGlobalFileNumCopies f = fromSources
	[ getFileNumCopies' f
	]

getFileNumCopies' :: FilePath  -> Annex (Maybe NumCopies)
getFileNumCopies' file = maybe getGlobalNumCopies (return . Just) =<< getattr
  where
	getattr = (NumCopies <$$> readish)
		<$> checkAttr "annex.numcopies" file

{- Checks if numcopies are satisfied for a file by running a comparison
 - between the number of (not untrusted) copies that are
 - belived to exist, and the configured value. -}
numCopiesCheck :: FilePath -> Key -> (Int -> Int -> v) -> Annex v
numCopiesCheck file key vs = do
	NumCopies needed <- getFileNumCopies file
	have <- trustExclude UnTrusted =<< Remote.keyLocations key
	return $ length have `vs` needed


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

module Creds (
	module Types.Creds,
	CredPairStorage(..),
	setRemoteCredPair,
	getRemoteCredPairFor,
	getRemoteCredPair,
	getEnvCredPair,
	writeCacheCreds,
	readCacheCreds,
	removeCreds,
) where

import Common.Annex
import Types.Creds
import Annex.Perms
import Utility.FileMode
import Crypto
import Types.Remote (RemoteConfig, RemoteConfigKey)
import Remote.Helper.Encryptable (remoteCipher, embedCreds)
import Utility.Env (getEnv)

import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Map as M
import Utility.Base64

{- A CredPair can be stored in a file, or in the environment, or perhaps
 - in a remote's configuration. -}
data CredPairStorage = CredPairStorage
	{ credPairFile :: FilePath
	, credPairEnvironment :: (String, String)
	, credPairRemoteKey :: Maybe RemoteConfigKey
	}

{- Stores creds in a remote's configuration, if the remote allows
 - that. Otherwise, caches them locally.
 - The creds are found in storage if not provided. -}
setRemoteCredPair :: RemoteConfig -> CredPairStorage -> Maybe CredPair -> Annex RemoteConfig
setRemoteCredPair c storage Nothing =
	maybe (return c) (setRemoteCredPair c storage . Just)
		=<< getRemoteCredPair c storage
setRemoteCredPair c storage (Just creds)
	| embedCreds c = case credPairRemoteKey storage of
		Nothing -> localcache
		Just key -> storeconfig key =<< remoteCipher c
	| otherwise = localcache
  where
	localcache = do
		writeCacheCredPair creds storage
		return c

	storeconfig key (Just cipher) = do
		s <- liftIO $ encrypt (getGpgEncParams c) cipher
			(feedBytes $ L.pack $ encodeCredPair creds)
			(readBytes $ return . L.unpack)
		return $ M.insert key (toB64 s) c
	storeconfig key Nothing =
		return $ M.insert key (toB64 $ encodeCredPair creds) c

{- Gets a remote's credpair, from the environment if set, otherwise
 - from the cache in gitAnnexCredsDir, or failing that, from the
 - value in RemoteConfig. -}
getRemoteCredPairFor :: String -> RemoteConfig -> CredPairStorage -> Annex (Maybe CredPair)
getRemoteCredPairFor this c storage = maybe missing (return . Just) =<< getRemoteCredPair c storage
  where
	(loginvar, passwordvar) = credPairEnvironment storage
	missing = do
		warning $ unwords
			[ "Set both", loginvar
			, "and", passwordvar
			, "to use", this
			]
		return Nothing

getRemoteCredPair :: RemoteConfig -> CredPairStorage -> Annex (Maybe CredPair)
getRemoteCredPair c storage = maybe fromcache (return . Just) =<< fromenv
  where
	fromenv = liftIO $ getEnvCredPair storage
	fromcache = maybe fromconfig (return . Just) =<< readCacheCredPair storage
	fromconfig = case credPairRemoteKey storage of
		Just key -> do
			mcipher <- remoteCipher c
			case (M.lookup key c, mcipher) of
				(Nothing, _) -> return Nothing
				(Just enccreds, Just cipher) -> do
					creds <- liftIO $ decrypt cipher
						(feedBytes $ L.pack $ fromB64 enccreds)
						(readBytes $ return . L.unpack)
					fromcreds creds
				(Just bcreds, Nothing) ->
					fromcreds $ fromB64 bcreds
		Nothing -> return Nothing
	fromcreds creds = case decodeCredPair creds of
		Just credpair -> do
			writeCacheCredPair credpair storage
			return $ Just credpair
		_ -> error "bad creds"

{- Gets a CredPair from the environment. -}
getEnvCredPair :: CredPairStorage -> IO (Maybe CredPair)
getEnvCredPair storage = liftM2 (,)
	<$> getEnv uenv
	<*> getEnv penv
  where
	(uenv, penv) = credPairEnvironment storage

writeCacheCredPair :: CredPair -> CredPairStorage -> Annex ()
writeCacheCredPair credpair storage =
	writeCacheCreds (encodeCredPair credpair) (credPairFile storage)

{- Stores the creds in a file inside gitAnnexCredsDir that only the user
 - can read. -}
writeCacheCreds :: Creds -> FilePath -> Annex ()
writeCacheCreds creds file = do
	d <- fromRepo gitAnnexCredsDir
	createAnnexDirectory d
	liftIO $ writeFileProtected (d </> file) creds

readCacheCredPair :: CredPairStorage -> Annex (Maybe CredPair)
readCacheCredPair storage = maybe Nothing decodeCredPair
	<$> readCacheCreds (credPairFile storage)

readCacheCreds :: FilePath -> Annex (Maybe Creds)
readCacheCreds file = do
	d <- fromRepo gitAnnexCredsDir
	let f = d </> file
	liftIO $ catchMaybeIO $ readFile f

encodeCredPair :: CredPair -> Creds
encodeCredPair (l, p) = unlines [l, p]

decodeCredPair :: Creds -> Maybe CredPair
decodeCredPair creds = case lines creds of
	l:p:[] -> Just (l, p)
	_ -> Nothing

removeCreds :: FilePath -> Annex ()
removeCreds file = do
	d <- fromRepo gitAnnexCredsDir
	let f = d </> file
	liftIO $ nukeFile f


code:
{- git-annex crypto
 -
 - Currently using gpg; could later be modified to support different
 - crypto backends if neccessary.
 -
 - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Rank2Types #-}

module Crypto (
	Cipher,
	KeyIds(..),
	EncKey,
	StorableCipher(..),
	genEncryptedCipher,
	genSharedCipher,
	updateEncryptedCipher,
	describeCipher,
	decryptCipher,
	encryptKey,
	feedFile,
	feedBytes,
	readBytes,
	encrypt,
	decrypt,
	getGpgEncParams,

	prop_HmacSha1WithCipher_sane
) where

import qualified Data.ByteString.Lazy as L
import Data.ByteString.Lazy.UTF8 (fromString)
import Control.Applicative
import qualified Data.Map as M
import Control.Monad.IO.Class
import Control.Monad.Catch (MonadMask)

import Common.Annex
import qualified Utility.Gpg as Gpg
import Types.Key
import Types.Crypto
import Types.Remote

{- The beginning of a Cipher is used for MAC'ing; the remainder is used
 - as the GPG symmetric encryption passphrase when using the hybrid
 - scheme. Note that the cipher itself is base-64 encoded, hence the
 - string is longer than 'cipherSize': 683 characters, padded to 684.
 -
 - The 256 first characters that feed the MAC represent at best 192
 - bytes of entropy.  However that's more than enough for both the
 - default MAC algorithm, namely HMAC-SHA1, and the "strongest"
 - currently supported, namely HMAC-SHA512, which respectively need
 - (ideally) 64 and 128 bytes of entropy.
 -
 - The remaining characters (320 bytes of entropy) is enough for GnuPG's
 - symetric cipher; unlike weaker public key crypto, the key does not
 - need to be too large.
 -}
cipherBeginning :: Int
cipherBeginning = 256

cipherSize :: Int
cipherSize = 512

cipherPassphrase :: Cipher -> String
cipherPassphrase (Cipher c) = drop cipherBeginning c
cipherPassphrase (MacOnlyCipher _) = error "MAC-only cipher"

cipherMac :: Cipher -> String
cipherMac (Cipher c) = take cipherBeginning c
cipherMac (MacOnlyCipher c) = c

{- Creates a new Cipher, encrypted to the specified key id. -}
genEncryptedCipher :: String -> EncryptedCipherVariant -> Bool -> IO StorableCipher
genEncryptedCipher keyid variant highQuality = do
	ks <- Gpg.findPubKeys keyid
	random <- Gpg.genRandom highQuality size
	encryptCipher (mkCipher random) variant ks
  where
	(mkCipher, size) = case variant of
		Hybrid -> (Cipher, cipherSize) -- used for MAC + symmetric
		PubKey -> (MacOnlyCipher, cipherBeginning) -- only used for MAC

{- Creates a new, shared Cipher. -}
genSharedCipher :: Bool -> IO StorableCipher
genSharedCipher highQuality =
	SharedCipher <$> Gpg.genRandom highQuality cipherSize

{- Updates an existing Cipher, re-encrypting it to add or remove keyids,
 - depending on whether the first component is True or False. -}
updateEncryptedCipher :: [(Bool, String)] -> StorableCipher -> IO StorableCipher
updateEncryptedCipher _ SharedCipher{} = undefined
updateEncryptedCipher [] encipher = return encipher
updateEncryptedCipher newkeys encipher@(EncryptedCipher _ variant (KeyIds ks)) = do
	dropKeys <- listKeyIds [ k | (False, k) <- newkeys ]
	forM_ dropKeys $ \k -> unless (k `elem` ks) $
		error $ "Key " ++ k ++ " was not present; cannot remove."
	addKeys <- listKeyIds [ k | (True, k) <- newkeys ]
	let ks' = (addKeys ++ ks) \\ dropKeys
	when (null ks') $
		error "Cannot remove the last key."
	cipher <- decryptCipher encipher
	encryptCipher cipher variant $ KeyIds ks'
  where
	listKeyIds = concat <$$> mapM (keyIds <$$> Gpg.findPubKeys)

describeCipher :: StorableCipher -> String
describeCipher (SharedCipher _) = "shared cipher"
describeCipher (EncryptedCipher _ variant (KeyIds ks)) =
	scheme ++ " with gpg " ++ keys ks ++ " " ++ unwords ks
  where
	scheme = case variant of
		Hybrid -> "hybrid cipher"
		PubKey -> "pubkey crypto"
	keys [_] = "key"
	keys _ = "keys"

{- Encrypts a Cipher to the specified KeyIds. -}
encryptCipher :: Cipher -> EncryptedCipherVariant -> KeyIds -> IO StorableCipher
encryptCipher c variant (KeyIds ks) = do
	-- gpg complains about duplicate recipient keyids
	let ks' = nub $ sort ks
	let params = Gpg.pkEncTo ks' ++ Gpg.stdEncryptionParams False
	encipher <- Gpg.pipeStrict params cipher
	return $ EncryptedCipher encipher variant (KeyIds ks')
  where
	cipher = case c of
		Cipher x -> x
		MacOnlyCipher x -> x

{- Decrypting an EncryptedCipher is expensive; the Cipher should be cached. -}
decryptCipher :: StorableCipher -> IO Cipher
decryptCipher (SharedCipher t) = return $ Cipher t
decryptCipher (EncryptedCipher t variant _) =
	mkCipher <$> Gpg.pipeStrict [ Param "--decrypt" ] t
  where
	mkCipher = case variant of
		Hybrid -> Cipher
		PubKey -> MacOnlyCipher

type EncKey = Key -> Key

{- Generates an encrypted form of a Key. The encryption does not need to be
 - reversable, nor does it need to be the same type of encryption used
 - on content. It does need to be repeatable. -}
encryptKey :: Mac -> Cipher -> EncKey
encryptKey mac c k = stubKey
	{ keyName = macWithCipher mac c (key2file k)
	, keyBackendName = "GPG" ++ showMac mac
	}

type Feeder = Handle -> IO ()
type Reader m a = Handle -> m a

feedFile :: FilePath -> Feeder
feedFile f h = L.hPut h =<< L.readFile f

feedBytes :: L.ByteString -> Feeder
feedBytes = flip L.hPut

readBytes :: (MonadIO m) => (L.ByteString -> m a) -> Reader m a
readBytes a h = liftIO (L.hGetContents h) >>= a

{- Runs a Feeder action, that generates content that is symmetrically
 - encrypted with the Cipher (unless it is empty, in which case
 - public-key encryption is used) using the given gpg options, and then
 - read by the Reader action.  Note: For public-key encryption,
 - recipients MUST be included in 'params' (for instance using
 - 'getGpgEncParams'). -}
encrypt :: (MonadIO m, MonadMask m) => [CommandParam] -> Cipher -> Feeder -> Reader m a -> m a
encrypt params cipher = case cipher of
	Cipher{} -> Gpg.feedRead (params ++ Gpg.stdEncryptionParams True) $
			cipherPassphrase cipher
	MacOnlyCipher{} -> Gpg.pipeLazy $ params ++ Gpg.stdEncryptionParams False

{- Runs a Feeder action, that generates content that is decrypted with the
 - Cipher (or using a private key if the Cipher is empty), and read by the
 - Reader action. -}
decrypt :: (MonadIO m, MonadMask m) => Cipher -> Feeder -> Reader m a -> m a
decrypt cipher = case cipher of
	Cipher{} -> Gpg.feedRead [Param "--decrypt"] $ cipherPassphrase cipher
	MacOnlyCipher{} -> Gpg.pipeLazy [Param "--decrypt"]

macWithCipher :: Mac -> Cipher -> String -> String
macWithCipher mac c = macWithCipher' mac (cipherMac c)
macWithCipher' :: Mac -> String -> String -> String
macWithCipher' mac c s = calcMac mac (fromString c) (fromString s)

{- Ensure that macWithCipher' returns the same thing forevermore. -}
prop_HmacSha1WithCipher_sane :: Bool
prop_HmacSha1WithCipher_sane = known_good == macWithCipher' HmacSha1 "foo" "bar"
  where
	known_good = "46b4ec586117154dacd49d664e5d63fdc88efb51"

{- Return some options suitable for GnuPG encryption, symmetric or not. -}
class LensGpgEncParams a where getGpgEncParams :: a -> [CommandParam]

{- Extract the GnuPG options from a pair of a Remote Config and a Remote
 - Git Config. -}
instance LensGpgEncParams (RemoteConfig, RemoteGitConfig) where
	getGpgEncParams (c,gc) = map Param (remoteAnnexGnupgOptions gc) ++ getGpgEncParams c
	  where

{- Extract the GnuPG options from a Remote Config, ignoring any
 - git config settings. (Which is ok if the remote is just being set up
 - and so doesn't have any.)
 -
 - If the remote is configured to use public-key encryption,
 - look up the recipient keys and add them to the option list.-}
instance LensGpgEncParams RemoteConfig where
	getGpgEncParams c = case M.lookup "encryption" c of
		Just "pubkey" -> Gpg.pkEncTo $ maybe [] (split ",") $ M.lookup "cipherkeys" c
		_ -> []

{- Extract the GnuPG options from a Remote. -}
instance LensGpgEncParams (RemoteA a) where
	getGpgEncParams r = getGpgEncParams (config r, gitconfig r)


code:
{- git repository handling
 -
 - This is written to be completely independant of git-annex and should be
 - suitable for other uses.
 -
 - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Git (
	Repo(..),
	Ref(..),
	fromRef,
	Branch,
	Sha,
	Tag,
	repoIsUrl,
	repoIsSsh,
	repoIsHttp,
	repoIsLocal,
	repoIsLocalBare,
	repoIsLocalUnknown,
	repoDescribe,
	repoLocation,
	repoPath,
	localGitDir,
	attributes,
	hookPath,
	assertLocal,
) where

import Network.URI (uriPath, uriScheme, unEscapeString)
#ifndef mingw32_HOST_OS
import System.Posix.Files
#endif

import Common
import Git.Types
#ifndef mingw32_HOST_OS
import Utility.FileMode
#endif

{- User-visible description of a git repo. -}
repoDescribe :: Repo -> String
repoDescribe Repo { remoteName = Just name } = name
repoDescribe Repo { location = Url url } = show url
repoDescribe Repo { location = Local { worktree = Just dir } } = dir
repoDescribe Repo { location = Local { gitdir = dir } } = dir
repoDescribe Repo { location = LocalUnknown dir } = dir
repoDescribe Repo { location = Unknown } = "UNKNOWN"

{- Location of the repo, either as a path or url. -}
repoLocation :: Repo -> String
repoLocation Repo { location = Url url } = show url
repoLocation Repo { location = Local { worktree = Just dir } } = dir
repoLocation Repo { location = Local { gitdir = dir } } = dir
repoLocation Repo { location = LocalUnknown dir } = dir
repoLocation Repo { location = Unknown } = undefined

{- Path to a repository. For non-bare, this is the worktree, for bare,
 - it's the gitdir, and for URL repositories, is the path on the remote
 - host. -}
repoPath :: Repo -> FilePath
repoPath Repo { location = Url u } = unEscapeString $ uriPath u
repoPath Repo { location = Local { worktree = Just d } } = d
repoPath Repo { location = Local { gitdir = d } } = d
repoPath Repo { location = LocalUnknown dir } = dir
repoPath Repo { location = Unknown } = undefined

{- Path to a local repository's .git directory. -}
localGitDir :: Repo -> FilePath
localGitDir Repo { location = Local { gitdir = d } } = d
localGitDir _ = undefined

{- Some code needs to vary between URL and normal repos,
 - or bare and non-bare, these functions help with that. -}
repoIsUrl :: Repo -> Bool
repoIsUrl Repo { location = Url _ } = True
repoIsUrl _ = False

repoIsSsh :: Repo -> Bool
repoIsSsh Repo { location = Url url }
	| scheme == "ssh:" = True
	-- git treats these the same as ssh
	| scheme == "git+ssh:" = True
	| scheme == "ssh+git:" = True
	| otherwise = False
  where
	scheme = uriScheme url
repoIsSsh _ = False

repoIsHttp :: Repo -> Bool
repoIsHttp Repo { location = Url url }
	| uriScheme url == "http:" = True
	| uriScheme url == "https:" = True
	| otherwise = False
repoIsHttp _ = False

repoIsLocal :: Repo -> Bool
repoIsLocal Repo { location = Local { } } = True
repoIsLocal _ = False

repoIsLocalBare :: Repo -> Bool
repoIsLocalBare Repo { location = Local { worktree = Nothing } } = True
repoIsLocalBare _ = False

repoIsLocalUnknown :: Repo -> Bool
repoIsLocalUnknown Repo { location = LocalUnknown { } } = True
repoIsLocalUnknown _ = False

assertLocal :: Repo -> a -> a
assertLocal repo action
	| repoIsUrl repo = error $ unwords
		[ "acting on non-local git repo"
		, repoDescribe repo
		, "not supported"
		]
	| otherwise = action

{- Path to a repository's gitattributes file. -}
attributes :: Repo -> FilePath
attributes repo
	| repoIsLocalBare repo = repoPath repo ++ "/info/.gitattributes"
	| otherwise = repoPath repo ++ "/.gitattributes"

{- Path to a given hook script in a repository, only if the hook exists
 - and is executable. -}
hookPath :: String -> Repo -> IO (Maybe FilePath)
hookPath script repo = do
	let hook = localGitDir repo </> "hooks" </> script
	ifM (catchBoolIO $ isexecutable hook)
		( return $ Just hook , return Nothing )
  where
#if mingw32_HOST_OS
	isexecutable f = doesFileExist f
#else
	isexecutable f = isExecutable . fileMode <$> getFileStatus f
#endif


code:
{- git autocorrection using Damerau-Levenshtein edit distance
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.AutoCorrect where

import Common
import Git.Types
import qualified Git.Config

import Text.EditDistance
import Control.Concurrent

{- These are the same cost values as used in git. -}
gitEditCosts :: EditCosts
gitEditCosts = EditCosts
	{ deletionCosts = ConstantCost 4
	, insertionCosts = ConstantCost 1
	, substitutionCosts = ConstantCost 2
	, transpositionCosts = ConstantCost 0
	}

{- Git's source calls this "an empirically derived magic number" -}
similarityFloor :: Int
similarityFloor = 7

{- Finds inexact matches for the input among the choices.
 - Returns an ordered list of good enough matches, or an empty list if
 - nothing matches well. -}
fuzzymatches :: String -> (c -> String) -> [c] -> [c]
fuzzymatches input showchoice choices = fst $ unzip $
	sortBy comparecost $ filter similarEnough $ zip choices costs
  where
	distance = restrictedDamerauLevenshteinDistance gitEditCosts input
	costs = map (distance . showchoice) choices
	comparecost a b = compare (snd a) (snd b)
	similarEnough (_, cst) = cst < similarityFloor

{- Takes action based on git's autocorrect configuration, in preparation for
 - an autocorrected command being run. -}
prepare :: String -> (c -> String) -> [c] -> Repo -> IO ()
prepare input showmatch matches r =
	case readish $ Git.Config.get "help.autocorrect" "0" r of
		Just n
			| n == 0 -> list
			| n < 0 -> warn
			| otherwise -> sleep n
		Nothing -> list
  where
	list = error $ unlines $
		[ "Unknown command '" ++ input ++ "'"
		, ""
		, "Did you mean one of these?"
		] ++ map (\m -> "\t" ++ showmatch m) matches
	warn =
		hPutStr stderr $ unlines
			[ "WARNING: You called a command named '" ++
			  input ++ "', which does not exist."
			, "Continuing under the assumption that you meant '" ++
			  showmatch (Prelude.head matches) ++ "'"
			]
	sleep n = do
		warn
		hPutStrLn stderr $ unwords
			[ "in"
			, show (fromIntegral n / 10 :: Float)
			, "seconds automatically..."]
		threadDelay (n * 100000) -- deciseconds to microseconds


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

{-# LANGUAGE BangPatterns #-}

module Git.Branch where

import Common
import Git
import Git.Sha
import Git.Command
import qualified Git.Ref
import qualified Git.BuildVersion

{- The currently checked out branch.
 -
 - In a just initialized git repo before the first commit,
 - symbolic-ref will show the master branch, even though that
 - branch is not created yet. So, this also looks at show-ref HEAD
 - to double-check.
 -}
current :: Repo -> IO (Maybe Git.Ref)
current r = do
	v <- currentUnsafe r
	case v of
		Nothing -> return Nothing
		Just branch ->
			ifM (null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r)
				( return Nothing
				, return v
				)

{- The current branch, which may not really exist yet. -}
currentUnsafe :: Repo -> IO (Maybe Git.Ref)
currentUnsafe r = parse . firstLine
	<$> pipeReadStrict [Param "symbolic-ref", Param $ fromRef Git.Ref.headRef] r
  where
	parse l
		| null l = Nothing
		| otherwise = Just $ Git.Ref l

{- Checks if the second branch has any commits not present on the first
 - branch. -}
changed :: Branch -> Branch -> Repo -> IO Bool
changed origbranch newbranch repo
	| origbranch == newbranch = return False
	| otherwise = not . null <$> diffs
  where
	diffs = pipeReadStrict
		[ Param "log"
		, Param (fromRef origbranch ++ ".." ++ fromRef newbranch)
		, Param "-n1"
		, Param "--pretty=%H"
		] repo

{- Check if it's possible to fast-forward from the old
 - ref to the new ref.
 -
 - This requires there to be a path from the old to the new. -}
fastForwardable :: Ref -> Ref -> Repo -> IO Bool
fastForwardable old new repo = not . null <$>
	pipeReadStrict
		[ Param "log"
		, Param $ fromRef old ++ ".." ++ fromRef new
		, Param "-n1"
		, Param "--pretty=%H"
		, Param "--ancestry-path"
		] repo

{- Given a set of refs that are all known to have commits not
 - on the branch, tries to update the branch by a fast-forward.
 -
 - In order for that to be possible, one of the refs must contain
 - every commit present in all the other refs.
 -}
fastForward :: Branch -> [Ref] -> Repo -> IO Bool
fastForward _ [] _ = return True
fastForward branch (first:rest) repo =
	-- First, check that the branch does not contain any
	-- new commits that are not in the first ref. If it does,
	-- cannot fast-forward.
	ifM (changed first branch repo)
		( no_ff
		, maybe no_ff do_ff =<< findbest first rest
		)
  where
	no_ff = return False
	do_ff to = do
		update branch to repo
		return True
	findbest c [] = return $ Just c
	findbest c (r:rs)
		| c == r = findbest c rs
		| otherwise = do
		better <- changed c r repo
		worse <- changed r c repo
		case (better, worse) of
			(True, True) -> return Nothing -- divergent fail
			(True, False) -> findbest r rs -- better
			(False, True) -> findbest c rs -- worse
			(False, False) -> findbest c rs -- same

{- The user may have set commit.gpgsign, indending all their manual
 - commits to be signed. But signing automatic/background commits could
 - easily lead to unwanted gpg prompts or failures.
 -}
data CommitMode = ManualCommit | AutomaticCommit
	deriving (Eq)

applyCommitMode :: CommitMode -> [CommandParam] -> [CommandParam]
applyCommitMode commitmode ps
	| commitmode == AutomaticCommit && not (Git.BuildVersion.older "2.0.0") =
		Param "--no-gpg-sign" : ps
	| otherwise = ps

{- Commit via the usual git command. -}
commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool
commitCommand = commitCommand' runBool

{- Commit will fail when the tree is clean. This suppresses that error. -}
commitQuiet :: CommitMode -> [CommandParam] -> Repo -> IO ()
commitQuiet commitmode ps = void . tryIO . commitCommand' runQuiet commitmode ps

commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> [CommandParam] -> Repo -> IO a
commitCommand' runner commitmode ps = runner $
	Param "commit" : applyCommitMode commitmode ps

{- Commits the index into the specified branch (or other ref),
 - with the specified parent refs, and returns the committed sha.
 -
 - Without allowempy set, avoids making a commit if there is exactly
 - one parent, and it has the same tree that would be committed.
 -
 - Unlike git-commit, does not run any hooks, or examine the work tree
 - in any way.
 -}
commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha)
commit commitmode allowempty message branch parentrefs repo = do
	tree <- getSha "write-tree" $
		pipeReadStrict [Param "write-tree"] repo
	ifM (cancommit tree)
		( do
			sha <- getSha "commit-tree" $
				pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps) sendmsg repo
			update branch sha repo
			return $ Just sha
		, return Nothing
		)
  where
	ps = applyCommitMode commitmode $
		map Param $ concatMap (\r -> ["-p", fromRef r]) parentrefs
	cancommit tree
		| allowempty = return True
		| otherwise = case parentrefs of
			[p] -> maybe False (tree /=) <$> Git.Ref.tree p repo
			_ -> return True
	sendmsg = Just $ flip hPutStr message

commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha
commitAlways commitmode message branch parentrefs repo = fromJust
	<$> commit commitmode True message branch parentrefs repo

{- A leading + makes git-push force pushing a branch. -}
forcePush :: String -> String
forcePush b = "+" ++ b

{- Updates a branch (or other ref) to a new Sha. -}
update :: Branch -> Sha -> Repo -> IO ()
update branch sha = run
	[ Param "update-ref"
	, Param $ fromRef branch
	, Param $ fromRef sha
	]

{- Checks out a branch, creating it if necessary. -}
checkout :: Branch -> Repo -> IO ()
checkout branch = run
	[ Param "checkout"
	, Param "-q"
	, Param "-B"
	, Param $ fromRef $ Git.Ref.base branch
	]

{- Removes a branch. -}
delete :: Branch -> Repo -> IO ()
delete branch = run
	[ Param "branch"
	, Param "-q"
	, Param "-D"
	, Param $ fromRef $ Git.Ref.base branch
	]


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

module Git.BuildVersion where

import Git.Version
import qualified Build.SysConfig

{- Using the version it was configured for avoids running git to check its
 - version, at the cost that upgrading git won't be noticed.
 - This is only acceptable because it's rare that git's version influences
 - code's behavior. -}
buildVersion :: GitVersion
buildVersion = normalize Build.SysConfig.gitversion

older :: String -> Bool
older n = buildVersion < normalize n


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

module Git.CatFile (
	CatFileHandle,
	catFileStart,
	catFileStart',
	catFileStop,
	catFile,
	catFileDetails,
	catTree,
	catObject,
	catObjectDetails,
) where

import System.IO
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Tuple.Utils
import Numeric
import System.Posix.Types

import Common
import Git
import Git.Sha
import Git.Command
import Git.Types
import Git.FilePath
import qualified Utility.CoProcess as CoProcess

data CatFileHandle = CatFileHandle CoProcess.CoProcessHandle Repo

catFileStart :: Repo -> IO CatFileHandle
catFileStart = catFileStart' True

catFileStart' :: Bool -> Repo -> IO CatFileHandle
catFileStart' restartable repo = do
	coprocess <- CoProcess.rawMode =<< gitCoProcessStart restartable
		[ Param "cat-file"
		, Param "--batch"
		] repo
	return $ CatFileHandle coprocess repo

catFileStop :: CatFileHandle -> IO ()
catFileStop (CatFileHandle p _) = CoProcess.stop p

{- Reads a file from a specified branch. -}
catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString
catFile h branch file = catObject h $ Ref $
	fromRef branch ++ ":" ++ toInternalGitPath file

catFileDetails :: CatFileHandle -> Branch -> FilePath -> IO (Maybe (L.ByteString, Sha, ObjectType))
catFileDetails h branch file = catObjectDetails h $ Ref $
	fromRef branch ++ ":" ++ toInternalGitPath file

{- Uses a running git cat-file read the content of an object.
 - Objects that do not exist will have "" returned. -}
catObject :: CatFileHandle -> Ref -> IO L.ByteString
catObject h object = maybe L.empty fst3 <$> catObjectDetails h object

catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType))
catObjectDetails (CatFileHandle hdl _) object = CoProcess.query hdl send receive
  where
	query = fromRef object
	send to = hPutStrLn to query
	receive from = do
		header <- hGetLine from
		case words header of
			[sha, objtype, size]
				| length sha == shaSize ->
					case (readObjectType objtype, reads size) of
						(Just t, [(bytes, "")]) -> readcontent t bytes from sha
						_ -> dne
				| otherwise -> dne
			_
				| header == fromRef object ++ " missing" -> dne
				| otherwise -> error $ "unknown response from git cat-file " ++ show (header, query)
	readcontent objtype bytes from sha = do
		content <- S.hGet from bytes
		eatchar '\n' from
		return $ Just (L.fromChunks [content], Ref sha, objtype)
	dne = return Nothing
	eatchar expected from = do
		c <- hGetChar from
		when (c /= expected) $
			error $ "missing " ++ (show expected) ++ " from git cat-file"

{- Gets a list of files and directories in a tree. (Not recursive.) -}
catTree :: CatFileHandle -> Ref -> IO [(FilePath, FileMode)]
catTree h treeref = go <$> catObjectDetails h treeref
  where
	go (Just (b, _, TreeObject)) = parsetree [] b
  	go _ = []

	parsetree c b = case L.break (== 0) b of
		(modefile, rest)
			| L.null modefile -> c
			| otherwise -> parsetree
				(parsemodefile modefile:c)
				(dropsha rest)

	-- these 20 bytes after the NUL hold the file's sha
	-- TODO: convert from raw form to regular sha
	dropsha = L.drop 21

	parsemodefile b =
		let (modestr, file) = separate (== ' ') (decodeBS b)
		in (file, readmode modestr)
	readmode = fst . fromMaybe (0, undefined) . headMaybe . readOct


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

module Git.CheckAttr where

import Common
import Git
import Git.Command
import qualified Git.BuildVersion
import qualified Utility.CoProcess as CoProcess

import System.IO.Error

type CheckAttrHandle = (CoProcess.CoProcessHandle, [Attr], String)

type Attr = String

{- Starts git check-attr running to look up the specified gitattributes
 - values and returns a handle.  -}
checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle
checkAttrStart attrs repo = do
	currdir <- getCurrentDirectory
	h <- CoProcess.rawMode =<< gitCoProcessStart True params repo
	return (h, attrs, currdir)
  where
	params =
		[ Param "check-attr"
		, Params "-z --stdin"
		] ++ map Param attrs ++
		[ Param "--" ]

checkAttrStop :: CheckAttrHandle -> IO ()
checkAttrStop (h, _, _) = CoProcess.stop h

{- Gets an attribute of a file. -}
checkAttr :: CheckAttrHandle -> Attr -> FilePath -> IO String
checkAttr (h, attrs, currdir) want file = do
	pairs <- CoProcess.query h send (receive "")
	let vals = map snd $ filter (\(attr, _) -> attr == want) pairs
	case vals of
		[v] -> return v
		_ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file
  where
	send to = hPutStr to $ file' ++ "\0"
	receive c from = do
		s <- hGetSomeString from 1024
		if null s
			then eofError
			else do
				let v = c ++ s
				maybe (receive v from) return (parse v)
	eofError = ioError $ mkIOError userErrorType "git check-attr EOF" Nothing Nothing
	parse s
		-- new null separated output
		| '\0' `elem` s = if "\0" `isSuffixOf` s
			then
				let bits = segment (== '\0') s
				in if length bits == (numattrs * 3) + 1
					then Just $ getattrvalues bits []
					else Nothing -- more attributes to come
			else Nothing -- output incomplete
		-- old one line per value output
		| otherwise = if "\n" `isSuffixOf` s
			then
				let ls = lines s
				in if length ls == numattrs
					then Just $ map (\(attr, val) -> (attr, oldattrvalue attr val))
						(zip attrs ls)
					else Nothing -- more attributes to come
			else Nothing -- line incomplete
	numattrs = length attrs

	{- Before git 1.7.7, git check-attr worked best with
	 - absolute filenames; using them worked around some bugs
	 - with relative filenames.
	 -
	 - With newer git, git check-attr chokes on some absolute
	 - filenames, and the bugs that necessitated them were fixed,
	 - so use relative filenames. -}
	oldgit = Git.BuildVersion.older "1.7.7"
	file'
		| oldgit = absPathFrom currdir file
		| otherwise = relPathDirToFile currdir $ absPathFrom currdir file
	oldattrvalue attr l = end bits !! 0
	  where
		bits = split sep l
		sep = ": " ++ attr ++ ": "
	getattrvalues (_filename:attr:val:rest) c = getattrvalues rest ((attr,val):c)
	getattrvalues _ c = c


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

module Git.CheckIgnore (
	CheckIgnoreHandle,
	checkIgnoreStart,
	checkIgnoreStop,
	checkIgnored
) where

import Common
import Git
import Git.Command
import qualified Git.Version
import qualified Utility.CoProcess as CoProcess

import System.IO.Error

type CheckIgnoreHandle = CoProcess.CoProcessHandle

{- Starts git check-ignore running, and returns a handle.
 -
 - This relies on git check-ignore --non-matching -v outputting
 - lines for both matching an non-matching files. Also relies on
 - GIT_FLUSH behavior flushing the output buffer when git check-ignore
 - is piping to us.
 -
 - The first version of git to support what we need is 1.8.4.
 - Nothing is returned if an older git is installed.
 -}
checkIgnoreStart :: Repo -> IO (Maybe CheckIgnoreHandle)
checkIgnoreStart repo = ifM supportedGitVersion
	( Just <$> (CoProcess.rawMode =<< gitCoProcessStart True params repo)
	, return Nothing
	)
  where
	params =
		[ Param "check-ignore"
		, Params "-z --stdin --verbose --non-matching"
		]

supportedGitVersion :: IO Bool
supportedGitVersion = do
	v <- Git.Version.installed
	return $ v >= Git.Version.normalize "1.8.4"

checkIgnoreStop :: CheckIgnoreHandle -> IO ()
checkIgnoreStop = CoProcess.stop

{- Returns True if a file is ignored. -}
checkIgnored :: CheckIgnoreHandle -> FilePath -> IO Bool
checkIgnored h file = CoProcess.query h send (receive "")
  where
	send to = do
		hPutStr to $ file ++ "\0"
		hFlush to
	receive c from = do
		s <- hGetSomeString from 1024
		if null s
			then eofError
			else do
				let v = c ++ s
				maybe (receive v from) return (parse v)
	parse s = case segment (== '\0') s of
		(_source:_line:pattern:_pathname:_eol:[]) -> Just $ not $ null pattern
		_ -> Nothing
	eofError = ioError $ mkIOError userErrorType "git cat-file EOF" Nothing Nothing