code:
{- git-annex "URL" backend -- keys whose content is available from urls.
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Backend.URL (
	backends,
	fromUrl
) where

import Common.Annex
import Types.Backend
import Types.Key
import Backend.Utilities

backends :: [Backend]
backends = [backend]

backend :: Backend
backend = Backend
	{ name = "URL"
	, getKey = const $ return Nothing
	, fsckKey = Nothing
	, canUpgradeKey = Nothing
	, fastMigrate = Nothing
	-- The content of an url can change at any time, so URL keys are
	-- not stable.
	, isStableKey = const False
	}

{- Every unique url has a corresponding key. -}
fromUrl :: String -> Maybe Integer -> Annex Key
fromUrl url size = do
	n <- genKeyName url
	return $ stubKey
		{ keyName = n
		, keyBackendName = "URL"
		, keySize = size
		}


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

module Backend.Utilities where

import Data.Hash.MD5

import Common.Annex

{- Generates a keyName from an input string. Takes care of sanitizing it.
 - If it's not too long, the full string is used as the keyName.
 - Otherwise, it's truncated at half the filename length limit, and its
 - md5 is prepended to ensure a unique key. -}
genKeyName :: String -> Annex String
genKeyName s = do
	limit <- liftIO . fileNameLengthLimit =<< fromRepo gitAnnexDir
	let s' = preSanitizeKeyName s
	let truncs = truncateFilePath (limit `div` 2) s'
	return $ if s' == truncs
		then s'
		else truncs ++ "-" ++ md5s (Str s)

repo_name: kakafarm/git

license: unknown


code:
{- git-annex "WORM" backend -- Write Once, Read Many
 -
 - Copyright 2010 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Backend.WORM (backends) where

import Common.Annex
import Types.Backend
import Types.Key
import Types.KeySource
import Backend.Utilities

backends :: [Backend]
backends = [backend]

backend :: Backend
backend = Backend
	{ name = "WORM"
	, getKey = keyValue
	, fsckKey = Nothing
	, canUpgradeKey = Nothing
	, fastMigrate = Nothing
	, isStableKey = const True
	}

{- The key includes the file size, modification time, and the
 - basename of the filename.
 -
 - That allows multiple files with the same names to have different keys,
 - while also allowing a file to be moved around while retaining the
 - same key.
 -}
keyValue :: KeySource -> Annex (Maybe Key)
keyValue source = do
	stat <- liftIO $ getFileStatus $ contentLocation source
	n <- genKeyName $ keyFilename source
	return $ Just $ stubKey
		{ keyName = n
		, keyBackendName = name backend
		, keySize = Just $ fromIntegral $ fileSize stat
		, keyMtime = Just $ modificationTime stat
		}


code:
{- Outputs the version of git-annex that was built, for use by
 - autobuilders. Note that this includes the git rev. -}

import Build.Version

main = putStr =<< getVersion


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

{-# LANGUAGE CPP #-}

module Build.BundledPrograms where

import Data.Maybe

import Build.SysConfig as SysConfig

{- Programs that git-annex uses, to include in the bundle.
 -
 - These may be just the command name, or the full path to it. -}
bundledPrograms :: [FilePath]
bundledPrograms = catMaybes
	[ Nothing
#ifndef mingw32_HOST_OS
	-- git is not included in the windows bundle
	, Just "git"
	-- Not strictly needed in PATH by git-annex, but called
	-- by git when it sshes to a remote.
	, Just "git-upload-pack"
	, Just "git-receive-pack"
	, Just "git-shell"
#endif
	, Just "cp"
#ifndef mingw32_HOST_OS
	-- using xargs on windows led to problems, so it's not used there
	, Just "xargs"
#endif
	, Just "rsync"
#ifndef darwin_HOST_OS
	-- OS X has ssh installed by default.
	-- (Linux probably, but not guaranteed.)
	, Just "ssh"
	, Just "ssh-keygen"
#endif
#ifndef mingw32_HOST_OS
	, Just "sh"
#endif
	, SysConfig.gpg
	, ifset SysConfig.curl "curl"
#ifndef darwin_HOST_OS
	-- wget on OSX has been problimatic, looking for certs in the wrong
	-- places. Don't ship it, use curl or the OSX's own wget if it has
	-- one.
	, ifset SysConfig.wget "wget"
#endif
	, ifset SysConfig.bup "bup"
	, SysConfig.lsof
	, SysConfig.gcrypt
	, SysConfig.sha1
	, SysConfig.sha256
	, SysConfig.sha512
	, SysConfig.sha224
	, SysConfig.sha384
#ifdef linux_HOST_OS
	-- used to unpack the tarball when upgrading
	, Just "gunzip"
	, Just "tar"
#endif
	-- nice, ionice, and nocache are not included in the bundle;
	-- we rely on the system's own version, which may better match
	-- its kernel, and avoid using them if not available.
	]
  where
	ifset True s = Just s
	ifset False _ = Nothing


code:
{- Checks system configuration and generates SysConfig.hs. -}

module Build.Configure where

import System.Directory
import Control.Applicative
import System.Environment (getArgs)
import Control.Monad.IfElse
import Control.Monad

import Build.TestConfig
import Build.Version
import Utility.SafeCommand
import Utility.ExternalSHA
import Utility.Env
import qualified Git.Version

tests :: [TestCase]
tests =
	[ TestCase "version" (Config "packageversion" . StringConfig <$> getVersion)
	, TestCase "UPGRADE_LOCATION" getUpgradeLocation
	, TestCase "git" $ requireCmd "git" "git --version >/dev/null"
	, TestCase "git version" getGitVersion
	, testCp "cp_a" "-a"
	, testCp "cp_p" "-p"
	, testCp "cp_reflink_auto" "--reflink=auto"
	, TestCase "xargs -0" $ requireCmd "xargs_0" "xargs -0 </dev/null"
	, TestCase "rsync" $ requireCmd "rsync" "rsync --version >/dev/null"
	, TestCase "curl" $ testCmd "curl" "curl --version >/dev/null"
	, TestCase "wget" $ testCmd "wget" "wget --version >/dev/null"
	, TestCase "bup" $ testCmd "bup" "bup --version >/dev/null"
	, TestCase "nice" $ testCmd "nice" "nice true >/dev/null"
	, TestCase "ionice" $ testCmd "ionice" "ionice -c3 true >/dev/null"
	, TestCase "nocache" $ testCmd "nocache" "nocache true >/dev/null"
	, TestCase "gpg" $ maybeSelectCmd "gpg"
		[ ("gpg", "--version >/dev/null")
		, ("gpg2", "--version >/dev/null") ]
	, TestCase "lsof" $ findCmdPath "lsof" "lsof"
	, TestCase "git-remote-gcrypt" $ findCmdPath "gcrypt" "git-remote-gcrypt"
	, TestCase "ssh connection caching" getSshConnectionCaching
	] ++ shaTestCases
	[ (1, "da39a3ee5e6b4b0d3255bfef95601890afd80709")
	, (256, "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855")
	, (512, "cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d13c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e")
	, (224, "d14a028c2a3a2bc9476102bb288234c415a2b01f828ea62ac5b3e42f")
	, (384, "38b060a751ac96384cd9327eb1b1e36a21fdb71114be07434c0cc7bf63f6e1da274edebfe76f65fbd51ad2f14898b95b")
	]

{- shaNsum are the program names used by coreutils. Some systems
 - install these with 'g' prefixes.
 -
 - On some systems, shaN is used instead, but on other
 - systems, it might be "hashalot", which does not produce
 - usable checksums. Only accept programs that produce
 - known-good hashes when run on files. -}
shaTestCases :: [(Int, String)] -> [TestCase]
shaTestCases l = map make l
  where
	make (n, knowngood) = TestCase key $
		Config key . MaybeStringConfig <$> search (shacmds n)
	  where
		key = "sha" ++ show n
		search [] = return Nothing
		search (c:cmds) = do
			sha <- externalSHA c n "/dev/null"
			if sha == Right knowngood
				then return $ Just c
				else search cmds

	shacmds n = concatMap (\x -> [x, 'g':x]) $
		map (\x -> "sha" ++ show n ++ x) ["sum", ""]

tmpDir :: String
tmpDir = "tmp"

testFile :: String
testFile = tmpDir ++ "/testfile"

testCp :: ConfigKey -> String -> TestCase
testCp k option = TestCase cmd $ testCmd k cmdline
  where
	cmd = "cp " ++ option
	cmdline = cmd ++ " " ++ testFile ++ " " ++ testFile ++ ".new"

getUpgradeLocation :: Test
getUpgradeLocation = do
	e <- getEnv "UPGRADE_LOCATION"
	return $ Config "upgradelocation" $ MaybeStringConfig e

getGitVersion :: Test
getGitVersion = do
	v <- Git.Version.installed
	let oldestallowed = Git.Version.normalize "1.7.1.0"
	when (v < oldestallowed) $
		error $ "installed git version " ++ show v ++ " is too old! (Need " ++ show oldestallowed ++ " or newer)"
	return $ Config "gitversion" $ StringConfig $ show v

getSshConnectionCaching :: Test
getSshConnectionCaching = Config "sshconnectioncaching" . BoolConfig <$>
	boolSystem "sh" [Param "-c", Param "ssh -o ControlPersist=yes -V >/dev/null 2>/dev/null"]

setup :: IO ()
setup = do
	createDirectoryIfMissing True tmpDir
	writeFile testFile "test file contents"

cleanup :: IO ()
cleanup = removeDirectoryRecursive tmpDir

run :: [TestCase] -> IO ()
run ts = do
	args <- getArgs
	setup
	config <- runTests ts
	if args == ["Android"]
		then writeSysConfig $ androidConfig config
		else writeSysConfig config
	cleanup
	whenM isReleaseBuild $
		cabalSetup "git-annex.cabal"

{- Hard codes some settings to cross-compile for Android. -}
androidConfig :: [Config] -> [Config]
androidConfig c = overrides ++ filter (not . overridden) c
  where
	overrides =
		[ Config "cp_reflink_auto" $ BoolConfig False
		, Config "curl" $ BoolConfig False
		, Config "sha224" $ MaybeStringConfig Nothing
		, Config "sha384" $ MaybeStringConfig Nothing
		]
	overridden (Config k _) = k `elem` overridekeys
	overridekeys = map (\(Config k _) -> k) overrides


code:
{- Generating and installing a desktop menu entry file and icon,
 - and a desktop autostart file. (And OSX equivilants.)
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Build.DesktopFile where

import Utility.Exception
import Utility.FreeDesktop
import Utility.Path
import Utility.Monad
import Config.Files
import Utility.OSX
import Assistant.Install.AutoStart
import Assistant.Install.Menu

import Control.Applicative
import System.Directory
import System.Environment
#ifndef mingw32_HOST_OS
import System.Posix.User
#endif
import Data.Maybe

systemwideInstall :: IO Bool
#ifndef mingw32_HOST_OS
systemwideInstall = isroot <||> destdirset
  where
	isroot = do
		uid <- fromIntegral <$> getRealUserID
		return $ uid == (0 :: Int)
	destdirset = isJust <$> catchMaybeIO (getEnv "DESTDIR")
#else
systemwideInstall = return False
#endif

inDestDir :: FilePath -> IO FilePath
inDestDir f = do
	destdir <- catchDefaultIO "" (getEnv "DESTDIR")
	return $ destdir ++ "/" ++ f

writeFDODesktop :: FilePath -> IO ()
writeFDODesktop command = do
	systemwide <- systemwideInstall

	datadir <- if systemwide then return systemDataDir else userDataDir
	menufile <- inDestDir (desktopMenuFilePath "git-annex" datadir)
	icondir <- inDestDir (iconDir datadir)
	installMenu command menufile "doc" icondir

	configdir <- if systemwide then return systemConfigDir else userConfigDir
	installAutoStart command
		=<< inDestDir (autoStartPath "git-annex" configdir)

writeOSXDesktop :: FilePath -> IO ()
writeOSXDesktop command = do
	installAutoStart command =<< inDestDir =<< ifM systemwideInstall
		( return $ systemAutoStart osxAutoStartLabel
		, userAutoStart osxAutoStartLabel
		)

install :: FilePath -> IO ()
install command = do
#ifdef darwin_HOST_OS
	writeOSXDesktop command
#else
	writeFDODesktop command
#endif
	ifM systemwideInstall
		( return ()
		, do
			programfile <- inDestDir =<< programFile
			createDirectoryIfMissing True (parentDir programfile)
			writeFile programfile command
		)


code:
{- Downloads git-annex autobuilds and installs them into the git-annex
 - repository in ~/lib/downloads that is used to distribute git-annex
 - releases.
 -
 - Generates info files, containing the version (of the corresponding file
 - from the autobuild).
 -
 - Also gpg signs the files.
 -}

import Common.Annex
import Types.Distribution
import Build.Version
import Utility.UserInfo
import Utility.Url
import qualified Git.Construct
import qualified Annex
import Annex.Content
import Backend
import Git.Command

import Data.Default
import Data.Time.Clock
import Data.Char

-- git-annex distribution signing key (for Joey Hess)
signingKey :: String
signingKey = "89C809CB"

-- URL to an autobuilt git-annex file, and the place to install
-- it in the repository.
autobuilds :: [(URLString, FilePath)]
autobuilds =
	(map linuxarch ["i386", "amd64", "armel"]) ++
	(map androidversion ["4.0", "4.3"]) ++
	[ (autobuild "x86_64-apple-mavericks/git-annex.dmg", "git-annex/OSX/current/10.9_Mavericks/git-annex.dmg")
	, (autobuild "windows/git-annex-installer.exe", "git-annex/windows/current/git-annex-installer.exe")
	]
  where
	linuxarch a =
		( autobuild (a ++ "/git-annex-standalone-" ++ a ++ ".tar.gz")
		, "git-annex/linux/current/git-annex-standalone-" ++ a ++ ".tar.gz"
		)
	androidversion v =
		( autobuild ("android/" ++ v ++ "/git-annex.apk")
		, "git-annex/android/current/" ++ v ++ "/git-annex.apk"
		)
	autobuild f = "https://downloads.kitenet.net/git-annex/autobuild/" ++ f

main :: IO ()
main = do
	repodir <- getRepoDir
	updated <- catMaybes <$> mapM (getbuild repodir) autobuilds
	state <- Annex.new =<< Git.Construct.fromPath repodir
	Annex.eval state (makeinfos updated)

-- Download a build from the autobuilder, and return its version.
-- It's very important that the version matches the build, otherwise
-- auto-upgrades can loop reatedly. So, check build-version before
-- and after downloading the file.
getbuild :: FilePath -> (URLString, FilePath) -> IO (Maybe (FilePath, Version))
getbuild repodir (url, f) = do
	bv1 <- getbv
	let dest = repodir </> f
	let tmp = dest ++ ".tmp"
	nukeFile tmp
	createDirectoryIfMissing True (parentDir dest)
	let oops s = do
		nukeFile tmp
		putStrLn $ "*** " ++ s
		return Nothing
	ifM (download url tmp def)
		( do
			bv2 <- getbv
			case bv2 of
				Nothing -> oops $ "no build-version file for " ++ url
				(Just v)
					| bv2 == bv1 -> do
						nukeFile dest
						renameFile tmp dest
						-- remove git rev part of version
						let v' = takeWhile (/= '-') v
						return $ Just (f, v')
					| otherwise -> oops $ "build version changed while downloading " ++ url ++ " " ++ show (bv1, bv2)
		, oops $ "failed to download " ++ url
		)
  where
	bvurl = takeDirectory url ++ "/build-version"
	getbv = do
		bv <- catchDefaultIO "" $ readProcess "curl" ["--silent", bvurl]
		return $ if null bv || any (not . versionchar) bv then Nothing else Just bv
	versionchar c = isAlphaNum c || c == '.' || c == '-'

makeinfos :: [(FilePath, Version)] -> Annex ()
makeinfos updated = do
	version <- liftIO getChangelogVersion
	void $ inRepo $ runBool
		[ Param "commit"
		, Param "-a"
		, Param "-m"
		, Param $ "publishing git-annex " ++ version
		]
	basedir <- liftIO getRepoDir
	now <- liftIO getCurrentTime
	liftIO $ putStrLn $ "building info files in " ++ basedir
	forM_ updated $ \(f, bv) -> do
		v <- lookupFile (basedir </> f)
		case v of
			Nothing -> noop
			Just k -> whenM (inAnnex k) $ do
				liftIO $ putStrLn f
				let infofile = basedir </> f ++ ".info"
				liftIO $ writeFile infofile $ show $ GitAnnexDistribution
					{ distributionUrl = mkUrl f
					, distributionKey = k
					, distributionVersion = bv
					, distributionReleasedate = now
					, distributionUrgentUpgrade = Nothing
					}
				void $ inRepo $ runBool [Param "add", File infofile]
				signFile infofile
				signFile (basedir </> f)
	void $ inRepo $ runBool
		[ Param "commit"
		, Param "-m"
		, Param $ "updated info files for git-annex " ++ version
		]
	void $ inRepo $ runBool
		[ Param "annex"
		, Params "move --to website"
		]
	void $ inRepo $ runBool
		[ Param "annex"
		, Params "sync"
		]

	-- Check for out of date info files.
	infos <- liftIO $ filter (".info" `isSuffixOf`)
		<$> dirContentsRecursive (basedir </> "git-annex")
	ds <- liftIO $ forM infos (readish <$$> readFile)
	let dis = zip infos ds
	let ood = filter (outofdate version) dis
	unless (null ood) $
		error $ "Some info files are out of date: " ++ show (map fst ood)
  where
	outofdate version (_, md) = case md of
		Nothing -> True
		Just d -> distributionVersion d /= version

getRepoDir :: IO FilePath
getRepoDir = do
	home <- liftIO myHomeDir
	return $ home </> "lib" </> "downloads"

mkUrl :: FilePath -> String
mkUrl f = "https://downloads.kitenet.net/" ++ f

signFile :: FilePath -> Annex ()
signFile f = do
	void $ liftIO $ boolSystem "gpg"
		[ Param "-a"
		, Param $ "--default-key=" ++ signingKey
		, Param "--detach-sign"
		, File f
		]
	liftIO $ rename (f ++ ".asc") (f ++ ".sig")
	void $ inRepo $ runBool [Param "add", File (f ++ ".sig")]


code:
{- Allows linking haskell programs too big for all the files to fit in a
 - command line.
 -
 - See https://ghc.haskell.org/trac/ghc/ticket/8596
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Main where

import Data.List.Utils
import Text.Parsec
import Text.Parsec.String
import Control.Applicative ((<$>))
import Control.Monad
import System.Directory
import Data.Maybe
import Data.List

import Utility.Monad
import Utility.Process hiding (env)
import Utility.Env

data CmdParams = CmdParams
	{ cmd :: String
	, opts :: String
	, env :: Maybe [(String, String)]
	} deriving (Show)

{- Find where ghc calls gcc to link the executable. -}
parseGhcLink :: Parser CmdParams
parseGhcLink = do
	void $ many prelinkline
	void linkheaderline
	void $ char '"'
	gcccmd <- many1 (noneOf "\"")
	void $ string "\" "
	gccparams <- restOfLine
	return $ CmdParams gcccmd (manglepaths gccparams) Nothing
  where
	linkheaderline = do
		void $ string "*** Linker"
		restOfLine
	prelinkline = do
		void $ notFollowedBy linkheaderline
		restOfLine
	manglepaths = replace "\\" "/"

{- Find where gcc calls collect2. -}
parseGccLink :: Parser CmdParams
parseGccLink = do
	cenv <- collectenv
	void $ try $ char ' '
	path <- manyTill anyChar (try $ string collectcmd)
	void $ char ' '
	collect2params <- restOfLine
	return $ CmdParams (path ++ collectcmd) (escapeDosPaths collect2params) cenv
  where
  	collectcmd = "collect2.exe"
  	collectgccenv = "COLLECT_GCC"
	collectltoenv = "COLLECT_LTO_WRAPPER"
	pathenv = "COMPILER_PATH"
	libpathenv = "LIBRARY_PATH"
  	optenv = "COLLECT_GCC_OPTIONS"
  	collectenv = do
		void $ many1 $ do
			notFollowedBy $ string collectgccenv
			restOfLine
		void $ string collectgccenv
		void $ char '='
		g <- restOfLine
		void $ string collectltoenv
		void $ char '='
		lt <- restOfLine
		void $ many1 $ do
			notFollowedBy $ string pathenv
			restOfLine
		void $ string pathenv
		void $ char '='
		p <- restOfLine
		void $ string libpathenv
		void $ char '='
		lp <- restOfLine
		void $ string optenv
		void $ char '='
		o <- restOfLine
		return $ Just [(collectgccenv, g), (collectltoenv, lt), (pathenv, p), (libpathenv, lp), (optenv, o)]

{- Find where collect2 calls ld. -}
parseCollect2 :: Parser CmdParams
parseCollect2 = do
	void $ manyTill restOfLine (try versionline)
	path <- manyTill anyChar (try $ string ldcmd)
	void $ char ' '
	params <- restOfLine
	return $ CmdParams (path ++ ldcmd) (skipHack $ escapeDosPaths params) Nothing
  where
	ldcmd = "ld.exe"
	versionline = do
		void $ string "collect2 version"
		restOfLine

{- For unknown reasons, asking the linker to link this in fails,
 - with error about multiple definitions of a symbol from the library.
 - This is a horrible hack. -}
skipHack :: String -> String
skipHack = replace "dist/build/git-annex/git-annex-tmp/Utility/winprocess.o" ""

{- Input contains something like
 - c:/program files/haskell platform/foo -LC:/Program Files/Haskell Platform/ -L...
 - and the *right* spaces must be escaped with \
 -
 - Argh.
 -}
escapeDosPaths :: String -> String
escapeDosPaths = replace "Program Files" "Program\\ Files"
	. replace "program files" "program\\ files"
	. replace "Haskell Platform" "Haskell\\ Platform"
	. replace "haskell platform" "haskell\\ platform"
	. replace "Application Data" "Application\\ Data"
	. replace "Documents and Settings" "Documents\\ and\\ Settings"
	. replace "Files (x86)" "Files\\ (x86)"
	. replace "files (x86)" "files\\ (x86)"

restOfLine :: Parser String
restOfLine = newline `after` many (noneOf "\n")

getOutput :: String -> [String] -> Maybe [(String, String)] -> IO (String, Bool)
getOutput c ps environ = do
	putStrLn $ unwords [c, show ps]
	systemenviron <- getEnvironment
	let environ' = fromMaybe [] environ ++ systemenviron
	out@(_, ok) <- processTranscript' c ps (Just environ') Nothing
	putStrLn $ unwords [c, "finished", show ok]
	return out

atFile :: FilePath -> String
atFile f = '@':f

runAtFile :: Parser CmdParams -> String -> FilePath -> [String] -> IO (String, Bool)
runAtFile p s f extraparams = do
	when (null $ opts c) $
		error $ "failed to find any options for " ++ f ++ " in >>>" ++ s ++ "<<<"
	writeFile f (opts c)
	out <- getOutput (cmd c) (atFile f:extraparams) (env c)
	removeFile f
	return out
  where
 	c = case parse p "" s of
		Left e -> error $
			(show e) ++
			"\n<<<\n" ++ s ++ "\n>>>"
		Right r -> r

main :: IO ()
main = do
	ghcout <- fst <$> getOutput "cabal"
		["build", "--ghc-options=-v -keep-tmp-files"] Nothing
	gccout <- fst <$> runAtFile parseGhcLink ghcout "gcc.opt" ["-v"]
	collect2out <- fst <$> runAtFile parseGccLink gccout "collect2.opt" ["-v"]
	(out, ok) <- runAtFile parseCollect2 collect2out "ld.opt" []
	unless ok $
		error $ "ld failed:\n" ++ out


code:
{- Expands template haskell splices
 -
 - You should probably just use http://hackage.haskell.org/package/zeroth
 - instead. I wish I had known about it before writing this.
 -
 - First, the code must be built with a ghc that supports TH,
 - and the splices dumped to a log. For example:
 -   cabal build --ghc-options=-ddump-splices 2>&1 | tee log
 -
 - Along with the log, a headers file may also be provided, containing
 - additional imports needed by the template haskell code.
 -
 - This program will parse the log, and expand all splices therein,
 - writing files to the specified destdir (which can be "." to modify
 - the source tree directly). They can then be built a second
 - time, with a ghc that does not support TH.
 -
 - Note that template haskell code may refer to symbols that are not
 - exported by the library that defines the TH code. In this case,
 - the library has to be modifed to export those symbols.
 -
 - There can also be other problems with the generated code; it may
 - need modifications to compile.
 -
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Main where

import Text.Parsec
import Text.Parsec.String
import Control.Applicative ((<$>))
import Data.Either
import Data.List hiding (find)
import Data.String.Utils
import Data.Char
import System.Environment
import System.FilePath
import System.Directory
import System.IO
import Control.Monad
import Prelude hiding (log)

import Utility.Monad
import Utility.Misc
import Utility.Exception
import Utility.Path
import Utility.FileSystemEncoding

data Coord = Coord
	{ coordLine :: Int
	, coordColumn :: Int
	}
	deriving (Read, Show)

offsetCoord :: Coord -> Coord -> Coord
offsetCoord a b = Coord
	(coordLine a - coordLine b)
	(coordColumn a - coordColumn b)

data SpliceType = SpliceExpression | SpliceDeclaration
	deriving (Read, Show, Eq)

data Splice = Splice
	{ splicedFile :: FilePath
	, spliceStart :: Coord
	, spliceEnd :: Coord
	, splicedExpression :: String
	, splicedCode :: String
	, spliceType :: SpliceType
	}
	deriving (Read, Show)

isExpressionSplice :: Splice -> Bool
isExpressionSplice s = spliceType s == SpliceExpression

number :: Parser Int
number = read <$> many1 digit

{- A pair of Coords is written in one of three ways:
 - "95:21-73", "1:1", or "(92,25)-(94,2)"
 -}
coordsParser :: Parser (Coord, Coord)
coordsParser = (try singleline <|> try weird <|> multiline) <?> "Coords"
  where
  	singleline = do
		line <- number
		void $ char ':'
		startcol <- number
		void $ char '-'
		endcol <- number
		return $ (Coord line startcol, Coord line endcol)

	weird = do
		line <- number
		void $ char ':'
		col <- number
		return $ (Coord line col, Coord line col)

	multiline = do
		start <- fromparens
		void $ char '-'
		end <- fromparens
		return $ (start, end)

	fromparens = between (char '(') (char ')') $ do
		line <- number
		void $ char ','
		col <- number
		return $ Coord line col

indent :: Parser String
indent = many1 $ char ' '

restOfLine :: Parser String
restOfLine = newline `after` many (noneOf "\n")

indentedLine :: Parser String
indentedLine = indent >> restOfLine

spliceParser :: Parser Splice
spliceParser = do
	file <- many1 (noneOf ":\n")
	void $ char ':'
	(start, end) <- coordsParser
	void $ string ": Splicing "
	splicetype <- tosplicetype
		<$> (string "expression" <|> string "declarations")
	void newline

	getthline <- expressionextractor
	expression <- unlines <$> many1 getthline

	void indent
	void $ string "======>"
	void newline

	getcodeline <- expressionextractor
	realcoords <- try (Right <$> getrealcoords file) <|> (Left <$> getcodeline)
	codelines <- many getcodeline
	return $ case realcoords of
		Left firstcodeline ->
			Splice file start end expression
				(unlines $ firstcodeline:codelines)
				splicetype
		Right (realstart, realend) ->
			Splice file realstart realend expression
				(unlines codelines)
				splicetype
  where
  	tosplicetype "declarations" = SpliceDeclaration
	tosplicetype "expression" = SpliceExpression
	tosplicetype s = error $ "unknown splice type: " ++ s

	{- All lines of the indented expression start with the same
	 - indent, which is stripped. Any other indentation is preserved. -}
	expressionextractor = do
		i <- lookAhead indent
		return $ try $ do
			void $ string i
			restOfLine

	{- When splicing declarations, GHC will output a splice
	 - at 1:1, and then inside the splice code block,
	 - the first line will give the actual coordinates of the
	 - line that was spliced. -}
	getrealcoords file = do
		void indent
		void $ string file
		void $ char ':'
		char '\n' `after` coordsParser

{- Extracts the splices, ignoring the rest of the compiler output. -}
splicesExtractor :: Parser [Splice]
splicesExtractor = rights <$> many extract
  where
  	extract = try (Right <$> spliceParser) <|> (Left <$> compilerJunkLine)
	compilerJunkLine = restOfLine

{- Modifies the source file, expanding the splices, which all must
 - have the same splicedFile. Writes the new file to the destdir.
 -
 - Each splice's Coords refer to the original position in the file,
 - and not to its position after any previous splices may have inserted
 - or removed lines.
 -
 - To deal with this complication, the file is broken into logical lines
 - (which can contain any String, including a multiline or empty string).
 - Each splice is assumed to be on its own block of lines; two
 - splices on the same line is not currently supported.
 - This means that a splice can modify the logical lines within its block
 - as it likes, without interfering with the Coords of other splices.
 -
 - As well as expanding splices, this can add a block of imports to the
 - file. These are put right before the first line in the file that
 - starts with "import "
 -}
applySplices :: FilePath -> Maybe String -> [Splice] -> IO ()
applySplices _ _ [] = noop
applySplices destdir imports splices@(first:_) = do
	let f = splicedFile first
	let dest = (destdir </> f)
	lls <- map (++ "\n") . lines <$> readFileStrictAnyEncoding f
	createDirectoryIfMissing True (parentDir dest)
	let newcontent = concat $ addimports $ expand lls splices
	oldcontent <- catchMaybeIO $ readFileStrictAnyEncoding dest
	when (oldcontent /= Just newcontent) $ do
		putStrLn $ "splicing " ++ f
		withFile dest WriteMode $ \h -> do
		        fileEncoding h
			hPutStr h newcontent
		        hClose h
  where
  	expand lls [] = lls
  	expand lls (s:rest)
		| isExpressionSplice s = expand (expandExpressionSplice s lls) rest
		| otherwise = expand (expandDeclarationSplice s lls) rest

	addimports lls = case imports of
		Nothing -> lls
		Just v ->
			let (start, end) = break ("import " `isPrefixOf`) lls
			in if null end
				then start
				else concat
					[ start
					, [v]
					, end
					]

{- Declaration splices are expanded to replace their whole line. -}
expandDeclarationSplice :: Splice -> [String] -> [String]
expandDeclarationSplice s lls = concat [before, [splice], end]
  where
	cs = spliceStart s
	ce = spliceEnd s

	(before, rest) = splitAt (coordLine cs - 1) lls
	(_oldlines, end) = splitAt (1 + coordLine (offsetCoord ce cs)) rest
	splice = mangleCode $ splicedCode s

{- Expression splices are expanded within their line. -}
expandExpressionSplice :: Splice -> [String] -> [String]
expandExpressionSplice sp lls = concat [before, spliced:padding, end]
  where
	cs = spliceStart sp
	ce = spliceEnd sp

	(before, rest) = splitAt (coordLine cs - 1) lls
	(oldlines, end) = splitAt (1 + coordLine (offsetCoord ce cs)) rest
	(splicestart, padding, spliceend) = case map expandtabs oldlines of
		ss:r
			| null r -> (ss, [], ss)
			| otherwise -> (ss, take (length r) (repeat []), last r)
		_ -> ([], [], [])
	spliced = concat
		[ joinsplice $ deqqstart $ take (coordColumn cs - 1) splicestart
		, addindent (findindent splicestart) (mangleCode $ splicedCode sp)
		, deqqend $ drop (coordColumn ce) spliceend
		]

	{- coordinates assume tabs are expanded to 8 spaces -}
	expandtabs = replace "\t" (take 8 $ repeat ' ')

	{- splicing leaves $() quasiquote behind; remove it -}
	deqqstart s = case reverse s of
		('(':'$':restq) -> reverse restq
		_ -> s
	deqqend (')':s) = s
	deqqend s = s

	{- Prepare the code that comes just before the splice so
	 - the splice will combine with it appropriately. -}
	joinsplice s
		-- all indentation? Skip it, we'll use the splice's indentation
		| all isSpace s = ""
		-- function definition needs no preparation
		-- ie: foo = $(splice)
		| "=" `isSuffixOf` s' = s
		-- nor does lambda definition or case expression
		| "->" `isSuffixOf` s' = s
		-- nor does a let .. in declaration
		| "in" `isSuffixOf` s' = s
		-- already have a $ to set off the splice
		-- ie: foo $ $(splice)
		| "$" `isSuffixOf` s' = s
		-- need to add a $ to set off the splice
		-- ie: bar $(splice)
		| otherwise = s ++ " $ "
	  where
	  	s' = filter (not . isSpace) s

	findindent = length . takeWhile isSpace
	addindent n = unlines . map (i ++) . lines
	  where
	  	i = take n $ repeat ' '

{- Tweaks code output by GHC in splices to actually build. Yipes. -}
mangleCode :: String -> String
mangleCode = flip_colon
	. remove_unnecessary_type_signatures
	. lambdaparenhack
	. lambdaparens
	. declaration_parens
	. case_layout
	. case_layout_multiline
	. yesod_url_render_hack
	. text_builder_hack
	. nested_instances
	. boxed_fileembed
	. collapse_multiline_strings
	. remove_package_version
	. emptylambda
  where
  	{- Lambdas are often output without parens around them.
	 - This breaks when the lambda is immediately applied to a
	 - parameter.
	 -
	 - For example:
	 -
	 - renderRoute (StaticR sub_a1nUH)
	 -   = \ (a_a1nUI, b_a1nUJ)
	 -       -> (((pack "static") : a_a1nUI),
	 -            b_a1nUJ)
	 -       (renderRoute sub_a1nUH)
	 -
	 - There are sometimes many lines of lambda code that need to be
	 - parenthesised. Approach: find the "->" and scan down the
	 - column to the first non-whitespace. This is assumed
	 - to be the expression after the lambda.
	 -
	 - Runs recursively on the body of the lambda, to handle nested
	 - lambdas.
	 -}
	lambdaparens = parsecAndReplace $ do
		-- skip lambdas inside tuples or parens
		prefix <- noneOf "(, \n"
		preindent <- many1 $ oneOf " \n"
		void $ string "\\ "
		lambdaparams <- restofline
		continuedlambdaparams <- many $ try $ do
			indent1 <- many1 $ char ' '
			p <- satisfy isLetter
			aram <- many $ satisfy isAlphaNum <|> oneOf "_"
			void newline
			return $ indent1 ++ p:aram ++ "\n"
		indent1 <- many1 $ char ' '
		void $ string "-> "
		firstline <- restofline
		lambdalines <- many $ try $ do
			void $ string indent1
			void $ char ' '
			l <- restofline
			return $ indent1 ++ " " ++ l
		return $ concat
			[ prefix:preindent
			, "(\\ " ++ lambdaparams ++ "\n"
			, concat continuedlambdaparams
			, indent1 ++ "-> "
			, lambdaparens $ intercalate "\n" (firstline:lambdalines)
			, ")\n"
			]

	{- Hack to add missing parens in a specific case in yesod
	 - static route code.
	 -
	 -     StaticR
	 -     yesod_dispatch_env_a4iDV
	 -     (\ p_a4iE2 r_a4iE3
	 -        -> r_a4iE3
	 -          {Network.Wai.pathInfo = p_a4iE2}
	 -        xrest_a4iDT req_a4iDW)) }
	 -
	 - Need to add another paren around the lambda, and close it
	 - before its parameters. lambdaparens misses this one because
	 - there is already one paren present.
	 -
	 - Note that the { } may be on the same line, or wrapped to next.
	 -
	 - FIXME: This is a hack. lambdaparens could just always add a
	 - layer of parens even when a lambda seems to be in parent.
	 -}
	lambdaparenhack = parsecAndReplace $ do
		indent1 <- many1 $ char ' '
		staticr <- string "StaticR"
		void newline
		void $ string indent1
		yesod_dispatch_env <- restofline
		void $ string indent1
		lambdaprefix <- string "(\\ "
		l1 <- restofline
		void $ string indent1
		lambdaarrow <- string "   ->"
		l2 <- restofline
		l3 <- if '{' `elem` l2 && '}' `elem` l2
			then return ""
			else do
				void $ string indent1
				restofline
		return $ unlines
			[ indent1 ++ staticr
			, indent1 ++ yesod_dispatch_env
			, indent1 ++ "(" ++ lambdaprefix ++ l1
			, indent1 ++ lambdaarrow ++ l2 ++ l3 ++ ")"
			]

	restofline = manyTill (noneOf "\n") newline

  	{- For some reason, GHC sometimes doesn't like the multiline
	 - strings it creates. It seems to get hung up on \{ at the
	 - start of a new line sometimes, wanting it to not be escaped.
	 -
	 - To work around what is likely a GHC bug, just collapse
	 - multiline strings. -}
	collapse_multiline_strings = parsecAndReplace $ do
		void $ string "\\\n"
		void $ many1 $ oneOf " \t"
		void $ string "\\"
		return "\\n"

	{- GHC outputs splices using explicit braces rather than layout.
	 - For a case expression, it does something weird:
	 -
	 - case foo of {
	 -   xxx -> blah
	 -   yyy -> blah };
	 -
	 - This is not legal Haskell; the statements in the case must be
	 - separated by ';'
	 -
	 - To fix, we could just put a semicolon at the start of every line
	 - containing " -> " ... Except that lambdas also contain that.
	 - But we can get around that: GHC outputs lambas like this:
	 -
	 - \ foo
	 -   -> bar
	 -
	 - Or like this:
	 -
	 - \ foo -> bar
	 -
	 - So, we can put the semicolon at the start of every line
	 - containing " -> " unless there's a "\ " first, or it's
	 - all whitespace up until it.
	 -}
	case_layout = parsecAndReplace $ do
		void newline
		indent1 <- many1 $ char ' '
		prefix <- manyTill (noneOf "\n") (try (string "-> "))
		if length prefix > 10
			then unexpected "too long a prefix"
			else if "\\ " `isInfixOf` prefix
				then unexpected "lambda expression"
				else if null prefix
					then unexpected "second line of lambda"
					else return $ "\n" ++ indent1 ++ "; " ++ prefix ++ " -> "
	{- Sometimes cases themselves span multiple lines:
	 -
	 - Nothing
	 -   -> foo
	 -
	 - -- This is not yet handled!
	 - ComplexConstructor  var var
	 -        var var
	 -   -> foo
	 -}
	case_layout_multiline = parsecAndReplace $ do
		void newline
		indent1 <- many1 $ char ' '
		firstline <- restofline

		void $ string indent1
		indent2 <- many1 $ char ' '
		void $ string "-> "
		if "\\ " `isInfixOf` firstline
			then unexpected "lambda expression"
			else return $ "\n" ++ indent1 ++ "; " ++ firstline ++ "\n"
				++ indent1 ++ indent2 ++ "-> "

	{- (foo, \ -> bar) is not valid haskell, GHC.
	 - Change to (foo, bar)
	 -
	 - (Does this ever happen outside a tuple? Only saw
	 - it inside them..
	 -}
	emptylambda = replace ", \\ -> " ", "

	{- GHC may output this:
	 -
	 - instance RenderRoute WebApp where
	 -   data instance Route WebApp
	 -        ^^^^^^^^
	 - The marked word should not be there.
	 -
	 - FIXME: This is a yesod-specific hack, it should look for the
	 - outer instance.
	 -}
	nested_instances = replace "  data instance Route" "  data Route"

	{- GHC does not properly parenthesise generated data type
	 - declarations. -}
	declaration_parens = replace "StaticR Route Static" "StaticR (Route Static)"

	{- A type signature is sometimes given for an entire lambda,
	 - which is not properly parenthesized or laid out. This is a
	 - hack to remove one specific case where this happens and the
	 - signature is easily inferred, so is just removed.
	 -}
	remove_unnecessary_type_signatures = parsecAndReplace $ do
		void $ string " ::"
		void newline
		void $ many1 $ char ' '
		void $ string "Text.Css.Block Text.Css.Resolved"
		void newline
		return ""

	{- GHC may add full package and version qualifications for
	 - symbols from unimported modules. We don't want these.
	 -
	 - Examples:
	 -   "blaze-html-0.4.3.1:Text.Blaze.Internal.preEscapedText"
	 -   "ghc-prim:GHC.Types.:"
	 -}
	remove_package_version = parsecAndReplace $
		mangleSymbol <$> qualifiedSymbol

	mangleSymbol "GHC.Types." = ""
	mangleSymbol "GHC.Tuple." = ""
	mangleSymbol s = s

	qualifiedSymbol :: Parser String
	qualifiedSymbol = do
		s <- hstoken
		void $ char ':'
		if length s < 5
			then unexpected "too short to be a namespace"
			else do
				t <- hstoken
				case t of
					(c:r) | isUpper c && "." `isInfixOf` r -> return t
					_ -> unexpected "not a module qualified symbol"

	hstoken :: Parser String
	hstoken = do
		t <- satisfy isLetter
		oken <- many $ satisfy isAlphaNum <|> oneOf "-.'"
		return $ t:oken

	{- This works when it's "GHC.Types.:", but we strip
	 - that above, so have to fix up after it here.
	 - The ; is added by case_layout. -}
	flip_colon = replace "; : _ " "; _ : "

{- Embedded files use unsafe packing, which is problimatic
 - for several reasons, including that GHC sometimes omits trailing
 - newlines in the file content, which leads to the wrong byte
 - count. Also, GHC sometimes outputs unicode characters, which
 - are not legal in unboxed strings.
 -
 - Avoid problems by converting:
 - GHC.IO.unsafePerformIO
 -   (Data.ByteString.Unsafe.unsafePackAddressLen
 -      lllll
 -      "blabblah"#)),
 - to:
 - Data.ByteString.Char8.pack "blabblah"),
 -
 - Note that the string is often multiline. This only works if
 - collapse_multiline_strings has run first.
 -}
boxed_fileembed :: String -> String
boxed_fileembed = parsecAndReplace $ do
	i <- indent
	void $ string "GHC.IO.unsafePerformIO"
	void newline
	void indent
	void $ string "(Data.ByteString.Unsafe.unsafePackAddressLen"
	void newline
	void indent
	void number
	void newline
	void indent
	void $ char '"'
	s <- restOfLine
	let s' = take (length s - 5) s
	if "\"#))," `isSuffixOf` s
		then return (i ++ "Data.ByteString.Char8.pack \"" ++ s' ++ "\"),\n")
		else fail "not an unboxed string"

{- This works around a problem in the expanded template haskell for Yesod
 - type-safe url rendering.
 -
 - It generates code like this:
 -
 -                                  (toHtml
 -                                     (\ u_a2ehE -> urender_a2ehD u_a2ehE []
 -                                        (CloseAlert aid)))));
 -
 - Where urender_a2ehD is the function returned by getUrlRenderParams.
 - But, that function that only takes 2 params, not 3.
 - And toHtml doesn't take a parameter at all!
 -
 - So, this modifes the code, to look like this:
 -
 -                                  (toHtml
 -                                     (flip urender_a2ehD []
 -                                        (CloseAlert aid)))));
 -
 - FIXME: Investigate and fix this properly.
 -}
yesod_url_render_hack :: String -> String
yesod_url_render_hack = parsecAndReplace $ do
	void $ string "(toHtml"
	void whitespace
	void $ string "(\\"
	void whitespace
	wtf <- hstoken
	void whitespace
	void $ string "->"
	void whitespace
	renderer <- hstoken
	void whitespace
	void $ string wtf
	void whitespace
	return $ "(toHtml (flip " ++ renderer ++ " "
  where
	whitespace :: Parser String
	whitespace = many $ oneOf " \t\r\n"

	hstoken :: Parser String
	hstoken = many1 $ satisfy isAlphaNum <|> oneOf "_"

{- Use exported symbol. -}
text_builder_hack :: String -> String
text_builder_hack = replace "Data.Text.Lazy.Builder.Internal.fromText" "Data.Text.Lazy.Builder.fromText"

{- Given a Parser that finds strings it wants to modify,
 - and returns the modified string, does a mass
 - find and replace throughout the input string.
 - Rather slow, but crazy powerful. -}
parsecAndReplace :: Parser String -> String -> String
parsecAndReplace p s = case parse find "" s of
	Left _e -> s
	Right l -> concatMap (either return id) l
  where
  	find :: Parser [Either Char String]
	find = many $ try (Right <$> p) <|> (Left <$> anyChar)

main :: IO ()
main = go =<< getArgs
  where
	go (destdir:log:header:[]) = run destdir log (Just header)
	go (destdir:log:[]) = run destdir log Nothing
  	go _ = error "usage: EvilSplicer destdir logfile [headerfile]"

	run destdir log mheader = do
		r <- parseFromFile splicesExtractor log
		case r of
			Left e -> error $ show e
			Right splices -> do
				let groups = groupBy (\a b -> splicedFile a == splicedFile b) splices
				imports <- maybe (return Nothing) (catchMaybeIO . readFile) mheader
				mapM_ (applySplices destdir imports) groups


code:
{- Generating and installing a desktop menu entry file and icon,
 - and a desktop autostart file. (And OSX equivilants.)
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Main where

import Build.DesktopFile

import System.Environment

main :: IO ()
main = getArgs >>= go
  where
	go [] = error "specify git-annex command"
	go (command:_) = install command


code:
{- Linux library copier and binary shimmer
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Main where

import Control.Applicative
import System.Environment
import Data.Maybe
import System.FilePath
import System.Directory
import Control.Monad
import Data.List
import System.Posix.Files
import Control.Monad.IfElse

import Utility.LinuxMkLibs
import Utility.Directory
import Utility.Process
import Utility.Monad
import Utility.Path
import Utility.FileMode
import Utility.CopyFile

main :: IO ()
main = getArgs >>= go
  where
	go [] = error "specify LINUXSTANDALONE_DIST"
	go (top:_) = mklibs top

mklibs :: FilePath -> IO ()
mklibs top = do
	fs <- dirContentsRecursive top
	mapM_ symToHardLink fs
	exes <- filterM checkExe fs
	libs <- parseLdd <$> readProcess "ldd" exes
	glibclibs <- glibcLibs
	let libs' = nub $ libs ++ glibclibs
	libdirs <- nub . catMaybes <$> mapM (installLib installFile top) libs'

	-- Various files used by runshell to set up env vars used by the
	-- linker shims.
	writeFile (top </> "libdirs") (unlines libdirs)
	writeFile (top </> "linker")
		(Prelude.head $ filter ("ld-linux" `isInfixOf`) libs')
	writeFile (top </> "gconvdir")
		(parentDir $ Prelude.head $ filter ("/gconv/" `isInfixOf`) glibclibs)

	mapM_ (installLinkerShim top) exes

{- Installs a linker shim script around a binary.
 -
 - Note that each binary is put into its own separate directory,
 - to avoid eg git looking for binaries in its directory rather
 - than in PATH.-}
installLinkerShim :: FilePath -> FilePath -> IO ()
installLinkerShim top exe = do
	createDirectoryIfMissing True shimdir
	renameFile exe exedest
	writeFile exe $ unlines
		[ "#!/bin/sh"
		, "exec \"$GIT_ANNEX_LINKER\" --library-path \"$GIT_ANNEX_LD_LIBRARY_PATH\" \"$GIT_ANNEX_SHIMMED/" ++ base ++ "/" ++ base ++ "\" \"$@\""
		]
	modifyFileMode exe $ addModes executeModes
  where
	base = takeFileName exe
	shimdir = top </> "shimmed" </> base
	exedest = shimdir </> base

{- Converting symlinks to hard links simplifies the binary shimming
 - process. -}
symToHardLink :: FilePath -> IO ()
symToHardLink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus f) $ do
	l <- readSymbolicLink f
	let absl = absPathFrom (parentDir f) l
	nukeFile f
	createLink absl f

installFile :: FilePath -> FilePath -> IO ()
installFile top f = do
	createDirectoryIfMissing True destdir
	void $ copyFileExternal f destdir
  where
	destdir = inTop top $ parentDir f

checkExe :: FilePath -> IO Bool
checkExe f
	| ".so" `isSuffixOf` f = return False
	| otherwise = ifM (isExecutable . fileMode <$> getFileStatus f)
		( checkFileExe <$> readProcess "file" [f]
		, return False
		)

{- Check that file(1) thinks it's a Linux ELF executable, or possibly
 - a shared library (a few executables like ssh appear as shared libraries). -}
checkFileExe :: String -> Bool
checkFileExe s = and
	[ "ELF" `isInfixOf` s
	, "executable" `isInfixOf` s || "shared object" `isInfixOf` s
	]


code:
{- Generates a NullSoft installer program for git-annex on Windows.
 -
 - To build the installer, git-annex should already be built by cabal,
 - and ssh and rsync, as well as cygwin libraries, already installed.
 -
 - This uses the Haskell nsis package (cabal install nsis)
 - to generate a .nsi file, which is then used to produce
 - git-annex-installer.exe
 -
 - The installer includes git-annex, and utilities it uses, with the
 - exception of git. The user needs to install git separately,
 - and the installer checks for that.
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE OverloadedStrings #-}

import Development.NSIS
import System.Directory
import System.FilePath
import Control.Monad
import Data.String
import Data.Maybe

import Utility.Tmp
import Utility.Path
import Utility.CopyFile
import Utility.SafeCommand
import Build.BundledPrograms

main = do
	withTmpDir "nsis-build" $ \tmpdir -> do
		let gitannex = tmpdir </> gitannexprogram
		mustSucceed "ln" [File "dist/build/git-annex/git-annex.exe", File gitannex]
		let license = tmpdir </> licensefile
		mustSucceed "sh" [Param "-c", Param $ "zcat standalone/licences.gz > '" ++ license ++ "'"]
		extrabins <- forM (cygwinPrograms ++ cygwinDlls) $ \f -> do
			p <- searchPath f
			when (isNothing p) $
				print ("unable to find in PATH", f)
			return p
		webappscript <- vbsLauncher tmpdir "git-annex-webapp" "git-annex webapp"
		autostartscript <- vbsLauncher tmpdir "git-annex-autostart" "git annex assistant --autostart"
		writeFile nsifile $ makeInstaller gitannex license
			(catMaybes extrabins)
			[ webappscript, autostartscript ]
		mustSucceed "makensis" [File nsifile]
	removeFile nsifile -- left behind if makensis fails
  where
	nsifile = "git-annex.nsi"
	mustSucceed cmd params = do
		r <- boolSystem cmd params
		case r of
			True -> return ()
			False -> error $ cmd ++ " failed"

{- Generates a .vbs launcher which runs a command without any visible DOS
 - box. -}
vbsLauncher :: FilePath -> String -> String -> IO String
vbsLauncher tmpdir basename cmd = do
	let f = tmpdir </> basename ++ ".vbs"
	writeFile f $ unlines
		[ "Set objshell=CreateObject(\"Wscript.Shell\")"
		, "objShell.Run(\"" ++ cmd ++ "\"), 0, False"
		]
	return f

gitannexprogram :: FilePath
gitannexprogram = "git-annex.exe"

licensefile :: FilePath
licensefile = "git-annex-licenses.txt"

installer :: FilePath
installer = "git-annex-installer.exe"

uninstaller :: FilePath
uninstaller = "git-annex-uninstall.exe"

gitInstallDir :: Exp FilePath
gitInstallDir = fromString "$PROGRAMFILES\\Git"

startMenuItem :: Exp FilePath
startMenuItem = "$SMPROGRAMS/git-annex.lnk"

autoStartItem :: Exp FilePath
autoStartItem = "$SMSTARTUP/git-annex-autostart.lnk"

needGit :: Exp String
needGit = strConcat
	[ fromString "You need git installed to use git-annex. Looking at "
	, gitInstallDir
	, fromString " , it seems to not be installed, "
	, fromString "or may be installed in another location. "
	, fromString "You can install git from http:////git-scm.com//"
	]

makeInstaller :: FilePath -> FilePath -> [FilePath] -> [FilePath] -> String
makeInstaller gitannex license extrabins launchers = nsis $ do
	name "git-annex"
	outFile $ str installer
	{- Installing into the same directory as git avoids needing to modify
 	 - path myself, since the git installer already does it. -}
	installDir gitInstallDir
	requestExecutionLevel Admin

	iff (fileExists gitInstallDir)
		(return ())
		(alert needGit)

	-- Pages to display
	page Directory                   -- Pick where to install
	page (License license)
	page InstFiles                   -- Give a progress bar while installing
	-- Start menu shortcut
	Development.NSIS.createDirectory "$SMPROGRAMS"
	createShortcut startMenuItem
		[ Target "wscript.exe"
		, Parameters "\"$INSTDIR/git-annex-webapp.vbs\""
		, StartOptions "SW_SHOWNORMAL"
		, IconFile "$INSTDIR/cmd/git-annex.exe"
		, IconIndex 2
		, KeyboardShortcut "ALT|CONTROL|a"
		, Description "git-annex webapp"
		]
	createShortcut autoStartItem
		[ Target "wscript.exe"
		, Parameters "\"$INSTDIR/git-annex-autostart.vbs\""
		, StartOptions "SW_SHOWNORMAL"
		, IconFile "$INSTDIR/cmd/git-annex.exe"
		, IconIndex 2
		, Description "git-annex autostart"
		]
	section "bins" [] $ do
		setOutPath "$INSTDIR\\bin"
		mapM_ addfile extrabins
	section "cmd" [] $ do
		setOutPath "$INSTDIR\\cmd"
		addfile gitannex
	section "meta" [] $ do
		setOutPath "$INSTDIR"
		addfile license
		mapM_ addfile launchers
		writeUninstaller $ str uninstaller
	uninstall $ do
		delete [RebootOK] $ startMenuItem
		delete [RebootOK] $ autoStartItem
		removefilesFrom "$INSTDIR/bin" extrabins
		removefilesFrom "$INSTDIR/cmd" [gitannex]
		removefilesFrom "$INSTDIR" $
			launchers ++
			[ license
			, uninstaller
			]
  where
	addfile f = file [] (str f)
	removefilesFrom d = mapM_ (\f -> delete [RebootOK] $ fromString $ d ++ "/" ++ takeFileName f)

cygwinPrograms :: [FilePath]
cygwinPrograms = map (\p -> p ++ ".exe") bundledPrograms

-- These are the dlls needed by Cygwin's rsync, ssh, etc.
-- TODO: Use ldd (available in cygwin) to automatically find all
-- needed libs.
cygwinDlls :: [FilePath]
cygwinDlls =
	[ "cygwin1.dll"
	, "cygasn1-8.dll"
	, "cygattr-1.dll"
	, "cygheimbase-1.dll"
	, "cygroken-18.dll"
	, "cygcom_err-2.dll"
	, "cygheimntlm-0.dll"
	, "cygsqlite3-0.dll"
	, "cygcrypt-0.dll"
	, "cyghx509-5.dll"
	, "cygssp-0.dll"
	, "cygcrypto-1.0.0.dll"
	, "cygiconv-2.dll"
	, "cyggcc_s-1.dll"
	, "cygintl-8.dll"
	, "cygwind-0.dll"
	, "cyggssapi-3.dll"
	, "cygkrb5-26.dll"
	, "cygz.dll"
	, "cygidn-11.dll"
	, "libcurl-4.dll"
	, "cyggnutls-26.dll"
	, "libcrypto.dll"
	, "libssl.dll"
	, "cyggcrypt-11.dll"
	, "cyggpg-error-0.dll"
	, "cygp11-kit-0.dll"
	, "cygtasn1-3.dll"
	, "cygffi-6.dll"
	, "cygbz2-1.dll"
	, "cygreadline7.dll"
	, "cygncursesw-10.dll"
	, "cygusb0.dll"
	]


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

module Main where

import Control.Applicative
import System.Environment (getArgs)
import Data.Maybe
import System.FilePath
import System.Directory
import Control.Monad
import Data.List
import Data.String.Utils

import Utility.PartialPrelude
import Utility.Directory
import Utility.Process
import Utility.Monad
import Utility.SafeCommand
import Utility.Path
import Utility.Exception
import Utility.Env

import qualified Data.Map as M
import qualified Data.Set as S

type LibMap = M.Map FilePath String

{- Recursively find and install libs, until nothing new to install is found. -}
mklibs :: FilePath -> [FilePath] -> [(FilePath, FilePath)] -> LibMap -> IO ()
mklibs appbase libdirs replacement_libs libmap = do
	(new, replacement_libs', libmap') <- installLibs appbase replacement_libs libmap
	unless (null new) $
		mklibs appbase (libdirs++new) replacement_libs' libmap'

{- Returns directories into which new libs were installed. -}
installLibs :: FilePath -> [(FilePath, FilePath)] -> LibMap -> IO ([FilePath], [(FilePath, FilePath)], LibMap)
installLibs appbase replacement_libs libmap = do
	(needlibs, replacement_libs', libmap') <- otool appbase replacement_libs libmap
	libs <- forM needlibs $ \lib -> do
		pathlib <- findLibPath lib
		let shortlib = fromMaybe (error "internal") (M.lookup lib libmap')
		let fulllib = dropWhile (== '/') lib
		let dest = appbase </> fulllib
		let symdest = appbase </> shortlib
		ifM (doesFileExist dest)
			( return Nothing
			, do
				createDirectoryIfMissing True (parentDir dest)
				putStrLn $ "installing " ++ pathlib ++ " as " ++ shortlib
				_ <- boolSystem "cp" [File pathlib, File dest]
				_ <- boolSystem "chmod" [Param "644", File dest]
				_ <- boolSystem "ln" [Param "-s", File fulllib, File symdest]
				return $ Just appbase
			)
	return (catMaybes libs, replacement_libs', libmap')

{- Returns libraries to install.
 -
 - Note that otool -L ignores DYLD_LIBRARY_PATH, so the
 - library files returned may need to be run through findLibPath
 - to find the actual libraries to install.
 -}
otool :: FilePath -> [(FilePath, FilePath)] -> LibMap -> IO ([FilePath], [(FilePath, FilePath)], LibMap)
otool appbase replacement_libs libmap = do
	files <- filterM doesFileExist =<< dirContentsRecursive appbase
	process [] files replacement_libs libmap
  where
	want s = not ("@executable_path" `isInfixOf` s)
		&& not (".framework" `isInfixOf` s)
		&& not ("libSystem.B" `isInfixOf` s)
	process c [] rls m = return (nub $ concat c, rls, m)
	process c (file:rest) rls m = do
		_ <- boolSystem "chmod" [Param "755", File file]
		libs <- filter want . parseOtool
			<$> readProcess "otool" ["-L", file]
		expanded_libs <- expand_rpath libs replacement_libs file
		let rls' = nub $ rls ++ (zip libs expanded_libs)
		m' <- install_name_tool file libs expanded_libs m
		process (expanded_libs:c) rest rls' m'

findLibPath :: FilePath -> IO FilePath
findLibPath l = go =<< getEnv "DYLD_LIBRARY_PATH"
  where
	go Nothing = return l
	go (Just p) = fromMaybe l
		<$> firstM doesFileExist (map (</> f) (split ":" p))
	f = takeFileName l

{- Expands any @rpath in the list of libraries.
 -
 - This is done by the nasty method of running the command with a dummy
 - option (so it doesn't do anything.. hopefully!) and asking the dynamic
 - linker to print expanded rpaths.
 -}
expand_rpath :: [String] -> [(FilePath, FilePath)] -> FilePath -> IO [String]
expand_rpath libs replacement_libs cmd
	| any ("@rpath" `isInfixOf`) libs = do
		installed <- M.fromList . Prelude.read
			<$> readFile "tmp/standalone-installed"
		let origcmd = case M.lookup cmd installed of
			Nothing -> cmd
			Just cmd' -> cmd'
		s <- catchDefaultIO "" $ readProcess "sh" ["-c", probe origcmd]
		let m = if (null s)
			then M.fromList replacement_libs
			else M.fromList $ mapMaybe parse $ lines s
		return $ map (replacem m) libs
	| otherwise = return libs
  where
  	probe c = "DYLD_PRINT_RPATHS=1 " ++ c ++ " --getting-rpath-dummy-option 2>&1 | grep RPATH"
	parse s = case words s of
		("RPATH":"successful":"expansion":"of":old:"to:":new:[]) ->
			Just (old, new)
		_ -> Nothing
	replacem m l = fromMaybe l $ M.lookup l m

parseOtool :: String -> [FilePath]
parseOtool = catMaybes . map parse . lines
  where
	parse l
		| "\t" `isPrefixOf` l = headMaybe $ words l
		| otherwise = Nothing

{- Adjusts binaries to use libraries bundled with it, rather than the
 - system libraries. -}
install_name_tool :: FilePath -> [FilePath] -> [FilePath] -> LibMap -> IO LibMap
install_name_tool _ [] _ libmap = return libmap
install_name_tool binary libs expanded_libs libmap = do
	let (libnames, libmap') = getLibNames expanded_libs libmap
	let params = concatMap change $ zip libs libnames
	ok <- boolSystem "install_name_tool" $ params ++ [File binary]
	unless ok $
		error $ "install_name_tool failed for " ++ binary
	return libmap'
  where
	change (lib, libname) =
		[ Param "-change"
		, File lib
		, Param $ "@executable_path/" ++ libname
		]

getLibNames :: [FilePath] -> LibMap -> ([FilePath], LibMap)
getLibNames libs libmap = go [] libs libmap
  where
	go c [] m = (reverse c, m)
	go c (l:rest) m =
		let (f, m') = getLibName l m
		in go (f:c) rest m'

{- Uses really short names for the library files it installs, because
 - binaries have arbitrarily short RPATH field limits. -}
getLibName :: FilePath -> LibMap -> (FilePath, LibMap)
getLibName lib libmap = case M.lookup lib libmap of
	Just n -> (n, libmap)
	Nothing -> (nextfreename, M.insert lib nextfreename libmap)
  where
	names = map pure ['A' .. 'Z'] ++
		[[n, l] | n <- ['0' .. '9'], l <- ['A' .. 'Z']]
	used = S.fromList $ M.elems libmap
	nextfreename = fromMaybe (error "ran out of short library names!") $
		headMaybe $ dropWhile (`S.member` used) names

main :: IO ()
main = getArgs >>= go
  where
	go [] = error "specify OSXAPP_BASE"
	go (appbase:_) = mklibs appbase [] [] M.empty


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

{-# LANGUAGE CPP #-}

module Main where

import Control.Monad.IfElse
import System.Environment
import System.FilePath
import System.Directory
import Control.Monad
import Build.BundledPrograms

import Utility.SafeCommand
import Utility.Path

progDir :: FilePath -> FilePath
#ifdef darwin_HOST_OS
progDir topdir = topdir
#else
progDir topdir = topdir </> "bin"
#endif

installProg :: FilePath -> FilePath -> IO (FilePath, FilePath)
installProg dir prog = searchPath prog >>= go
  where
	go Nothing = error $ "cannot find " ++ prog ++ " in PATH"
	go (Just f) = do
		let dest = dir </> takeFileName f
		unlessM (boolSystem "install" [File f, File dest]) $
			error $ "install failed for " ++ prog
		return (dest, f)

main :: IO ()
main = getArgs >>= go
  where
	go [] = error "specify topdir"
        go (topdir:_) = do
		let dir = progDir topdir
		createDirectoryIfMissing True dir
		installed <- forM bundledPrograms $ installProg dir
		writeFile "tmp/standalone-installed" (show installed)


code:
{- Tests the system and generates Build.SysConfig.hs. -}

module Build.TestConfig where

import Utility.Path
import Utility.Monad
import Utility.SafeCommand

import System.IO
import System.FilePath
import System.Directory

type ConfigKey = String
data ConfigValue =
	BoolConfig Bool |
	StringConfig String |
	MaybeStringConfig (Maybe String) |
	MaybeBoolConfig (Maybe Bool)
data Config = Config ConfigKey ConfigValue

type Test = IO Config
type TestName = String
data TestCase = TestCase TestName Test

instance Show ConfigValue where
	show (BoolConfig b) = show b
	show (StringConfig s) = show s
	show (MaybeStringConfig s) = show s
	show (MaybeBoolConfig s) = show s

instance Show Config where
	show (Config key value) = unlines
		[ key ++ " :: " ++ valuetype value
		, key ++ " = " ++ show value
		]
	  where
		valuetype (BoolConfig _) = "Bool"
		valuetype (StringConfig _) = "String"
		valuetype (MaybeStringConfig _) = "Maybe String"
		valuetype (MaybeBoolConfig _) = "Maybe Bool"

writeSysConfig :: [Config] -> IO ()
writeSysConfig config = writeFile "Build/SysConfig.hs" body
  where
	body = unlines $ header ++ map show config ++ footer
	header = [
		  "{- Automatically generated. -}"
		, "module Build.SysConfig where"
		, ""
		]
	footer = []

runTests :: [TestCase] -> IO [Config]
runTests [] = return []
runTests (TestCase tname t : ts) = do
	testStart tname
	c <- t
	testEnd c
	rest <- runTests ts
	return $ c:rest

{- Tests that a command is available, aborting if not. -}
requireCmd :: ConfigKey -> String -> Test
requireCmd k cmdline = do
	ret <- testCmd k cmdline
	handle ret
  where
	handle r@(Config _ (BoolConfig True)) = return r
	handle r = do
		testEnd r
		error $ "** the " ++ c ++ " command is required"
	c = head $ words cmdline

{- Checks if a command is available by running a command line. -}
testCmd :: ConfigKey -> String -> Test
testCmd k cmdline = do
	ok <- boolSystem "sh" [ Param "-c", Param $ quiet cmdline ]
	return $ Config k (BoolConfig ok)

{- Ensures that one of a set of commands is available by running each in
 - turn. The Config is set to the first one found. -}
selectCmd :: ConfigKey -> [(String, String)] -> Test
selectCmd k = searchCmd
		(return . Config k . StringConfig)
		(\cmds -> do
			testEnd $ Config k $ BoolConfig False
			error $ "* need one of these commands, but none are available: " ++ show cmds
		)

maybeSelectCmd :: ConfigKey -> [(String, String)] -> Test
maybeSelectCmd k = searchCmd
		(return . Config k . MaybeStringConfig . Just)
		(\_ -> return $ Config k $ MaybeStringConfig Nothing)

searchCmd :: (String -> Test) -> ([String] -> Test) -> [(String, String)] -> Test
searchCmd success failure cmdsparams = search cmdsparams
  where
	search [] = failure $ fst $ unzip cmdsparams
	search ((c, params):cs) = do
		ok <- boolSystem "sh" [ Param "-c", Param $ quiet $ c ++ " " ++ params ]
		if ok
			then success c
			else search cs

{- Finds a command, either in PATH or perhaps in a sbin directory not in
 - PATH. If it's in PATH the config is set to just the command name,
 - but if it's found outside PATH, the config is set to the full path to
 - the command. -}
findCmdPath :: ConfigKey -> String -> Test
findCmdPath k command = do
	ifM (inPath command)
		( return $ Config k $ MaybeStringConfig $ Just command
		, do
			r <- getM find ["/usr/sbin", "/sbin", "/usr/local/sbin"]
			return $ Config k $ MaybeStringConfig r
		)
  where
	find d =
		let f = d </> command
		in ifM (doesFileExist f) ( return (Just f), return Nothing )

quiet :: String -> String
quiet s = s ++ " >/dev/null 2>&1"

testStart :: TestName -> IO ()
testStart s = do
	putStr $ "  checking " ++ s ++ "..."
	hFlush stdout

testEnd :: Config -> IO ()
testEnd (Config _ (BoolConfig True)) = status "yes"
testEnd (Config _ (BoolConfig False)) = status "no"
testEnd (Config _ (StringConfig s)) = status s
testEnd (Config _ (MaybeStringConfig (Just s))) = status s
testEnd (Config _ (MaybeStringConfig Nothing)) = status "not available"
testEnd (Config _ (MaybeBoolConfig (Just True))) = status "yes"
testEnd (Config _ (MaybeBoolConfig (Just False))) = status "no"
testEnd (Config _ (MaybeBoolConfig Nothing)) = status "unknown"

status :: String -> IO ()
status s = putStrLn $ ' ':s


code:
{- Package version determination, for configure script. -}

module Build.Version where

import Data.Maybe
import Control.Applicative
import Data.List
import System.Environment
import System.Directory
import Data.Char
import System.Process

import Utility.Monad
import Utility.Exception

type Version = String

{- Set when making an official release. (Distribution vendors should set
 - this too.) -}
isReleaseBuild :: IO Bool
isReleaseBuild = isJust <$> catchMaybeIO (getEnv "RELEASE_BUILD")

{- Version is usually based on the major version from the changelog,
 - plus the date of the last commit, plus the git rev of that commit.
 - This works for autobuilds, ad-hoc builds, etc.
 -
 - If git or a git repo is not available, or something goes wrong,
 - or this is a release build, just use the version from the changelog. -}
getVersion :: IO Version
getVersion = do
	changelogversion <- getChangelogVersion
	ifM (isReleaseBuild)
		( return changelogversion
		, catchDefaultIO changelogversion $ do
			let major = takeWhile (/= '.') changelogversion
			autoversion <- takeWhile (\c -> isAlphaNum c || c == '-') <$> readProcess "sh"
				[ "-c"
				, "git log -n 1 --format=format:'%ci %h'| sed -e 's/-//g' -e 's/ .* /-g/'"
				] ""
			if null autoversion
				then return changelogversion
				else return $ concat [ major, ".", autoversion ]
		)

getChangelogVersion :: IO Version
getChangelogVersion = do
	changelog <- readFile "debian/changelog"
	let verline = takeWhile (/= '\n') changelog
	return $ middle (words verline !! 1)
  where
	middle = drop 1 . init

{- Set up cabal file with version. -}
cabalSetup :: FilePath -> IO ()
cabalSetup cabalfile = do
	version <- takeWhile (\c -> isDigit c || c == '.')
		<$> getChangelogVersion
	cabal <- readFile cabalfile
	writeFile tmpcabalfile $ unlines $
		map (setfield "Version" version) $
		lines cabal
	renameFile tmpcabalfile cabalfile
  where
	tmpcabalfile = cabalfile++".tmp"
	setfield field value s
		| fullfield `isPrefixOf` s = fullfield ++ value
		| otherwise = s
	  where
		fullfield = field ++ ": "


code:
#!/bin/sh
#
# Workaround for `cabal sdist` requiring all included files to be listed
# in .cabal.

# Create target directory
sdist_dir=git-annex-$(grep '^Version:' git-annex.cabal | sed -re 's/Version: *//')
mkdir --parents dist/$sdist_dir

find . \( -name .git -or -name dist -or -name cabal-dev \) -prune \
	-or -not -name \\*.orig -not -type d -print \
	| perl -ne "print unless length >= 100 - length q{$sdist_dir}" \
	| grep -v ':' \
	| xargs cp --parents --target-directory dist/$sdist_dir

cd dist
tar --format=ustar -caf $sdist_dir.tar.gz $sdist_dir

# Check that tarball can be unpacked by cabal.
# It's picky about tar longlinks etc.
rm -rf $sdist_dir
cabal unpack $sdist_dir.tar.gz


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

{-# LANGUAGE CPP #-}

module BuildFlags where

buildFlags :: [String]
buildFlags = filter (not . null)
	[ ""
#ifdef WITH_ASSISTANT
	, "Assistant"
#else
#warning Building without the assistant.
#endif
#ifdef WITH_WEBAPP
	, "Webapp"
#else
#warning Building without the webapp. You probably need to install Yesod..
#endif
#ifdef WITH_WEBAPP_SECURE
	, "Webapp-secure"
#endif
#ifdef WITH_PAIRING
	, "Pairing"
#else
#warning Building without local pairing.
#endif
#ifdef WITH_TESTSUITE
	, "Testsuite"
#else
#warning Building without the testsuite.
#endif
#ifdef WITH_S3
	, "S3"
#else
#warning Building without S3.
#endif
#ifdef WITH_WEBDAV
	, "WebDAV"
#else
#warning Building without WebDAV.
#endif
#ifdef WITH_INOTIFY
	, "Inotify"
#endif
#ifdef WITH_FSEVENTS
	, "FsEvents"
#endif
#ifdef WITH_KQUEUE
	, "Kqueue"
#endif
#ifdef WITH_DBUS
	, "DBus"
#endif
#ifdef WITH_DESKTOP_NOTIFY
	, "DesktopNotify"
#endif
#ifdef WITH_XMPP
	, "XMPP"
#else
#warning Building without XMPP.
#endif
#ifdef WITH_DNS
	, "DNS"
#endif
#ifdef WITH_FEED
	, "Feeds"
#else
#warning Building without Feeds.
#endif
#ifdef WITH_QUVI
	, "Quvi"
#else
#warning Building without quvi.
#endif
#ifdef WITH_TDFA
	, "TDFA"
#endif
#ifdef WITH_CRYPTOHASH
	, "CryptoHash"
#else
#warning Building without CryptoHash.
#endif
#ifdef WITH_EKG
	, "EKG"
#endif
	]


code:
{- git-annex command checks
 -
 - Common sanity checks for commands, and an interface to selectively
 - remove them, or add others.
 -
 - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Checks where

import Common.Annex
import Types.Command
import Annex.Init
import Config
import Utility.Daemon
import qualified Git

commonChecks :: [CommandCheck]
commonChecks = [repoExists]

repoExists :: CommandCheck
repoExists = CommandCheck 0 ensureInitialized

notDirect :: Command -> Command
notDirect = addCheck $ whenM isDirect $
	error "You cannot run this command in a direct mode repository."

notBareRepo :: Command -> Command
notBareRepo = addCheck $ whenM (fromRepo Git.repoIsLocalBare) $
	error "You cannot run this command in a bare repository."

noDaemonRunning :: Command -> Command
noDaemonRunning = addCheck $ whenM (isJust <$> daemonpid) $
	error "You cannot run this command while git-annex watch or git-annex assistant is running."
  where
  	daemonpid = liftIO . checkDaemon =<< fromRepo gitAnnexPidFile

dontCheck :: CommandCheck -> Command -> Command
dontCheck check cmd = mutateCheck cmd $ \c -> filter (/= check) c

addCheck :: Annex () -> Command -> Command
addCheck check cmd = mutateCheck cmd $ \c ->
	CommandCheck (length c + 100) check : c

mutateCheck :: Command -> ([CommandCheck] -> [CommandCheck]) -> Command
mutateCheck cmd@(Command { cmdcheck = c }) a = cmd { cmdcheck = a c }


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

{-# LANGUAGE CPP #-}

module CmdLine (
	dispatch,
	usage,
	shutdown
) where

import qualified Control.Exception as E
import qualified Data.Map as M
import Control.Exception (throw)
import System.Console.GetOpt
#ifndef mingw32_HOST_OS
import System.Posix.Signals
#endif

import Common.Annex
import qualified Annex
import qualified Git
import qualified Git.AutoCorrect
import Annex.Content
import Annex.Environment
import Command
import Types.Messages

{- Runs the passed command line. -}
dispatch :: Bool -> CmdParams -> [Command] -> [Option] -> [(String, String)] -> String -> IO Git.Repo -> IO ()
dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do
	setupConsole
	r <- E.try getgitrepo :: IO (Either E.SomeException Git.Repo)
	case r of
		Left e -> maybe (throw e) (\a -> a params) (cmdnorepo cmd)
		Right g -> do
			state <- Annex.new g
			Annex.eval state $ do
				checkEnvironment
				checkfuzzy
				forM_ fields $ uncurry Annex.setField
				when (cmdnomessages cmd) $
					Annex.setOutput QuietOutput
				sequence_ flags
				whenM (annexDebug <$> Annex.getGitConfig) $
					liftIO enableDebugOutput
				startup
				performCommandAction cmd params
				shutdown $ cmdnocommit cmd
  where
	err msg = msg ++ "\n\n" ++ usage header allcmds
	cmd = Prelude.head cmds
	(fuzzy, cmds, name, args) = findCmd fuzzyok allargs allcmds err
	(flags, params) = getOptCmd args cmd commonoptions
	checkfuzzy = when fuzzy $
		inRepo $ Git.AutoCorrect.prepare name cmdname cmds

{- Parses command line params far enough to find the Command to run, and
 - returns the remaining params.
 - Does fuzzy matching if necessary, which may result in multiple Commands. -}
findCmd :: Bool -> CmdParams -> [Command] -> (String -> String) -> (Bool, [Command], String, CmdParams)
findCmd fuzzyok argv cmds err
	| isNothing name = error $ err "missing command"
	| not (null exactcmds) = (False, exactcmds, fromJust name, args)
	| fuzzyok && not (null inexactcmds) = (True, inexactcmds, fromJust name, args)
	| otherwise = error $ err $ "unknown command " ++ fromJust name
  where
	(name, args) = findname argv []
	findname [] c = (Nothing, reverse c)
	findname (a:as) c
		| "-" `isPrefixOf` a = findname as (a:c)
		| otherwise = (Just a, reverse c ++ as)
	exactcmds = filter (\c -> name == Just (cmdname c)) cmds
	inexactcmds = case name of
		Nothing -> []
		Just n -> Git.AutoCorrect.fuzzymatches n cmdname cmds

{- Parses command line options, and returns actions to run to configure flags
 - and the remaining parameters for the command. -}
getOptCmd :: CmdParams -> Command -> [Option] -> ([Annex ()], CmdParams)
getOptCmd argv cmd commonoptions = check $
	getOpt Permute (commonoptions ++ cmdoptions cmd) argv
  where
	check (flags, rest, []) = (flags, rest)
	check (_, _, errs) = error $ unlines
		[ concat errs
		, commandUsage cmd
		]

{- Actions to perform each time ran. -}
startup :: Annex ()
startup =
#ifndef mingw32_HOST_OS
	liftIO $ void $ installHandler sigINT Default Nothing
#else
	return ()
#endif

{- Cleanup actions. -}
shutdown :: Bool -> Annex ()
shutdown nocommit = do
	saveState nocommit
	sequence_ =<< M.elems <$> Annex.getState Annex.cleanup
	liftIO reapZombies -- zombies from long-running git processes


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

{-# LANGUAGE BangPatterns #-}

module CmdLine.Action where

import Common.Annex
import qualified Annex
import Types.Command
import qualified Annex.Queue
import Annex.Exception

type CommandActionRunner = CommandStart -> CommandCleanup

{- Runs a command, starting with the check stage, and then
 - the seek stage. Finishes by printing the number of commandActions that
 - failed. -}
performCommandAction :: Command -> CmdParams -> Annex ()
performCommandAction Command { cmdseek = seek, cmdcheck = c, cmdname = name } params = do
	mapM_ runCheck c
	Annex.changeState $ \s -> s { Annex.errcounter = 0 }
	seek params
	showerrcount =<< Annex.getState Annex.errcounter
  where
	showerrcount 0 = noop
	showerrcount cnt = error $ name ++ ": " ++ show cnt ++ " failed"

{- Runs one of the actions needed to perform a command.
 - Individual actions can fail without stopping the whole command,
 - including by throwing IO errors (but other errors terminate the whole
 - command).
 -
 - This should only be run in the seek stage. -}
commandAction :: CommandActionRunner
commandAction a = handle =<< tryAnnexIO go
  where
	go = do
		Annex.Queue.flushWhenFull
		callCommandAction a
	handle (Right True) = return True
	handle (Right False) = incerr
	handle (Left err) = do
		showErr err
		showEndFail
		incerr
	incerr = do
		Annex.changeState $ \s ->
			let ! c = Annex.errcounter s + 1
			    ! s' = s { Annex.errcounter = c }
			in s'
		return False

{- Runs a single command action through the start, perform and cleanup
 - stages, without catching errors. Useful if one command wants to run
 - part of another command. -}
callCommandAction :: CommandActionRunner
callCommandAction = start
  where
	start   = stage $ maybe skip perform
	perform = stage $ maybe failure cleanup
	cleanup = stage $ status
	stage = (=<<)
	skip = return True
	failure = showEndFail >> return False
	status r = showEndResult r >> return r


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

{-# LANGUAGE CPP, OverloadedStrings #-}

module CmdLine.GitAnnex where

import qualified Git.CurrentRepo
import CmdLine
import Command
import Utility.Env
import Annex.Ssh

import qualified Command.Add
import qualified Command.Unannex
import qualified Command.Drop
import qualified Command.Move
import qualified Command.Copy
import qualified Command.Get
import qualified Command.LookupKey
import qualified Command.ExamineKey
import qualified Command.FromKey
import qualified Command.DropKey
import qualified Command.TransferKey
import qualified Command.TransferKeys
import qualified Command.ReKey
import qualified Command.MetaData
import qualified Command.View
import qualified Command.VAdd
import qualified Command.VFilter
import qualified Command.VPop
import qualified Command.VCycle
import qualified Command.Reinject
import qualified Command.Fix
import qualified Command.Init
import qualified Command.Describe
import qualified Command.InitRemote
import qualified Command.EnableRemote
import qualified Command.Fsck
import qualified Command.Repair
import qualified Command.Unused
import qualified Command.DropUnused
import qualified Command.AddUnused
import qualified Command.Unlock
import qualified Command.Lock
import qualified Command.PreCommit
import qualified Command.Find
import qualified Command.FindRef
import qualified Command.Whereis
import qualified Command.List
import qualified Command.Log
import qualified Command.Merge
import qualified Command.ResolveMerge
import qualified Command.Info
import qualified Command.Status
import qualified Command.Migrate
import qualified Command.Uninit
import qualified Command.Reinit
import qualified Command.NumCopies
import qualified Command.Trust
import qualified Command.Untrust
import qualified Command.Semitrust
import qualified Command.Dead
import qualified Command.Group
import qualified Command.Wanted
import qualified Command.Schedule
import qualified Command.Ungroup
import qualified Command.Vicfg
import qualified Command.Sync
import qualified Command.Mirror
import qualified Command.AddUrl
#ifdef WITH_FEED
import qualified Command.ImportFeed
#endif
import qualified Command.RmUrl
import qualified Command.Import
import qualified Command.Map
import qualified Command.Direct
import qualified Command.Indirect
import qualified Command.Upgrade
import qualified Command.Forget
import qualified Command.Version
import qualified Command.Help
#ifdef WITH_ASSISTANT
import qualified Command.Watch
import qualified Command.Assistant
#ifdef WITH_WEBAPP
import qualified Command.WebApp
#endif
#ifdef WITH_XMPP
import qualified Command.XMPPGit
#endif
import qualified Command.RemoteDaemon
#endif
#ifdef WITH_TESTSUITE
import qualified Command.Test
import qualified Command.FuzzTest
import qualified Command.TestRemote
#endif
#ifdef WITH_EKG
import System.Remote.Monitoring
#endif

cmds :: [Command]
cmds = concat
	[ Command.Add.def
	, Command.Get.def
	, Command.Drop.def
	, Command.Move.def
	, Command.Copy.def
	, Command.Unlock.def
	, Command.Lock.def
	, Command.Sync.def
	, Command.Mirror.def
	, Command.AddUrl.def
#ifdef WITH_FEED
	, Command.ImportFeed.def
#endif
	, Command.RmUrl.def
	, Command.Import.def
	, Command.Init.def
	, Command.Describe.def
	, Command.InitRemote.def
	, Command.EnableRemote.def
	, Command.Reinject.def
	, Command.Unannex.def
	, Command.Uninit.def
	, Command.Reinit.def
	, Command.PreCommit.def
	, Command.NumCopies.def
	, Command.Trust.def
	, Command.Untrust.def
	, Command.Semitrust.def
	, Command.Dead.def
	, Command.Group.def
	, Command.Wanted.def
	, Command.Schedule.def
	, Command.Ungroup.def
	, Command.Vicfg.def
	, Command.LookupKey.def
	, Command.ExamineKey.def
	, Command.FromKey.def
	, Command.DropKey.def
	, Command.TransferKey.def
	, Command.TransferKeys.def
	, Command.ReKey.def
	, Command.MetaData.def
	, Command.View.def
	, Command.VAdd.def
	, Command.VFilter.def
	, Command.VPop.def
	, Command.VCycle.def
	, Command.Fix.def
	, Command.Fsck.def
	, Command.Repair.def
	, Command.Unused.def
	, Command.DropUnused.def
	, Command.AddUnused.def
	, Command.Find.def
	, Command.FindRef.def
	, Command.Whereis.def
	, Command.List.def
	, Command.Log.def
	, Command.Merge.def
	, Command.ResolveMerge.def
	, Command.Info.def
	, Command.Status.def
	, Command.Migrate.def
	, Command.Map.def
	, Command.Direct.def
	, Command.Indirect.def
	, Command.Upgrade.def
	, Command.Forget.def
	, Command.Version.def
	, Command.Help.def
#ifdef WITH_ASSISTANT
	, Command.Watch.def
	, Command.Assistant.def
#ifdef WITH_WEBAPP
	, Command.WebApp.def
#endif
#ifdef WITH_XMPP
	, Command.XMPPGit.def
#endif
	, Command.RemoteDaemon.def
#endif
#ifdef WITH_TESTSUITE
	, Command.Test.def
	, Command.FuzzTest.def
	, Command.TestRemote.def
#endif
	]

header :: String
header = "git-annex command [option ...]"

run :: [String] -> IO ()
run args = do
#ifdef WITH_EKG
	_ <- forkServer "localhost" 4242
#endif
	go envmodes
  where
	go [] = dispatch True args cmds gitAnnexOptions [] header Git.CurrentRepo.get
	go ((v, a):rest) = maybe (go rest) a =<< getEnv v
	envmodes =
		[ (sshCachingEnv, runSshCaching args)
		, (sshAskPassEnv, runSshAskPass)
		]


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

module CmdLine.GitAnnex.Options where

import System.Console.GetOpt

import Common.Annex
import qualified Git.Config
import Git.Types
import Types.TrustLevel
import Types.NumCopies
import Types.Messages
import qualified Annex
import qualified Remote
import qualified Limit
import qualified Limit.Wanted
import CmdLine.Option
import CmdLine.Usage

gitAnnexOptions :: [Option]
gitAnnexOptions = commonOptions ++
	[ Option ['N'] ["numcopies"] (ReqArg setnumcopies paramNumber)
		"override default number of copies"
	, Option [] ["trust"] (trustArg Trusted)
		"override trust setting"
	, Option [] ["semitrust"] (trustArg SemiTrusted)
		"override trust setting back to default"
	, Option [] ["untrust"] (trustArg UnTrusted)
		"override trust setting to untrusted"
	, Option ['c'] ["config"] (ReqArg setgitconfig "NAME=VALUE")
		"override git configuration setting"
	, Option ['x'] ["exclude"] (ReqArg Limit.addExclude paramGlob)
		"skip files matching the glob pattern"
	, Option ['I'] ["include"] (ReqArg Limit.addInclude paramGlob)
		"limit to files matching the glob pattern"
	, Option ['i'] ["in"] (ReqArg Limit.addIn paramRemote)
		"match files present in a remote"
	, Option ['C'] ["copies"] (ReqArg Limit.addCopies paramNumber)
		"skip files with fewer copies"
	, Option [] ["lackingcopies"] (ReqArg (Limit.addLackingCopies False) paramNumber)
		"match files that need more copies"
	, Option [] ["approxlackingcopies"] (ReqArg (Limit.addLackingCopies True) paramNumber)
		"match files that need more copies (faster)"
	, Option ['B'] ["inbackend"] (ReqArg Limit.addInBackend paramName)
		"match files using a key-value backend"
	, Option [] ["inallgroup"] (ReqArg Limit.addInAllGroup paramGroup)
		"match files present in all remotes in a group"
	, Option [] ["largerthan"] (ReqArg Limit.addLargerThan paramSize)
		"match files larger than a size"
	, Option [] ["smallerthan"] (ReqArg Limit.addSmallerThan paramSize)
		"match files smaller than a size"
	, Option [] ["metadata"] (ReqArg Limit.addMetaData "FIELD=VALUE")
		"match files with attached metadata"
	, Option [] ["want-get"] (NoArg Limit.Wanted.addWantGet)
		"match files the repository wants to get"
	, Option [] ["want-drop"] (NoArg Limit.Wanted.addWantDrop)
		"match files the repository wants to drop"
	, Option ['T'] ["time-limit"] (ReqArg Limit.addTimeLimit paramTime)
		"stop after the specified amount of time"
	, Option [] ["user-agent"] (ReqArg setuseragent paramName)
		"override default User-Agent"
	, Option [] ["trust-glacier"] (NoArg (Annex.setFlag "trustglacier"))
		"Trust Amazon Glacier inventory"
	] ++ matcherOptions
  where
	trustArg t = ReqArg (Remote.forceTrust t) paramRemote
	setnumcopies v = maybe noop
		(\n -> Annex.changeState $ \s -> s { Annex.forcenumcopies = Just $ NumCopies n })
		(readish v)
	setuseragent v = Annex.changeState $ \s -> s { Annex.useragent = Just v }
	setgitconfig v = inRepo (Git.Config.store v)
		>>= pure . (\r -> r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] })
		>>= Annex.changeGitRepo

keyOptions :: [Option]
keyOptions =
	[ Option ['A'] ["all"] (NoArg (Annex.setFlag "all"))
		"operate on all versions of all files"
	, Option ['U'] ["unused"] (NoArg (Annex.setFlag "unused"))
		"operate on files found by last run of git-annex unused"
	, Option [] ["key"] (ReqArg (Annex.setField "key") paramKey)
		"operate on specified key"
	]

fromOption :: Option
fromOption = fieldOption ['f'] "from" paramRemote "source remote"

toOption :: Option
toOption = fieldOption ['t'] "to" paramRemote "destination remote"

fromToOptions :: [Option]
fromToOptions = [fromOption, toOption]

jsonOption :: Option
jsonOption = Option ['j'] ["json"] (NoArg (Annex.setOutput JSONOutput))
	"enable JSON output"


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

module CmdLine.GitAnnexShell where

import System.Environment
import System.Console.GetOpt

import Common.Annex
import qualified Git.Construct
import CmdLine
import Command
import Annex.UUID
import Annex (setField)
import CmdLine.GitAnnexShell.Fields
import Utility.UserInfo
import Remote.GCrypt (getGCryptUUID)
import qualified Annex
import Annex.Init

import qualified Command.ConfigList
import qualified Command.InAnnex
import qualified Command.DropKey
import qualified Command.RecvKey
import qualified Command.SendKey
import qualified Command.TransferInfo
import qualified Command.Commit
import qualified Command.NotifyChanges
import qualified Command.GCryptSetup

cmds_readonly :: [Command]
cmds_readonly = concat
	[ gitAnnexShellCheck Command.ConfigList.def
	, gitAnnexShellCheck Command.InAnnex.def
	, gitAnnexShellCheck Command.SendKey.def
	, gitAnnexShellCheck Command.TransferInfo.def
	, gitAnnexShellCheck Command.NotifyChanges.def
	]

cmds_notreadonly :: [Command]
cmds_notreadonly = concat
	[ gitAnnexShellCheck Command.RecvKey.def
	, gitAnnexShellCheck Command.DropKey.def
	, gitAnnexShellCheck Command.Commit.def
	, Command.GCryptSetup.def
	]

cmds :: [Command]
cmds = map adddirparam $ cmds_readonly ++ cmds_notreadonly
  where
	adddirparam c = c { cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c }

options :: [OptDescr (Annex ())]
options = commonOptions ++
	[ Option [] ["uuid"] (ReqArg checkUUID paramUUID) "local repository uuid"
	]
  where
	checkUUID expected = getUUID >>= check
	  where
		check u | u == toUUID expected = noop
		check NoUUID = checkGCryptUUID expected
		check u = unexpectedUUID expected u
	checkGCryptUUID expected = check =<< getGCryptUUID True =<< gitRepo
	  where
	  	check (Just u) | u == toUUID expected = noop
		check Nothing = unexpected expected "uninitialized repository"
		check (Just u) = unexpectedUUID expected u
	unexpectedUUID expected u = unexpected expected $ "UUID " ++ fromUUID u
	unexpected expected s = error $
		"expected repository UUID " ++ expected ++ " but found " ++ s

header :: String
header = "git-annex-shell [-c] command [parameters ...] [option ...]"

run :: [String] -> IO ()
run [] = failure
-- skip leading -c options, passed by eg, ssh
run ("-c":p) = run p
-- a command can be either a builtin or something to pass to git-shell
run c@(cmd:dir:params)
	| cmd `elem` builtins = builtin cmd dir params
	| otherwise = external c
run c@(cmd:_)
	-- Handle the case of being the user's login shell. It will be passed
	-- a single string containing all the real parameters.
	| "git-annex-shell " `isPrefixOf` cmd = run $ drop 1 $ shellUnEscape cmd
	| cmd `elem` builtins = failure
	| otherwise = external c

builtins :: [String]
builtins = map cmdname cmds

builtin :: String -> String -> [String] -> IO ()
builtin cmd dir params = do
	checkNotReadOnly cmd
	checkDirectory $ Just dir
	let (params', fieldparams, opts) = partitionParams params
	    fields = filter checkField $ parseFields fieldparams
	    cmds' = map (newcmd $ unwords opts) cmds
	dispatch False (cmd : params') cmds' options fields header $
		Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath
  where
	addrsyncopts opts seek k = setField "RsyncOptions" opts >> seek k
	newcmd opts c = c { cmdseek = addrsyncopts opts (cmdseek c) }

external :: [String] -> IO ()
external params = do
	{- Normal git-shell commands all have the directory as their last
	 - parameter. -}
	let lastparam = lastMaybe =<< shellUnEscape <$> lastMaybe params
	    (params', _, _) = partitionParams params
	checkDirectory lastparam
	checkNotLimited
	unlessM (boolSystem "git-shell" $ map Param $ "-c":params') $
		error "git-shell failed"

{- Split the input list into 3 groups separated with a double dash --.
 - Parameters between two -- markers are field settings, in the form:
 - field=value field=value
 -
 - Parameters after the last -- are the command itself and its arguments e.g.,
 - rsync --bandwidth=100.
 -}
partitionParams :: [String] -> ([String], [String], [String])
partitionParams ps = case segment (== "--") ps of
	params:fieldparams:rest -> ( params, fieldparams, intercalate ["--"] rest )
	[params] -> (params, [], [])
	_ -> ([], [], [])

parseFields :: [String] -> [(String, String)]
parseFields = map (separate (== '='))

{- Only allow known fields to be set, ignore others.
 - Make sure that field values make sense. -}
checkField :: (String, String) -> Bool
checkField (field, value)
	| field == fieldName remoteUUID = fieldCheck remoteUUID value
	| field == fieldName associatedFile = fieldCheck associatedFile value
	| field == fieldName direct = fieldCheck direct value
	| otherwise = False

failure :: IO ()
failure = error $ "bad parameters\n\n" ++ usage header cmds

checkNotLimited :: IO ()
checkNotLimited = checkEnv "GIT_ANNEX_SHELL_LIMITED"

checkNotReadOnly :: String -> IO ()
checkNotReadOnly cmd
	| cmd `elem` map cmdname cmds_readonly = noop
	| otherwise = checkEnv "GIT_ANNEX_SHELL_READONLY"

checkDirectory :: Maybe FilePath -> IO ()
checkDirectory mdir = do
	v <- catchMaybeIO $ getEnv "GIT_ANNEX_SHELL_DIRECTORY"
	case (v, mdir) of
		(Nothing, _) -> noop
		(Just d, Nothing) -> req d Nothing
		(Just d, Just dir)
			|  d `equalFilePath` dir -> noop
			| otherwise -> do
				home <- myHomeDir
				d' <- canondir home d
				dir' <- canondir home dir
				if d' `equalFilePath` dir'
					then noop
					else req d' (Just dir')
  where
	req d mdir' = error $ unwords
		[ "Only allowed to access"
		, d
		, maybe "and could not determine directory from command line" ("not " ++) mdir'
		]

	{- A directory may start with ~/ or in some cases, even /~/,
	 - or could just be relative to home, or of course could
	 - be absolute. -}
	canondir home d
		| "~/" `isPrefixOf` d = return d
		| "/~/" `isPrefixOf` d = return $ drop 1 d
		| otherwise = relHome $ absPathFrom home d

checkEnv :: String -> IO ()
checkEnv var = do
	v <- catchMaybeIO $ getEnv var
	case v of
		Nothing -> noop
		Just "" -> noop
		Just _ -> error $ "Action blocked by " ++ var

{- Modifies a Command to check that it is run in either a git-annex
 - repository, or a repository with a gcrypt-id set. -}
gitAnnexShellCheck :: [Command] -> [Command]
gitAnnexShellCheck = map $ addCheck okforshell . dontCheck repoExists
  where
	okforshell = unlessM (isInitialized <||> isJust . gcryptId <$> Annex.getGitConfig) $
		error "Not a git-annex or gcrypt repository."


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

module CmdLine.GitAnnexShell.Fields where

import Common.Annex
import qualified Annex
import Git.FilePath

import Data.Char

{- A field, stored in Annex state, with a value sanity checker. -}
data Field = Field
	{ fieldName :: String
	, fieldCheck :: String -> Bool
	}

getField :: Field -> Annex (Maybe String)
getField = Annex.getField . fieldName

remoteUUID :: Field
remoteUUID = Field "remoteuuid" $
	-- does it look like a UUID?
	all (\c -> isAlphaNum c || c == '-')

associatedFile :: Field
associatedFile = Field "associatedfile" $ \f ->
	-- is the file a safe relative filename?
	not (absoluteGitPath f) && not ("../" `isPrefixOf` f)

direct :: Field
direct = Field "direct" $ \f -> f == "1"


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

module CmdLine.Option (
	commonOptions,
	matcherOptions,
	flagOption,
	fieldOption,
	optionName,
	ArgDescr(..),
	OptDescr(..),
) where

import System.Console.GetOpt

import Common.Annex
import qualified Annex
import Types.Messages
import Types.DesktopNotify
import Limit
import CmdLine.Usage

commonOptions :: [Option]
commonOptions =
	[ Option [] ["force"] (NoArg (setforce True))
		"allow actions that may lose annexed data"
	, Option ['F'] ["fast"] (NoArg (setfast True))
		"avoid slow operations"
	, Option ['a'] ["auto"] (NoArg (setauto True))
		"automatic mode"
	, Option ['q'] ["quiet"] (NoArg (Annex.setOutput QuietOutput))
		"avoid verbose output"
	, Option ['v'] ["verbose"] (NoArg (Annex.setOutput NormalOutput))
		"allow verbose output (default)"
	, Option ['d'] ["debug"] (NoArg setdebug)
		"show debug messages"
	, Option [] ["no-debug"] (NoArg unsetdebug)
		"don't show debug messages"
	, Option ['b'] ["backend"] (ReqArg setforcebackend paramName)
		"specify key-value backend to use"
	, Option [] ["notify-finish"] (NoArg (setdesktopnotify mkNotifyFinish))
		"show desktop notification after transfer finishes"
	, Option [] ["notify-start"] (NoArg (setdesktopnotify mkNotifyStart))
		"show desktop notification after transfer completes"
	]
  where
	setforce v = Annex.changeState $ \s -> s { Annex.force = v }
	setfast v = Annex.changeState $ \s -> s { Annex.fast = v }
	setauto v = Annex.changeState $ \s -> s { Annex.auto = v }
	setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v }
	setdebug = Annex.changeGitConfig $ \c -> c { annexDebug = True }
	unsetdebug = Annex.changeGitConfig $ \c -> c { annexDebug = False }
	setdesktopnotify v = Annex.changeState $ \s -> s { Annex.desktopnotify = Annex.desktopnotify s <> v }

matcherOptions :: [Option]
matcherOptions =
	[ longopt "not" "negate next option"
	, longopt "and" "both previous and next option must match"
	, longopt "or" "either previous or next option must match"
	, shortopt "(" "open group of options"
	, shortopt ")" "close group of options"
	]
  where
	longopt o = Option [] [o] $ NoArg $ addToken o
	shortopt o = Option o [] $ NoArg $ addToken o

{- An option that sets a flag. -}
flagOption :: String -> String -> String -> Option
flagOption short opt description =
	Option short [opt] (NoArg (Annex.setFlag opt)) description

{- An option that sets a field. -}
fieldOption :: String -> String -> String -> String -> Option
fieldOption short opt paramdesc description =
	Option short [opt] (ReqArg (Annex.setField opt) paramdesc) description

{- The flag or field name used for an option. -}
optionName :: Option -> String
optionName (Option _ o _ _) = Prelude.head o


code:
{- git-annex command seeking
 -
 - These functions find appropriate files or other things based on
 - the values a user passes to a command, and prepare actions operating
 - on them.
 -
 - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module CmdLine.Seek where

import Common.Annex
import Types.Command
import Types.Key
import Types.FileMatcher
import qualified Annex
import qualified Git
import qualified Git.Command
import qualified Git.LsFiles as LsFiles
import qualified Git.LsTree as LsTree
import Git.FilePath
import qualified Limit
import CmdLine.Option
import CmdLine.Action
import Logs.Location
import Logs.Unused
import Annex.CatFile

withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek
withFilesInGit a params = seekActions $ prepFiltered a $
	seekHelper LsFiles.inRepo params

withFilesNotInGit :: Bool -> (FilePath -> CommandStart) -> CommandSeek
withFilesNotInGit skipdotfiles a params
	| skipdotfiles = do
		{- dotfiles are not acted on unless explicitly listed -}
		files <- filter (not . dotfile) <$>
			seekunless (null ps && not (null params)) ps
		dotfiles <- seekunless (null dotps) dotps
		go (files++dotfiles)
	| otherwise = go =<< seekunless False params
  where
	(dotps, ps) = partition dotfile params
	seekunless True _ = return []
	seekunless _ l = do
		force <- Annex.getState Annex.force
		g <- gitRepo
		liftIO $ Git.Command.leaveZombie <$> LsFiles.notInRepo force l g
	go l = seekActions $ prepFiltered a $
		return $ concat $ segmentPaths params l

withFilesInRefs :: (FilePath -> Key -> CommandStart) -> CommandSeek
withFilesInRefs a = mapM_ go
  where
	go r = do
		matcher <- Limit.getMatcher
		l <- inRepo $ LsTree.lsTree (Git.Ref r)
		forM_ l $ \i -> do
			let f = getTopFilePath $ LsTree.file i
			v <- catKey (Git.Ref $ LsTree.sha i) (LsTree.mode i)
			case v of
				Nothing -> noop
				Just k -> whenM (matcher $ MatchingKey k) $
					void $ commandAction $ a f k

withPathContents :: ((FilePath, FilePath) -> CommandStart) -> CommandSeek
withPathContents a params = seekActions $
	map a . concat <$> liftIO (mapM get params)
  where
	get p = ifM (isDirectory <$> getFileStatus p)
		( map (\f -> (f, makeRelative (parentDir p) f))
			<$> dirContentsRecursiveSkipping (".git" `isSuffixOf`) True p
		, return [(p, takeFileName p)]
		)

withWords :: ([String] -> CommandStart) -> CommandSeek
withWords a params = seekActions $ return [a params]

withStrings :: (String -> CommandStart) -> CommandSeek
withStrings a params = seekActions $ return $ map a params

withPairs :: ((String, String) -> CommandStart) -> CommandSeek
withPairs a params = seekActions $ return $ map a $ pairs [] params
  where
	pairs c [] = reverse c
	pairs c (x:y:xs) = pairs ((x,y):c) xs
	pairs _ _ = error "expected pairs"

withFilesToBeCommitted :: (String -> CommandStart) -> CommandSeek
withFilesToBeCommitted a params = seekActions $ prepFiltered a $
	seekHelper LsFiles.stagedNotDeleted params

withFilesUnlocked :: (FilePath -> CommandStart) -> CommandSeek
withFilesUnlocked = withFilesUnlocked' LsFiles.typeChanged

withFilesUnlockedToBeCommitted :: (FilePath -> CommandStart) -> CommandSeek
withFilesUnlockedToBeCommitted = withFilesUnlocked' LsFiles.typeChangedStaged

{- Unlocked files have changed type from a symlink to a regular file.
 -
 - Furthermore, unlocked files used to be a git-annex symlink,
 - not some other sort of symlink.
 -}
withFilesUnlocked' :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> (FilePath -> CommandStart) -> CommandSeek
withFilesUnlocked' typechanged a params = seekActions $
	prepFiltered a unlockedfiles
  where
  	check f = liftIO (notSymlink f) <&&>
		(isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f)
	unlockedfiles = filterM check =<< seekHelper typechanged params

{- Finds files that may be modified. -}
withFilesMaybeModified :: (FilePath -> CommandStart) -> CommandSeek
withFilesMaybeModified a params = seekActions $
	prepFiltered a $ seekHelper LsFiles.modified params

withKeys :: (Key -> CommandStart) -> CommandSeek
withKeys a params = seekActions $ return $ map (a . parse) params
  where
	parse p = fromMaybe (error "bad key") $ file2key p

{- Gets the value of a field options, which is fed into
 - a conversion function.
 -}
getOptionField :: Option -> (Maybe String -> Annex a) -> Annex a
getOptionField option converter = converter <=< Annex.getField $ optionName option

getOptionFlag :: Option -> Annex Bool
getOptionFlag option = Annex.getFlag (optionName option)

withNothing :: CommandStart -> CommandSeek
withNothing a [] = seekActions $ return [a]
withNothing _ _ = error "This command takes no parameters."

{- If --all is specified, or in a bare repo, runs an action on all
 - known keys.
 -
 - If --unused is specified, runs an action on all keys found by
 - the last git annex unused scan.
 -
 - If --key is specified, operates only on that key.
 -
 - Otherwise, fall back to a regular CommandSeek action on
 - whatever params were passed. -}
withKeyOptions :: (Key -> CommandStart) -> CommandSeek -> CommandSeek
withKeyOptions keyop fallbackop params = do
	bare <- fromRepo Git.repoIsLocalBare
	allkeys <- Annex.getFlag "all"
	unused <- Annex.getFlag "unused"
	specifickey <- Annex.getField "key"
	auto <- Annex.getState Annex.auto
	when (auto && bare) $
		error "Cannot use --auto in a bare repository"
	case	(allkeys, unused, null params, specifickey) of
		(False  , False , True       , Nothing)
			| bare -> go auto loggedKeys
			| otherwise -> fallbackop params
		(False  , False , _          , Nothing) -> fallbackop params
		(True   , False , True       , Nothing) -> go auto loggedKeys
		(False  , True  , True       , Nothing) -> go auto unusedKeys'
		(False  , False , True       , Just ks) -> case file2key ks of
			Nothing -> error "Invalid key"
			Just k -> go auto $ return [k]
		_ -> error "Can only specify one of file names, --all, --unused, or --key"
  where
  	go True _ = error "Cannot use --auto with --all or --unused or --key"
	go False a = do
		matcher <- Limit.getMatcher
		seekActions $ map (process matcher) <$> a
	process matcher k = ifM (matcher $ MatchingKey k)
		( keyop k , return Nothing)

prepFiltered :: (FilePath -> CommandStart) -> Annex [FilePath] -> Annex [CommandStart]
prepFiltered a fs = do
	matcher <- Limit.getMatcher
	map (process matcher) <$> fs
  where
	process matcher f = ifM (matcher $ MatchingFile $ FileInfo f f)
		( a f , return Nothing )

seekActions :: Annex [CommandStart] -> Annex ()
seekActions gen = do
	as <- gen
	mapM_ commandAction as

seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [FilePath] -> Annex [FilePath]
seekHelper a params = do
	ll <- inRepo $ \g ->
		runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g) params
	{- Show warnings only for files/directories that do not exist. -}
	forM_ (map fst $ filter (null . snd) $ zip params ll) $ \p ->
		unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $
			fileNotFound p
	return $ concat ll

notSymlink :: FilePath -> IO Bool
notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f