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

module Annex.Branch (
	fullname,
	name,
	hasOrigin,
	hasSibling,
	siblingBranches,
	create,
	update,
	forceUpdate,
	updateTo,
	get,
	getHistorical,
	change,
	commit,
	forceCommit,
	files,
	withIndex,
	performTransitions,
) where

import qualified Data.ByteString.Lazy as L
import qualified Data.Set as S
import qualified Data.Map as M
import Data.Bits.Utils

import Common.Annex
import Annex.BranchState
import Annex.Journal
import Annex.Index
import qualified Git
import qualified Git.Command
import qualified Git.Ref
import qualified Git.Sha
import qualified Git.Branch
import qualified Git.UnionMerge
import qualified Git.UpdateIndex
import Git.HashObject
import Git.Types
import Git.FilePath
import Annex.CatFile
import Annex.Perms
import Logs
import Logs.Transitions
import Logs.Trust.Pure
import Annex.ReplaceFile
import qualified Annex.Queue
import Annex.Branch.Transitions

{- Name of the branch that is used to store git-annex's information. -}
name :: Git.Ref
name = Git.Ref "git-annex"

{- Fully qualified name of the branch. -}
fullname :: Git.Ref
fullname = Git.Ref $ "refs/heads/" ++ fromRef name

{- Branch's name in origin. -}
originname :: Git.Ref
originname = Git.Ref $ "origin/" ++ fromRef name

{- Does origin/git-annex exist? -}
hasOrigin :: Annex Bool
hasOrigin = inRepo $ Git.Ref.exists originname

{- Does the git-annex branch or a sibling foo/git-annex branch exist? -}
hasSibling :: Annex Bool
hasSibling = not . null <$> siblingBranches

{- List of git-annex (refs, branches), including the main one and any
 - from remotes. Duplicate refs are filtered out. -}
siblingBranches :: Annex [(Git.Ref, Git.Branch)]
siblingBranches = inRepo $ Git.Ref.matchingUniq [name]

{- Creates the branch, if it does not already exist. -}
create :: Annex ()
create = void getBranch

{- Returns the ref of the branch, creating it first if necessary. -}
getBranch :: Annex Git.Ref
getBranch = maybe (hasOrigin >>= go >>= use) return =<< branchsha
  where
	go True = do
		inRepo $ Git.Command.run
			[Param "branch", Param $ fromRef name, Param $ fromRef originname]
		fromMaybe (error $ "failed to create " ++ fromRef name)
			<$> branchsha
	go False = withIndex' True $
		inRepo $ Git.Branch.commitAlways Git.Branch.AutomaticCommit "branch created" fullname []
	use sha = do
		setIndexSha sha
		return sha
	branchsha = inRepo $ Git.Ref.sha fullname

{- Ensures that the branch and index are up-to-date; should be
 - called before data is read from it. Runs only once per git-annex run. -}
update :: Annex ()
update = runUpdateOnce $ void $ updateTo =<< siblingBranches

{- Forces an update even if one has already been run. -}
forceUpdate :: Annex Bool
forceUpdate = updateTo =<< siblingBranches

{- Merges the specified Refs into the index, if they have any changes not
 - already in it. The Branch names are only used in the commit message;
 - it's even possible that the provided Branches have not been updated to
 - point to the Refs yet.
 -
 - The branch is fast-forwarded if possible, otherwise a merge commit is
 - made.
 -
 - Before Refs are merged into the index, it's important to first stage the
 - journal into the index. Otherwise, any changes in the journal would
 - later get staged, and might overwrite changes made during the merge.
 - This is only done if some of the Refs do need to be merged.
 -
 - Also handles performing any Transitions that have not yet been
 - performed, in either the local branch, or the Refs.
 -
 - Returns True if any refs were merged in, False otherwise.
 -}
updateTo :: [(Git.Ref, Git.Branch)] -> Annex Bool
updateTo pairs = do
	-- ensure branch exists, and get its current ref
	branchref <- getBranch
	dirty <- journalDirty
	ignoredrefs <- getIgnoredRefs
	(refs, branches) <- unzip <$> filterM (isnewer ignoredrefs) pairs
	if null refs
		{- Even when no refs need to be merged, the index
		 - may still be updated if the branch has gotten ahead
		 - of the index. -}
		then whenM (needUpdateIndex branchref) $ lockJournal $ \jl -> do
			forceUpdateIndex jl branchref
			{- When there are journalled changes
			 - as well as the branch being updated,
			 - a commit needs to be done. -}
			when dirty $
				go branchref True [] [] jl
		else lockJournal $ go branchref dirty refs branches
	return $ not $ null refs
  where
	isnewer ignoredrefs (r, _)
		| S.member r ignoredrefs = return False
		| otherwise = inRepo $ Git.Branch.changed fullname r
	go branchref dirty refs branches jl = withIndex $ do
		cleanjournal <- if dirty then stageJournal jl else return noop
		let merge_desc = if null branches
			then "update"
			else "merging " ++
				unwords (map Git.Ref.describe branches) ++
				" into " ++ fromRef name
		localtransitions <- parseTransitionsStrictly "local"
			<$> getLocal transitionsLog
		unless (null branches) $ do
			showSideAction merge_desc
			mergeIndex jl refs
		let commitrefs = nub $ fullname:refs
		unlessM (handleTransitions jl localtransitions commitrefs) $ do
			ff <- if dirty
				then return False
				else inRepo $ Git.Branch.fastForward fullname refs
			if ff
				then updateIndex jl branchref
				else commitIndex jl branchref merge_desc commitrefs
		liftIO cleanjournal

{- Gets the content of a file, which may be in the journal, or in the index
 - (and committed to the branch).
 -
 - Updates the branch if necessary, to ensure the most up-to-date available
 - content is returned.
 -
 - Returns an empty string if the file doesn't exist yet. -}
get :: FilePath -> Annex String
get file = do
	update
	getLocal file

{- Like get, but does not merge the branch, so the info returned may not
 - reflect changes in remotes.
 - (Changing the value this returns, and then merging is always the
 - same as using get, and then changing its value.) -}
getLocal :: FilePath -> Annex String
getLocal file = go =<< getJournalFileStale file
  where
	go (Just journalcontent) = return journalcontent
	go Nothing = getRaw file

getRaw :: FilePath -> Annex String
getRaw = getRef fullname

getHistorical :: RefDate -> FilePath -> Annex String
getHistorical date = getRef (Git.Ref.dateRef fullname date)

getRef :: Ref -> FilePath -> Annex String
getRef ref file = withIndex $ decodeBS <$> catFile ref file

{- Applies a function to modifiy the content of a file.
 -
 - Note that this does not cause the branch to be merged, it only
 - modifes the current content of the file on the branch.
 -}
change :: FilePath -> (String -> String) -> Annex ()
change file a = lockJournal $ \jl -> a <$> getLocal file >>= set jl file

{- Records new content of a file into the journal -}
set :: JournalLocked -> FilePath -> String -> Annex ()
set = setJournalFile

{- Stages the journal, and commits staged changes to the branch. -}
commit :: String -> Annex ()
commit = whenM journalDirty . forceCommit

{- Commits the current index to the branch even without any journalled
 - changes. -}
forceCommit :: String -> Annex ()
forceCommit message = lockJournal $ \jl -> do
	cleanjournal <- stageJournal jl
	ref <- getBranch
	withIndex $ commitIndex jl ref message [fullname]
	liftIO cleanjournal

{- Commits the staged changes in the index to the branch.
 -
 - Ensures that the branch's index file is first updated to the state
 - of the branch at branchref, before running the commit action. This
 - is needed because the branch may have had changes pushed to it, that
 - are not yet reflected in the index.
 -
 - Also safely handles a race that can occur if a change is being pushed
 - into the branch at the same time. When the race happens, the commit will
 - be made on top of the newly pushed change, but without the index file
 - being updated to include it. The result is that the newly pushed
 - change is reverted. This race is detected and another commit made
 - to fix it.
 -
 - The branchref value can have been obtained using getBranch at any
 - previous point, though getting it a long time ago makes the race
 - more likely to occur.
 -}
commitIndex :: JournalLocked -> Git.Ref -> String -> [Git.Ref] -> Annex ()
commitIndex jl branchref message parents = do
	showStoringStateAction
	commitIndex' jl branchref message parents
commitIndex' :: JournalLocked -> Git.Ref -> String -> [Git.Ref] -> Annex ()
commitIndex' jl branchref message parents = do
	updateIndex jl branchref
	committedref <- inRepo $ Git.Branch.commitAlways Git.Branch.AutomaticCommit message fullname parents
	setIndexSha committedref
	parentrefs <- commitparents <$> catObject committedref
	when (racedetected branchref parentrefs) $
		fixrace committedref parentrefs
  where
	-- look for "parent ref" lines and return the refs
	commitparents = map (Git.Ref . snd) . filter isparent .
		map (toassoc . decodeBS) . L.split newline
	newline = c2w8 '\n'
	toassoc = separate (== ' ')
	isparent (k,_) = k == "parent"

	{- The race can be detected by checking the commit's
	 - parent, which will be the newly pushed branch,
	 - instead of the expected ref that the index was updated to. -}
	racedetected expectedref parentrefs
		| expectedref `elem` parentrefs = False -- good parent
		| otherwise = True -- race!

	{- To recover from the race, union merge the lost refs
	 - into the index, and recommit on top of the bad commit. -}
	fixrace committedref lostrefs = do
		mergeIndex jl lostrefs
		commitIndex jl committedref racemessage [committedref]

	racemessage = message ++ " (recovery from race)"

{- Lists all files on the branch. There may be duplicates in the list. -}
files :: Annex [FilePath]
files = do
	update
	(++)
		<$> branchFiles
		<*> getJournalledFilesStale

{- Files in the branch, not including any from journalled changes,
 - and without updating the branch. -}
branchFiles :: Annex [FilePath]
branchFiles = withIndex $ inRepo $ Git.Command.pipeNullSplitZombie
	[ Params "ls-tree --name-only -r -z"
	, Param $ fromRef fullname
	]

{- Populates the branch's index file with the current branch contents.
 -
 - This is only done when the index doesn't yet exist, and the index
 - is used to build up changes to be commited to the branch, and merge
 - in changes from other branches.
 -}
genIndex :: Git.Repo -> IO ()
genIndex g = Git.UpdateIndex.streamUpdateIndex g
	[Git.UpdateIndex.lsTree fullname g]

{- Merges the specified refs into the index.
 - Any changes staged in the index will be preserved. -}
mergeIndex :: JournalLocked -> [Git.Ref] -> Annex ()
mergeIndex jl branches = do
	prepareModifyIndex jl
	h <- catFileHandle
	inRepo $ \g -> Git.UnionMerge.mergeIndex h g branches

{- Removes any stale git lock file, to avoid git falling over when
 - updating the index.
 -
 - Since all modifications of the index are performed inside this module,
 - and only when the journal is locked, the fact that the journal has to be
 - locked when this is called ensures that no other process is currently
 - modifying the index. So any index.lock file must be stale, caused
 - by git running when the system crashed, or the repository's disk was
 - removed, etc.
 -}
prepareModifyIndex :: JournalLocked -> Annex ()
prepareModifyIndex _jl = do
	index <- fromRepo gitAnnexIndex
	void $ liftIO $ tryIO $ removeFile $ index ++ ".lock"

{- Runs an action using the branch's index file. -}
withIndex :: Annex a -> Annex a
withIndex = withIndex' False
withIndex' :: Bool -> Annex a -> Annex a
withIndex' bootstrapping a = do
	f <- fromRepo gitAnnexIndex
	withIndexFile f $ do
		checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do
			unless bootstrapping create
			createAnnexDirectory $ takeDirectory f
			unless bootstrapping $ inRepo genIndex
		a

{- Updates the branch's index to reflect the current contents of the branch.
 - Any changes staged in the index will be preserved.
 -
 - Compares the ref stored in the lock file with the current
 - ref of the branch to see if an update is needed.
 -}
updateIndex :: JournalLocked -> Git.Ref -> Annex ()
updateIndex jl branchref = whenM (needUpdateIndex branchref) $
	forceUpdateIndex jl branchref

forceUpdateIndex :: JournalLocked -> Git.Ref -> Annex ()
forceUpdateIndex jl branchref = do
	withIndex $ mergeIndex jl [fullname]
	setIndexSha branchref

{- Checks if the index needs to be updated. -}
needUpdateIndex :: Git.Ref -> Annex Bool
needUpdateIndex branchref = do
	f <- fromRepo gitAnnexIndexStatus
	committedref <- Git.Ref . firstLine <$>
		liftIO (catchDefaultIO "" $ readFileStrict f)
	return (committedref /= branchref)

{- Record that the branch's index has been updated to correspond to a
 - given ref of the branch. -}
setIndexSha :: Git.Ref -> Annex ()
setIndexSha ref = do
	f <- fromRepo gitAnnexIndexStatus
	liftIO $ writeFile f $ fromRef ref ++ "\n"
	setAnnexFilePerm f

{- Stages the journal into the index and returns an action that will
 - clean up the staged journal files, which should only be run once
 - the index has been committed to the branch.
 -
 - Before staging, this removes any existing git index file lock.
 - This is safe to do because stageJournal is the only thing that
 - modifies this index file, and only one can run at a time, because
 - the journal is locked. So any existing git index file lock must be
 - stale, and the journal must contain any data that was in the process
 - of being written to the index file when it crashed.
 -}
stageJournal :: JournalLocked -> Annex (IO ())
stageJournal jl = withIndex $ do
	prepareModifyIndex jl
	g <- gitRepo
	let dir = gitAnnexJournalDir g
	(jlogf, jlogh) <- openjlog
	withJournalHandle $ \jh -> do
		h <- hashObjectStart g
		Git.UpdateIndex.streamUpdateIndex g
			[genstream dir h jh jlogh]
		hashObjectStop h
	return $ cleanup dir jlogh jlogf
  where
	genstream dir h jh jlogh streamer = do
		v <- readDirectory jh
		case v of
			Nothing -> return ()
			Just file -> do
				unless (dirCruft file) $ do
					let path = dir </> file
					sha <- hashFile h path
					hPutStrLn jlogh file
					streamer $ Git.UpdateIndex.updateIndexLine
						sha FileBlob (asTopFilePath $ fileJournal file)
				genstream dir h jh jlogh streamer
	-- Clean up the staged files, as listed in the temp log file.
	-- The temp file is used to avoid needing to buffer all the
	-- filenames in memory.
	cleanup dir jlogh jlogf = do
		hFlush jlogh
		hSeek jlogh AbsoluteSeek 0
		stagedfs <- lines <$> hGetContents jlogh
		mapM_ (removeFile . (dir </>)) stagedfs
		hClose jlogh
		nukeFile jlogf
	openjlog = do
		tmpdir <- fromRepo gitAnnexTmpMiscDir
		createAnnexDirectory tmpdir
		liftIO $ openTempFile tmpdir "jlog"

{- This is run after the refs have been merged into the index,
 - but before the result is committed to the branch.
 - (Which is why it's passed the contents of the local branches's
 - transition log before that merge took place.)
 -
 - When the refs contain transitions that have not yet been done locally,
 - the transitions are performed on the index, and a new branch
 - is created from the result.
 -
 - When there are transitions recorded locally that have not been done
 - to the remote refs, the transitions are performed in the index,
 - and committed to the existing branch. In this case, the untransitioned
 - remote refs cannot be merged into the branch (since transitions
 - throw away history), so they are added to the list of refs to ignore,
 - to avoid re-merging content from them again.
 -}
handleTransitions :: JournalLocked -> Transitions -> [Git.Ref] -> Annex Bool
handleTransitions jl localts refs = do
	m <- M.fromList <$> mapM getreftransition refs
	let remotets = M.elems m
	if all (localts ==) remotets
		then return False
		else do
			let allts = combineTransitions (localts:remotets)
			let (transitionedrefs, untransitionedrefs) =
				partition (\r -> M.lookup r m == Just allts) refs
			performTransitionsLocked jl allts (localts /= allts) transitionedrefs
			ignoreRefs untransitionedrefs
			return True
  where
  	getreftransition ref = do
		ts <- parseTransitionsStrictly "remote" . decodeBS
			<$> catFile ref transitionsLog
		return (ref, ts)

ignoreRefs :: [Git.Ref] -> Annex ()
ignoreRefs rs = do
	old <- getIgnoredRefs
	let s = S.unions [old, S.fromList rs]
	f <- fromRepo gitAnnexIgnoredRefs
	replaceFile f $ \tmp -> liftIO $ writeFile tmp $
		unlines $ map fromRef $ S.elems s

getIgnoredRefs :: Annex (S.Set Git.Ref)
getIgnoredRefs = S.fromList . mapMaybe Git.Sha.extractSha . lines <$> content
  where
  	content = do
		f <- fromRepo gitAnnexIgnoredRefs
		liftIO $ catchDefaultIO "" $ readFile f

{- Performs the specified transitions on the contents of the index file,
 - commits it to the branch, or creates a new branch.
 -}
performTransitions :: Transitions -> Bool -> [Ref] -> Annex ()
performTransitions ts neednewlocalbranch transitionedrefs = lockJournal $ \jl ->
	performTransitionsLocked jl ts neednewlocalbranch transitionedrefs
performTransitionsLocked :: JournalLocked -> Transitions -> Bool -> [Ref] -> Annex ()
performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do
	-- For simplicity & speed, we're going to use the Annex.Queue to
	-- update the git-annex branch, while it usually holds changes
	-- for the head branch. Flush any such changes.
	Annex.Queue.flush
	withIndex $ do
		prepareModifyIndex jl
		run $ mapMaybe getTransitionCalculator $ transitionList ts
		Annex.Queue.flush
		if neednewlocalbranch
			then do
				committedref <- inRepo $ Git.Branch.commitAlways Git.Branch.AutomaticCommit message fullname transitionedrefs
				setIndexSha committedref
			else do
				ref <- getBranch
				commitIndex jl ref message (nub $ fullname:transitionedrefs)
  where
  	message
		| neednewlocalbranch && null transitionedrefs = "new branch for transition " ++ tdesc
		| otherwise = "continuing transition " ++ tdesc
	tdesc = show $ map describeTransition $ transitionList ts

	{- The changes to make to the branch are calculated and applied to
	 - the branch directly, rather than going through the journal,
	 - which would be innefficient. (And the journal is not designed
	 - to hold changes to every file in the branch at once.)
	 -
	 - When a file in the branch is changed by transition code,
	 - that value is remembered and fed into the code for subsequent
	 - transitions.
	 -}
	run [] = noop
	run changers = do
		trustmap <- calcTrustMap <$> getRaw trustLog
		fs <- branchFiles
		hasher <- inRepo hashObjectStart
		forM_ fs $ \f -> do
			content <- getRaw f
			apply changers hasher f content trustmap
		liftIO $ hashObjectStop hasher
	apply [] _ _ _ _ = return ()
	apply (changer:rest) hasher file content trustmap =
		case changer file content trustmap of
			RemoveFile -> do
				Annex.Queue.addUpdateIndex
					=<< inRepo (Git.UpdateIndex.unstageFile file)
				-- File is deleted; can't run any other
				-- transitions on it.
				return ()
			ChangeFile content' -> do
				sha <- inRepo $ hashObject BlobObject content'
				Annex.Queue.addUpdateIndex $ Git.UpdateIndex.pureStreamer $
					Git.UpdateIndex.updateIndexLine sha FileBlob (asTopFilePath file)
				apply rest hasher file content' trustmap
			PreserveFile ->
				apply rest hasher file content trustmap


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

module Annex.Branch.Transitions (
	FileTransition(..),
	getTransitionCalculator
) where

import Logs
import Logs.Transitions
import qualified Logs.UUIDBased as UUIDBased
import qualified Logs.Presence.Pure as Presence
import qualified Logs.Chunk.Pure as Chunk
import Types.TrustLevel
import Types.UUID

import qualified Data.Map as M

data FileTransition
	= ChangeFile String
	| RemoveFile
	| PreserveFile

type TransitionCalculator = FilePath -> String -> TrustMap -> FileTransition

getTransitionCalculator :: Transition -> Maybe TransitionCalculator
getTransitionCalculator ForgetGitHistory = Nothing
getTransitionCalculator ForgetDeadRemotes = Just dropDead

dropDead :: FilePath -> String -> TrustMap -> FileTransition
dropDead f content trustmap = case getLogVariety f of
	Just UUIDBasedLog
		-- Don't remove the dead repo from the trust log,
		-- because git remotes may still exist, and they need
		-- to still know it's dead.
		| f == trustLog -> PreserveFile
		| otherwise -> ChangeFile $ UUIDBased.showLog id $ dropDeadFromMapLog trustmap id $ UUIDBased.parseLog Just content
	Just NewUUIDBasedLog -> ChangeFile $
		UUIDBased.showLogNew id $ dropDeadFromMapLog trustmap id $ UUIDBased.parseLogNew Just content
	Just (ChunkLog _) -> ChangeFile $
		Chunk.showLog $ dropDeadFromMapLog trustmap fst $ Chunk.parseLog content
	Just (PresenceLog _) ->
		let newlog = Presence.compactLog $ dropDeadFromPresenceLog trustmap $ Presence.parseLog content
		in if null newlog
			then RemoveFile
			else ChangeFile $ Presence.showLog newlog
	Just OtherLog -> PreserveFile
	Nothing -> PreserveFile

dropDeadFromMapLog :: Ord k => TrustMap -> (k -> UUID) -> M.Map k v -> M.Map k v
dropDeadFromMapLog trustmap getuuid = M.filterWithKey $ \k _v -> notDead trustmap getuuid k

{- Presence logs can contain UUIDs or other values. Any line that matches
 - a dead uuid is dropped; any other values are passed through. -}
dropDeadFromPresenceLog :: TrustMap -> [Presence.LogLine] -> [Presence.LogLine]
dropDeadFromPresenceLog trustmap = filter $ notDead trustmap (toUUID . Presence.info)

notDead :: TrustMap -> (v -> UUID) -> v -> Bool
notDead trustmap a v = M.findWithDefault SemiTrusted (a v) trustmap /= DeadTrusted

repo_name: kakafarm/git

license: unknown


code:
{- git-annex branch state management
 -
 - Runtime state about the git-annex branch.
 -
 - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Annex.BranchState where

import Common.Annex
import Types.BranchState
import qualified Annex

getState :: Annex BranchState
getState = Annex.getState Annex.branchstate

setState :: BranchState -> Annex ()
setState state = Annex.changeState $ \s -> s { Annex.branchstate = state }

changeState :: (BranchState -> BranchState) -> Annex ()
changeState changer = setState =<< changer <$> getState

{- Runs an action to check that the index file exists, if it's not been
 - checked before in this run of git-annex. -}
checkIndexOnce :: Annex () -> Annex ()
checkIndexOnce a = unlessM (indexChecked <$> getState) $ do
	a
	changeState $ \s -> s { indexChecked = True }

{- Runs an action to update the branch, if it's not been updated before
 - in this run of git-annex. -}
runUpdateOnce :: Annex () -> Annex ()
runUpdateOnce a = unlessM (branchUpdated <$> getState) $ do
	a
	disableUpdate

{- Avoids updating the branch. A useful optimisation when the branch
 - is known to have not changed, or git-annex won't be relying on info
 - from it. -}
disableUpdate :: Annex ()
disableUpdate = changeState $ \s -> s { branchUpdated = True }


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

module Annex.CatFile (
	catFile,
	catFileDetails,
	catObject,
	catTree,
	catObjectDetails,
	catFileHandle,
	catKey,
	catKeyFile,
	catKeyFileHEAD,
	catLink,
) where

import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
import System.PosixCompat.Types

import Common.Annex
import qualified Git
import qualified Git.CatFile
import qualified Annex
import Git.Types
import Git.FilePath
import Git.FileMode
import qualified Git.Ref

catFile :: Git.Branch -> FilePath -> Annex L.ByteString
catFile branch file = do
	h <- catFileHandle
	liftIO $ Git.CatFile.catFile h branch file

catFileDetails :: Git.Branch -> FilePath -> Annex (Maybe (L.ByteString, Sha, ObjectType))
catFileDetails branch file = do
	h <- catFileHandle
	liftIO $ Git.CatFile.catFileDetails h branch file

catObject :: Git.Ref -> Annex L.ByteString
catObject ref = do
	h <- catFileHandle
	liftIO $ Git.CatFile.catObject h ref

catTree :: Git.Ref -> Annex [(FilePath, FileMode)]
catTree ref = do
	h <- catFileHandle
	liftIO $ Git.CatFile.catTree h ref

catObjectDetails :: Git.Ref -> Annex (Maybe (L.ByteString, Sha, ObjectType))
catObjectDetails ref = do
	h <- catFileHandle
	liftIO $ Git.CatFile.catObjectDetails h ref

{- There can be multiple index files, and a different cat-file is needed
 - for each. This is selected by setting GIT_INDEX_FILE in the gitEnv. -}
catFileHandle :: Annex Git.CatFile.CatFileHandle
catFileHandle = do
	m <- Annex.getState Annex.catfilehandles
	indexfile <- fromMaybe "" . maybe Nothing (lookup "GIT_INDEX_FILE")
		<$> fromRepo gitEnv
	case M.lookup indexfile m of
		Just h -> return h
		Nothing -> do
			h <- inRepo Git.CatFile.catFileStart
			let m' = M.insert indexfile h m
			Annex.changeState $ \s -> s { Annex.catfilehandles = m' }
			return h

{- From the Sha or Ref of a symlink back to the key.
 -
 - Requires a mode witness, to guarantee that the file is a symlink.
 -}
catKey :: Ref -> FileMode -> Annex (Maybe Key)
catKey = catKey' True

catKey' :: Bool -> Sha -> FileMode -> Annex (Maybe Key)
catKey' modeguaranteed sha mode
	| isSymLink mode = do
		l <- catLink modeguaranteed sha
		return $ if isLinkToAnnex l
			then fileKey $ takeFileName l
			else Nothing
	| otherwise = return Nothing

{- Gets a symlink target. -}
catLink :: Bool -> Sha -> Annex String
catLink modeguaranteed sha = fromInternalGitPath . decodeBS <$> get
  where
  	-- If the mode is not guaranteed to be correct, avoid
	-- buffering the whole file content, which might be large.
	-- 8192 is enough if it really is a symlink.
  	get
		| modeguaranteed = catObject sha
		| otherwise = L.take 8192 <$> catObject sha

{- Looks up the key corresponding to the Ref using the running cat-file.
 -
 - Currently this always has to look in HEAD, because cat-file --batch
 - does not offer a way to specify that we want to look up a tree object
 - in the index. So if the index has a file staged not as a symlink,
 - and it is a symlink in head, the wrong mode is gotten.
 - Also, we have to assume the file is a symlink if it's not yet committed
 - to HEAD. For these reasons, modeguaranteed is not set.
 -}
catKeyChecked :: Bool -> Ref -> Annex (Maybe Key)
catKeyChecked needhead ref@(Ref r) =
	catKey' False ref =<< findmode <$> catTree treeref
  where
  	pathparts = split "/" r
	dir = intercalate "/" $ take (length pathparts - 1) pathparts
	file = fromMaybe "" $ lastMaybe pathparts
	treeref = Ref $ if needhead then "HEAD" ++ dir ++ "/" else dir ++ "/"
	findmode = fromMaybe symLinkMode . headMaybe .
		 map snd . filter (\p -> fst p == file)

{- From a file in the repository back to the key.
 -
 - Ideally, this should reflect the key that's staged in the index,
 - not the key that's committed to HEAD. Unfortunately, git cat-file
 - does not refresh the index file after it's started up, so things
 - newly staged in the index won't show up. It does, however, notice
 - when branches change.
 -
 - For command-line git-annex use, that doesn't matter. It's perfectly
 - reasonable for things staged in the index after the currently running
 - git-annex process to not be noticed by it. However, we do want to see
 - what's in the index, since it may have uncommitted changes not in HEAD
 -
 - For the assistant, this is much more of a problem, since it commits
 - files and then needs to be able to immediately look up their keys.
 - OTOH, the assistant doesn't keep changes staged in the index for very
 - long at all before committing them -- and it won't look at the keys
 - of files until after committing them.
 -
 - So, this gets info from the index, unless running as a daemon.
 -}
catKeyFile :: FilePath -> Annex (Maybe Key)
catKeyFile f = ifM (Annex.getState Annex.daemon)
	( catKeyFileHEAD f
	, catKeyChecked True $ Git.Ref.fileRef f
	)

catKeyFileHEAD :: FilePath -> Annex (Maybe Key)
catKeyFileHEAD f = catKeyChecked False $ Git.Ref.fileFromRef Git.Ref.headRef f


code:
{- git check-attr interface, with handle automatically stored in the Annex monad
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Annex.CheckAttr (
	checkAttr,
	checkAttrHandle
) where

import Common.Annex
import qualified Git.CheckAttr as Git
import qualified Annex

{- All gitattributes used by git-annex. -}
annexAttrs :: [Git.Attr]
annexAttrs =
	[ "annex.backend"
	, "annex.numcopies"
	]

checkAttr :: Git.Attr -> FilePath -> Annex String
checkAttr attr file = do
	h <- checkAttrHandle
	liftIO $ Git.checkAttr h attr file

checkAttrHandle :: Annex Git.CheckAttrHandle
checkAttrHandle = maybe startup return =<< Annex.getState Annex.checkattrhandle
  where
	startup = do
		h <- inRepo $ Git.checkAttrStart annexAttrs
		Annex.changeState $ \s -> s { Annex.checkattrhandle = Just h }
		return h


code:
{- git check-ignore interface, with handle automatically stored in
 - the Annex monad
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Annex.CheckIgnore (
	checkIgnored,
	checkIgnoreHandle
) where

import Common.Annex
import qualified Git.CheckIgnore as Git
import qualified Annex

checkIgnored :: FilePath -> Annex Bool
checkIgnored file = go =<< checkIgnoreHandle
  where
  	go Nothing = return False
	go (Just h) = liftIO $ Git.checkIgnored h file

checkIgnoreHandle :: Annex (Maybe Git.CheckIgnoreHandle)
checkIgnoreHandle = maybe startup return =<< Annex.getState Annex.checkignorehandle
  where
	startup = do
		v <- inRepo Git.checkIgnoreStart
		when (isNothing v) $
			warning "The installed version of git is too old for .gitignores to be honored by git-annex."
		Annex.changeState $ \s -> s { Annex.checkignorehandle = Just v }
		return v


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

{-# LANGUAGE CPP #-}

module Annex.Content (
	inAnnex,
	inAnnexSafe,
	inAnnexCheck,
	lockContent,
	getViaTmp,
	getViaTmpChecked,
	getViaTmpUnchecked,
	prepGetViaTmpChecked,
	prepTmp,
	withTmp,
	checkDiskSpace,
	moveAnnex,
	sendAnnex,
	prepSendAnnex,
	removeAnnex,
	fromAnnex,
	moveBad,
	KeyLocation(..),
	getKeysPresent,
	saveState,
	downloadUrl,
	preseedTmp,
	freezeContent,
	thawContent,
	dirKeys,
	withObjectLoc,
) where

import System.IO.Unsafe (unsafeInterleaveIO)

import Common.Annex
import Logs.Location
import qualified Git
import qualified Annex
import qualified Annex.Queue
import qualified Annex.Branch
import Utility.DiskFree
import Utility.FileMode
import qualified Annex.Url as Url
import Types.Key
import Utility.DataUnits
import Utility.CopyFile
import Config
import Git.SharedRepository
import Annex.Perms
import Annex.Link
import Annex.Content.Direct
import Annex.ReplaceFile
import Annex.Exception

#ifdef mingw32_HOST_OS
import Utility.WinLock
#endif

{- Checks if a given key's content is currently present. -}
inAnnex :: Key -> Annex Bool
inAnnex key = inAnnexCheck key $ liftIO . doesFileExist

{- Runs an arbitrary check on a key's content. -}
inAnnexCheck :: Key -> (FilePath -> Annex Bool) -> Annex Bool
inAnnexCheck key check = inAnnex' id False check key

{- Generic inAnnex, handling both indirect and direct mode.
 -
 - In direct mode, at least one of the associated files must pass the
 - check. Additionally, the file must be unmodified.
 -}
inAnnex' :: (a -> Bool) -> a -> (FilePath -> Annex a) -> Key -> Annex a
inAnnex' isgood bad check key = withObjectLoc key checkindirect checkdirect
  where
	checkindirect loc = do
		whenM (fromRepo Git.repoIsUrl) $
			error "inAnnex cannot check remote repo"
		check loc
	checkdirect [] = return bad
	checkdirect (loc:locs) = do
		r <- check loc
		if isgood r
			then ifM (goodContent key loc)
				( return r
				, checkdirect locs
				)
			else checkdirect locs

{- A safer check; the key's content must not only be present, but
 - is not in the process of being removed. -}
inAnnexSafe :: Key -> Annex (Maybe Bool)
inAnnexSafe key = inAnnex' (fromMaybe False) (Just False) go key
  where
	is_locked = Nothing
	is_unlocked = Just True
	is_missing = Just False

	go contentfile = maybe (checkindirect contentfile) (checkdirect contentfile)
		=<< contentLockFile key

#ifndef mingw32_HOST_OS
	checkindirect f = liftIO $ openforlock f >>= check is_missing
	{- In direct mode, the content file must exist, but
	 - the lock file often generally won't exist unless a removal is in
	 - process. This does not create the lock file, it only checks for
	 - it. -}
	checkdirect contentfile lockfile = liftIO $
		ifM (doesFileExist contentfile)
			( openforlock lockfile >>= check is_unlocked
			, return is_missing
			)
	openforlock f = catchMaybeIO $
		openFd f ReadOnly Nothing defaultFileFlags
	check _ (Just h) = do
		v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)
		closeFd h
		return $ case v of
			Just _ -> is_locked
			Nothing -> is_unlocked
	check def Nothing = return def
#else
	checkindirect f = liftIO $ ifM (doesFileExist f)
		( do
			v <- lockShared f
			case v of
				Nothing -> return is_locked
				Just lockhandle -> do
					dropLock lockhandle
					return is_unlocked
		, return is_missing
		)
	{- In Windows, see if we can take a shared lock. If so,
	 - remove the lock file to clean up after ourselves. -}
	checkdirect contentfile lockfile =
		ifM (liftIO $ doesFileExist contentfile)
			( modifyContent lockfile $ liftIO $ do
				v <- lockShared lockfile
				case v of
					Nothing -> return is_locked
					Just lockhandle -> do
						dropLock lockhandle
						void $ tryIO $ nukeFile lockfile
						return is_unlocked
			, return is_missing
			)
#endif

{- Direct mode and especially Windows has to use a separate lock
 - file from the content, since locking the actual content file
 - would interfere with the user's use of it. -}
contentLockFile :: Key -> Annex (Maybe FilePath)
contentLockFile key = ifM isDirect
	( Just <$> calcRepo (gitAnnexContentLock key)
	, return Nothing
	)

{- Content is exclusively locked while running an action that might remove
 - it. (If the content is not present, no locking is done.) -}
lockContent :: Key -> Annex a -> Annex a
lockContent key a = do
	contentfile <- calcRepo $ gitAnnexLocation key
	lockfile <- contentLockFile key
	maybe noop setuplockfile lockfile
	bracketAnnex (liftIO $ lock contentfile lockfile) (unlock lockfile) (const a)
  where
	alreadylocked = error "content is locked"
	setuplockfile lockfile = modifyContent lockfile $
		void $ liftIO $ tryIO $
			writeFile lockfile ""
	cleanuplockfile lockfile = modifyContent lockfile $
		void $ liftIO $ tryIO $
			nukeFile lockfile
#ifndef mingw32_HOST_OS
	lock contentfile Nothing = opencontentforlock contentfile >>= dolock
	lock _ (Just lockfile) = openforlock lockfile >>= dolock . Just
	{- Since content files are stored with the write bit disabled, have
	 - to fiddle with permissions to open for an exclusive lock. -}
	opencontentforlock f = catchMaybeIO $ ifM (doesFileExist f)
		( withModifiedFileMode f
			(`unionFileModes` ownerWriteMode)
			(openforlock f)
		, openforlock f
		)
	openforlock f = openFd f ReadWrite Nothing defaultFileFlags
	dolock Nothing = return Nothing
	dolock (Just fd) = do
		v <- tryIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
		case v of
			Left _ -> alreadylocked
			Right _ -> return $ Just fd
	unlock mlockfile mfd = do
		maybe noop cleanuplockfile mlockfile
		liftIO $ maybe noop closeFd mfd
#else
	lock _ (Just lockfile) = maybe alreadylocked (return . Just) =<< lockExclusive lockfile
	lock _ Nothing = return Nothing
	unlock mlockfile mlockhandle = do
		liftIO $ maybe noop dropLock mlockhandle
		maybe noop cleanuplockfile mlockfile
#endif

{- Runs an action, passing it a temporary filename to get,
 - and if the action succeeds, moves the temp file into
 - the annex as a key's content. -}
getViaTmp :: Key -> (FilePath -> Annex Bool) -> Annex Bool
getViaTmp = getViaTmpChecked (return True)

{- Like getViaTmp, but does not check that there is enough disk space
 - for the incoming key. For use when the key content is already on disk
 - and not being copied into place. -}
getViaTmpUnchecked :: Key -> (FilePath -> Annex Bool) -> Annex Bool
getViaTmpUnchecked = finishGetViaTmp (return True)

getViaTmpChecked :: Annex Bool -> Key -> (FilePath -> Annex Bool) -> Annex Bool
getViaTmpChecked check key action =
	prepGetViaTmpChecked key False $
		finishGetViaTmp check key action

{- Prepares to download a key via a tmp file, and checks that there is
 - enough free disk space.
 -
 - When the temp file already exists, count the space it is using as
 - free, since the download will overwrite it or resume.
 -
 - Wen there's enough free space, runs the download action.
 -}
prepGetViaTmpChecked :: Key -> a -> Annex a -> Annex a
prepGetViaTmpChecked key unabletoget getkey = do
	tmp <- fromRepo $ gitAnnexTmpObjectLocation key

	e <- liftIO $ doesFileExist tmp
	alreadythere <- if e
		then fromIntegral . fileSize <$> liftIO (getFileStatus tmp)
		else return 0
	ifM (checkDiskSpace Nothing key alreadythere)
		( do
			-- The tmp file may not have been left writable
			when e $ thawContent tmp
			getkey
		, return unabletoget
		)

finishGetViaTmp :: Annex Bool -> Key -> (FilePath -> Annex Bool) -> Annex Bool
finishGetViaTmp check key action = do
	tmpfile <- prepTmp key
	ifM (action tmpfile <&&> check)
		( do
			moveAnnex key tmpfile
			logStatus key InfoPresent
			return True
		-- the tmp file is left behind, in case caller wants
		-- to resume its transfer
		, return False
		)

prepTmp :: Key -> Annex FilePath
prepTmp key = do
	tmp <- fromRepo $ gitAnnexTmpObjectLocation key
	createAnnexDirectory (parentDir tmp)
	return tmp

{- Creates a temp file for a key, runs an action on it, and cleans up
 - the temp file. If the action throws an exception, the temp file is
 - left behind, which allows for resuming.
 -}
withTmp :: Key -> (FilePath -> Annex a) -> Annex a
withTmp key action = do
	tmp <- prepTmp key
	res <- action tmp
	liftIO $ nukeFile tmp
	return res

{- Checks that there is disk space available to store a given key,
 - in a destination (or the annex) printing a warning if not. -}
checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Annex Bool
checkDiskSpace destination key alreadythere = do
	reserve <- annexDiskReserve <$> Annex.getGitConfig
	free <- liftIO . getDiskFree =<< dir
	force <- Annex.getState Annex.force
	case (free, keySize key) of
		(Just have, Just need) -> do
			let ok = (need + reserve <= have + alreadythere) || force
			unless ok $
				needmorespace (need + reserve - have - alreadythere)
			return ok
		_ -> return True
  where
	dir = maybe (fromRepo gitAnnexDir) return destination
	needmorespace n =
		warning $ "not enough free space, need " ++
			roughSize storageUnits True n ++
			" more" ++ forcemsg
	forcemsg = " (use --force to override this check or adjust annex.diskreserve)"

{- Moves a key's content into .git/annex/objects/
 -
 - In direct mode, moves it to the associated file, or files.
 -
 - What if the key there already has content? This could happen for
 - various reasons; perhaps the same content is being annexed again.
 - Perhaps there has been a hash collision generating the keys.
 -
 - The current strategy is to assume that in this case it's safe to delete
 - one of the two copies of the content; and the one already in the annex
 - is left there, assuming it's the original, canonical copy.
 -
 - I considered being more paranoid, and checking that both files had
 - the same content. Decided against it because A) users explicitly choose
 - a backend based on its hashing properties and so if they're dealing
 - with colliding files it's their own fault and B) adding such a check
 - would not catch all cases of colliding keys. For example, perhaps
 - a remote has a key; if it's then added again with different content then
 - the overall system now has two different peices of content for that
 - key, and one of them will probably get deleted later. So, adding the
 - check here would only raise expectations that git-annex cannot truely
 - meet.
 -}
moveAnnex :: Key -> FilePath -> Annex ()
moveAnnex key src = withObjectLoc key storeobject storedirect
  where
	storeobject dest = ifM (liftIO $ doesFileExist dest)
		( alreadyhave
		, modifyContent dest $ do
			liftIO $ moveFile src dest
			freezeContent dest
		)
	storeindirect = storeobject =<< calcRepo (gitAnnexLocation key)

	{- In direct mode, the associated file's content may be locally
	 - modified. In that case, it's preserved. However, the content
	 - we're moving into the annex may be the only extant copy, so
	 - it's important we not lose it. So, when the key's content
	 - cannot be moved to any associated file, it's stored in indirect
	 - mode.
	 -}
	storedirect = storedirect' storeindirect
	storedirect' fallback [] = fallback
	storedirect' fallback (f:fs) = do
		thawContent src
		v <- isAnnexLink f
		if Just key == v
			then do
				updateInodeCache key src
				replaceFile f $ liftIO . moveFile src
				chmodContent f
				forM_ fs $
					addContentWhenNotPresent key f
			else ifM (goodContent key f)
				( storedirect' alreadyhave fs
				, storedirect' fallback fs
				)

	alreadyhave = liftIO $ removeFile src

{- Runs an action to transfer an object's content.
 -
 - In direct mode, it's possible for the file to change as it's being sent.
 - If this happens, runs the rollback action and returns False. The
 - rollback action should remove the data that was transferred.
 -}
sendAnnex :: Key -> Annex () -> (FilePath -> Annex Bool) -> Annex Bool
sendAnnex key rollback sendobject = go =<< prepSendAnnex key
  where
	go Nothing = return False
	go (Just (f, checksuccess)) = do
		r <- sendobject f
		ifM checksuccess
			( return r
			, do
				rollback
				return False
			)

{- Returns a file that contains an object's content,
 - and an check to run after the transfer is complete.
 -
 - In direct mode, it's possible for the file to change as it's being sent,
 - and the check detects this case and returns False.
 -
 - Note that the returned check action is, in some cases, run in the
 - Annex monad of the remote that is receiving the object, rather than
 - the sender. So it cannot rely on Annex state.
 -}
prepSendAnnex :: Key -> Annex (Maybe (FilePath, Annex Bool))
prepSendAnnex key = withObjectLoc key indirect direct
  where
	indirect f = return $ Just (f, return True)
	direct [] = return Nothing
	direct (f:fs) = do
		cache <- recordedInodeCache key
		-- check that we have a good file
		ifM (sameInodeCache f cache)
			( return $ Just (f, sameInodeCache f cache)
			, direct fs
			)

{- Performs an action, passing it the location to use for a key's content.
 -
 - In direct mode, the associated files will be passed. But, if there are
 - no associated files for a key, the indirect mode action will be
 - performed instead. -}
withObjectLoc :: Key -> (FilePath -> Annex a) -> ([FilePath] -> Annex a) -> Annex a
withObjectLoc key indirect direct = ifM isDirect
	( do
		fs <- associatedFiles key
		if null fs
			then goindirect
			else direct fs
	, goindirect
	)
  where
	goindirect = indirect =<< calcRepo (gitAnnexLocation key)

cleanObjectLoc :: Key -> Annex () -> Annex ()
cleanObjectLoc key cleaner = do
	file <- calcRepo $ gitAnnexLocation key
	void $ tryAnnexIO $ thawContentDir file
	cleaner
	liftIO $ removeparents file (3 :: Int)
  where
	removeparents _ 0 = noop
	removeparents file n = do
		let dir = parentDir file
		maybe noop (const $ removeparents dir (n-1))
			<=< catchMaybeIO $ removeDirectory dir

{- Removes a key's file from .git/annex/objects/
 -
 - In direct mode, deletes the associated files or files, and replaces
 - them with symlinks. -}
removeAnnex :: Key -> Annex ()
removeAnnex key = withObjectLoc key remove removedirect
  where
	remove file = cleanObjectLoc key $ do
		secureErase file
		liftIO $ nukeFile file
		removeInodeCache key
	removedirect fs = do
		cache <- recordedInodeCache key
		removeInodeCache key
		mapM_ (resetfile cache) fs
	resetfile cache f = whenM (sameInodeCache f cache) $ do
		l <- inRepo $ gitAnnexLink f key
		secureErase f
		replaceFile f $ makeAnnexLink l

{- Runs the secure erase command if set, otherwise does nothing.
 - File may or may not be deleted at the end; caller is responsible for
 - making sure it's deleted. -}
secureErase :: FilePath -> Annex ()
secureErase file = maybe noop go =<< annexSecureEraseCommand <$> Annex.getGitConfig
  where
  	go basecmd = void $ liftIO $
		boolSystem "sh" [Param "-c", Param $ gencmd basecmd]
	gencmd = massReplace [ ("%file", shellEscape file) ]

{- Moves a key's file out of .git/annex/objects/ -}
fromAnnex :: Key -> FilePath -> Annex ()
fromAnnex key dest = cleanObjectLoc key $ do
	file <- calcRepo $ gitAnnexLocation key
	thawContent file
	liftIO $ moveFile file dest

{- Moves a key out of .git/annex/objects/ into .git/annex/bad, and
 - returns the file it was moved to. -}
moveBad :: Key -> Annex FilePath
moveBad key = do
	src <- calcRepo $ gitAnnexLocation key
	bad <- fromRepo gitAnnexBadDir
	let dest = bad </> takeFileName src
	createAnnexDirectory (parentDir dest)
	cleanObjectLoc key $
		liftIO $ moveFile src dest
	logStatus key InfoMissing
	return dest

data KeyLocation = InAnnex | InRepository

{- List of keys whose content exists in the specified location.

 - InAnnex only lists keys under .git/annex/objects,
 - while InRepository, in direct mode, also finds keys located in the
 - work tree.
 -
 - Note that InRepository has to check whether direct mode files
 - have goodContent.
 -}
getKeysPresent :: KeyLocation -> Annex [Key]
getKeysPresent keyloc = do
	direct <- isDirect
	dir <- fromRepo gitAnnexObjectDir
	s <- getstate direct
	liftIO $ traverse s direct (2 :: Int) dir
  where
	traverse s direct depth dir = do
		contents <- catchDefaultIO [] (dirContents dir)
		if depth == 0
			then do
				contents' <- filterM (present s direct) contents
				let keys = mapMaybe (fileKey . takeFileName) contents'
				continue keys []
			else do
				let deeper = traverse s direct (depth - 1)
				continue [] (map deeper contents)
	continue keys [] = return keys
	continue keys (a:as) = do
		{- Force lazy traversal with unsafeInterleaveIO. -}
		morekeys <- unsafeInterleaveIO a
		continue (morekeys++keys) as

	present _ False d = presentInAnnex d
	present s True d = presentDirect s d <||> presentInAnnex d

	presentInAnnex = doesFileExist . contentfile
	contentfile d = d </> takeFileName d

	presentDirect s d = case keyloc of
		InAnnex -> return False
		InRepository -> case fileKey (takeFileName d) of
			Nothing -> return False
			Just k -> Annex.eval s $
				anyM (goodContent k) =<< associatedFiles k

	{- In order to run Annex monad actions within unsafeInterleaveIO,
	 - the current state is taken and reused. No changes made to this
	 - state will be preserved.
	 -
	 - As an optimsation, call inodesChanged to prime the state with
	 - a cached value that will be used in the call to goodContent.
	 -}
	getstate direct = do
		when direct $
			void $ inodesChanged
		Annex.getState id

{- Things to do to record changes to content when shutting down.
 -
 - It's acceptable to avoid committing changes to the branch,
 - especially if performing a short-lived action.
 -}
saveState :: Bool -> Annex ()
saveState nocommit = doSideAction $ do
	Annex.Queue.flush
	unless nocommit $
		whenM (annexAlwaysCommit <$> Annex.getGitConfig) $
			Annex.Branch.commit "update"

{- Downloads content from any of a list of urls. -}
downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool
downloadUrl urls file = go =<< annexWebDownloadCommand <$> Annex.getGitConfig
  where
  	go Nothing = Url.withUrlOptions $ \uo ->
		anyM (\u -> Url.download u file uo) urls
	go (Just basecmd) = liftIO $ anyM (downloadcmd basecmd) urls
	downloadcmd basecmd url =
		boolSystem "sh" [Param "-c", Param $ gencmd url basecmd]
			<&&> doesFileExist file
	gencmd url = massReplace
		[ ("%file", shellEscape file)
		, ("%url", shellEscape url)
		]

{- Copies a key's content, when present, to a temp file.
 - This is used to speed up some rsyncs. -}
preseedTmp :: Key -> FilePath -> Annex Bool
preseedTmp key file = go =<< inAnnex key
  where
	go False = return False
	go True = do
		ok <- copy
		when ok $ thawContent file
		return ok
	copy = ifM (liftIO $ doesFileExist file)
		( return True
		, do
			s <- calcRepo $ gitAnnexLocation key
			liftIO $ copyFileExternal s file
		)

{- Blocks writing to an annexed file, and modifies file permissions to
 - allow reading it, per core.sharedRepository setting. -}
freezeContent :: FilePath -> Annex ()
freezeContent file = unlessM crippledFileSystem $
	liftIO . go =<< fromRepo getSharedRepository
  where
	go GroupShared = modifyFileMode file $
		removeModes writeModes .
		addModes [ownerReadMode, groupReadMode]
	go AllShared = modifyFileMode file $
		removeModes writeModes .
		addModes readModes
	go _ = modifyFileMode file $
		removeModes writeModes .
		addModes [ownerReadMode]

{- Adjusts read mode of annexed file per core.sharedRepository setting. -}
chmodContent :: FilePath -> Annex ()
chmodContent file = unlessM crippledFileSystem $
	liftIO . go =<< fromRepo getSharedRepository
  where
	go GroupShared = modifyFileMode file $
		addModes [ownerReadMode, groupReadMode]
	go AllShared = modifyFileMode file $
		addModes readModes
	go _ = modifyFileMode file $
		addModes [ownerReadMode]

{- Allows writing to an annexed file that freezeContent was called on
 - before. -}
thawContent :: FilePath -> Annex ()
thawContent file = unlessM crippledFileSystem $
	liftIO . go =<< fromRepo getSharedRepository
  where
	go GroupShared = groupWriteRead file
	go AllShared = groupWriteRead file
	go _ = allowWrite file

{- Finds files directly inside a directory like gitAnnexBadDir
 - (not in subdirectories) and returns the corresponding keys. -}
dirKeys :: (Git.Repo -> FilePath) -> Annex [Key]
dirKeys dirspec = do
	dir <- fromRepo dirspec
	ifM (liftIO $ doesDirectoryExist dir)
		( do
			contents <- liftIO $ getDirectoryContents dir
			files <- liftIO $ filterM doesFileExist $
				map (dir </>) contents
			return $ mapMaybe (fileKey . takeFileName) files
		, return []
		)


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

{-# LANGUAGE CPP #-}

module Annex.Content.Direct (
	associatedFiles,
	associatedFilesRelative,
	removeAssociatedFile,
	removeAssociatedFileUnchecked,
	removeAssociatedFiles,
	addAssociatedFile,
	goodContent,
	recordedInodeCache,
	updateInodeCache,
	addInodeCache,
	writeInodeCache,
	compareInodeCaches,
	compareInodeCachesWith,
	sameInodeCache,
	elemInodeCaches,
	sameFileStatus,
	removeInodeCache,
	toInodeCache,
	inodesChanged,
	createInodeSentinalFile,
	addContentWhenNotPresent,
	withTSDelta,
	getTSDelta,
) where

import Common.Annex
import qualified Annex
import Annex.Perms
import qualified Git
import Utility.Tmp
import Logs.Location
import Utility.InodeCache
import Utility.CopyFile
import Annex.ReplaceFile
import Annex.Link

{- Absolute FilePaths of Files in the tree that are associated with a key. -}
associatedFiles :: Key -> Annex [FilePath]
associatedFiles key = do
	files <- associatedFilesRelative key
	top <- fromRepo Git.repoPath
	return $ map (top </>) files

{- List of files in the tree that are associated with a key, relative to
 - the top of the repo. -}
associatedFilesRelative :: Key -> Annex [FilePath]
associatedFilesRelative key = do
	mapping <- calcRepo $ gitAnnexMapping key
	liftIO $ catchDefaultIO [] $ withFile mapping ReadMode $ \h -> do
		fileEncoding h
		-- Read strictly to ensure the file is closed
		-- before changeAssociatedFiles tries to write to it.
		-- (Especially needed on Windows.)
		lines <$> hGetContentsStrict h

{- Changes the associated files information for a key, applying a
 - transformation to the list. Returns new associatedFiles value. -}
changeAssociatedFiles :: Key -> ([FilePath] -> [FilePath]) -> Annex [FilePath]
changeAssociatedFiles key transform = do
	mapping <- calcRepo $ gitAnnexMapping key
	files <- associatedFilesRelative key
	let files' = transform files
	when (files /= files') $
		modifyContent mapping $
			liftIO $ viaTmp writeFileAnyEncoding mapping $
				unlines files'
	top <- fromRepo Git.repoPath
	return $ map (top </>) files'

{- Removes the list of associated files. -}
removeAssociatedFiles :: Key -> Annex ()
removeAssociatedFiles key = do
	mapping <- calcRepo $ gitAnnexMapping key
	modifyContent mapping $
		liftIO $ nukeFile mapping

{- Removes an associated file. Returns new associatedFiles value.
 - Checks if this was the last copy of the object, and updates location
 - log. -}
removeAssociatedFile :: Key -> FilePath -> Annex [FilePath]
removeAssociatedFile key file = do
	fs <- removeAssociatedFileUnchecked key file
	when (null fs) $
		logStatus key InfoMissing
	return fs

{- Removes an associated file. Returns new associatedFiles value. -}
removeAssociatedFileUnchecked :: Key -> FilePath -> Annex [FilePath]
removeAssociatedFileUnchecked key file = do
	file' <- normaliseAssociatedFile file
	changeAssociatedFiles key $ filter (/= file')

{- Adds an associated file. Returns new associatedFiles value. -}
addAssociatedFile :: Key -> FilePath -> Annex [FilePath]
addAssociatedFile key file = do
	file' <- normaliseAssociatedFile file
	changeAssociatedFiles key $ \files ->
		if file' `elem` files
			then files
			else file':files

{- Associated files are always stored relative to the top of the repository.
 - The input FilePath is relative to the CWD, or is absolute. -}
normaliseAssociatedFile :: FilePath -> Annex FilePath
normaliseAssociatedFile file = do
	top <- fromRepo Git.repoPath
	liftIO $ relPathDirToFile top <$> absPath file

{- Checks if a file in the tree, associated with a key, has not been modified.
 -
 - To avoid needing to fsck the file's content, which can involve an
 - expensive checksum, this relies on a cache that contains the file's
 - expected mtime and inode.
 -}
goodContent :: Key -> FilePath -> Annex Bool
goodContent key file = sameInodeCache file =<< recordedInodeCache key

{- Gets the recorded inode cache for a key.
 -
 - A key can be associated with multiple files, so may return more than
 - one. -}
recordedInodeCache :: Key -> Annex [InodeCache]
recordedInodeCache key = withInodeCacheFile key $ \f ->
	liftIO $ catchDefaultIO [] $
		mapMaybe readInodeCache . lines <$> readFileStrict f

{- Caches an inode for a file.
 -
 - Anything else already cached is preserved.
 -}
updateInodeCache :: Key -> FilePath -> Annex ()
updateInodeCache key file = maybe noop (addInodeCache key)
	=<< withTSDelta (liftIO . genInodeCache file)

{- Adds another inode to the cache for a key. -}
addInodeCache :: Key -> InodeCache -> Annex ()
addInodeCache key cache = do
	oldcaches <- recordedInodeCache key
	unlessM (elemInodeCaches cache oldcaches) $
		writeInodeCache key (cache:oldcaches)

{- Writes inode cache for a key. -}
writeInodeCache :: Key -> [InodeCache] -> Annex ()
writeInodeCache key caches = withInodeCacheFile key $ \f ->
	modifyContent f $
		liftIO $ writeFile f $
			unlines $ map showInodeCache caches

{- Removes an inode cache. -}
removeInodeCache :: Key -> Annex ()
removeInodeCache key = withInodeCacheFile key $ \f ->
	modifyContent f $
		liftIO $ nukeFile f

withInodeCacheFile :: Key -> (FilePath -> Annex a) -> Annex a
withInodeCacheFile key a = a =<< calcRepo (gitAnnexInodeCache key)

{- Checks if a InodeCache matches the current version of a file. -}
sameInodeCache :: FilePath -> [InodeCache] -> Annex Bool
sameInodeCache _ [] = return False
sameInodeCache file old = go =<< withTSDelta (liftIO . genInodeCache file)
  where
	go Nothing = return False
	go (Just curr) = elemInodeCaches curr old

{- Checks if a FileStatus matches the recorded InodeCache of a file. -}
sameFileStatus :: Key -> FileStatus -> Annex Bool
sameFileStatus key status = do
	old <- recordedInodeCache key
	curr <- withTSDelta $ \delta -> liftIO $ toInodeCache delta status
	case (old, curr) of
		(_, Just c) -> elemInodeCaches c old
		([], Nothing) -> return True
		_ -> return False

{- If the inodes have changed, only the size and mtime are compared. -}
compareInodeCaches :: InodeCache -> InodeCache -> Annex Bool
compareInodeCaches x y
	| compareStrong x y = return True
	| otherwise = ifM inodesChanged
		( return $ compareWeak x y
		, return False
		)

elemInodeCaches :: InodeCache -> [InodeCache] -> Annex Bool
elemInodeCaches _ [] = return False
elemInodeCaches c (l:ls) = ifM (compareInodeCaches c l)
	( return True
	, elemInodeCaches c ls
	)

compareInodeCachesWith :: Annex InodeComparisonType
compareInodeCachesWith = ifM inodesChanged ( return Weakly, return Strongly )

{- Copies the contentfile to the associated file, if the associated
 - file has no content. If the associated file does have content,
 - even if the content differs, it's left unchanged. -}
addContentWhenNotPresent :: Key -> FilePath -> FilePath -> Annex ()
addContentWhenNotPresent key contentfile associatedfile = do
	v <- isAnnexLink associatedfile
	when (Just key == v) $
		replaceFile associatedfile $
			liftIO . void . copyFileExternal contentfile
	updateInodeCache key associatedfile

{- Some filesystems get new inodes each time they are mounted.
 - In order to work on such a filesystem, a sentinal file is used to detect
 - when the inodes have changed.
 -
 - If the sentinal file does not exist, we have to assume that the
 - inodes have changed.
 -}
inodesChanged :: Annex Bool
inodesChanged = sentinalInodesChanged <$> sentinalStatus

withTSDelta :: (TSDelta -> Annex a) -> Annex a
withTSDelta a = a =<< getTSDelta

getTSDelta :: Annex TSDelta
#ifdef mingw32_HOST_OS
getTSDelta = sentinalTSDelta <$> sentinalStatus
#else
getTSDelta = pure noTSDelta -- optimisation
#endif

sentinalStatus :: Annex SentinalStatus
sentinalStatus = maybe check return =<< Annex.getState Annex.sentinalstatus
  where
	check = do
		sc <- liftIO . checkSentinalFile =<< annexSentinalFile
		Annex.changeState $ \s -> s { Annex.sentinalstatus = Just sc }
		return sc

{- The sentinal file is only created when first initializing a repository.
 - If there are any annexed objects in the repository already, creating
 - the file would invalidate their inode caches. -}
createInodeSentinalFile :: Annex ()
createInodeSentinalFile = unlessM (alreadyexists <||> hasobjects) $ do
	s <- annexSentinalFile
	createAnnexDirectory (parentDir (sentinalFile s))
	liftIO $ writeSentinalFile s
  where
	alreadyexists = liftIO. sentinalFileExists =<< annexSentinalFile
	hasobjects = liftIO . doesDirectoryExist =<< fromRepo gitAnnexObjectDir

annexSentinalFile :: Annex SentinalFile
annexSentinalFile = do
	sentinalfile <- fromRepo gitAnnexInodeSentinal
	sentinalcachefile <- fromRepo gitAnnexInodeSentinalCache
	return $ SentinalFile
		{ sentinalFile = sentinalfile
		, sentinalCacheFile = sentinalcachefile
		}


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

module Annex.Direct where

import Common.Annex
import qualified Annex
import qualified Git
import qualified Git.LsFiles
import qualified Git.Merge
import qualified Git.DiffTree as DiffTree
import qualified Git.Config
import qualified Git.Ref
import qualified Git.Branch
import Git.Sha
import Git.FilePath
import Git.Types
import Config
import Annex.CatFile
import qualified Annex.Queue
import Logs.Location
import Backend
import Types.KeySource
import Annex.Content
import Annex.Content.Direct
import Annex.Link
import Utility.InodeCache
import Utility.CopyFile
import Annex.Perms
import Annex.ReplaceFile
import Annex.Exception
import Annex.VariantFile
import Git.Index
import Annex.Index
import Annex.LockFile

{- Uses git ls-files to find files that need to be committed, and stages
 - them into the index. Returns True if some changes were staged. -}
stageDirect :: Annex Bool
stageDirect = do
	Annex.Queue.flush
	top <- fromRepo Git.repoPath
	(l, cleanup) <- inRepo $ Git.LsFiles.stagedOthersDetails [top]
	forM_ l go
	void $ liftIO cleanup
	staged <- Annex.Queue.size
	Annex.Queue.flush
	return $ staged /= 0
  where
	{- Determine what kind of modified or deleted file this is, as
	 - efficiently as we can, by getting any key that's associated
	 - with it in git, as well as its stat info. -}
	go (file, Just sha, Just mode) = withTSDelta $ \delta -> do
		shakey <- catKey sha mode
		mstat <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file
		mcache <- liftIO $ maybe (pure Nothing) (toInodeCache delta) mstat
		filekey <- isAnnexLink file
		case (shakey, filekey, mstat, mcache) of
			(_, Just key, _, _)
				| shakey == filekey -> noop
				{- A changed symlink. -}
				| otherwise -> stageannexlink file key
			(Just key, _, _, Just cache) -> do
				{- All direct mode files will show as
				 - modified, so compare the cache to see if
				 - it really was. -}
				oldcache <- recordedInodeCache key
				case oldcache of
					[] -> modifiedannexed file key cache
					_ -> unlessM (elemInodeCaches cache oldcache) $
						modifiedannexed file key cache
			(Just key, _, Nothing, _) -> deletedannexed file key
			(Nothing, _, Nothing, _) -> deletegit file
			(_, _, Just _, _) -> addgit file
	go _ = noop

	modifiedannexed file oldkey cache = do
		void $ removeAssociatedFile oldkey file
		void $ addDirect file cache

	deletedannexed file key = do
		void $ removeAssociatedFile key file
		deletegit file

	stageannexlink file key = do
		l <- inRepo $ gitAnnexLink file key
		stageSymlink file =<< hashSymlink l
		void $ addAssociatedFile key file

	addgit file = Annex.Queue.addCommand "add" [Param "-f"] [file]

	deletegit file = Annex.Queue.addCommand "rm" [Param "-qf"] [file]

{- Run before a commit to update direct mode bookeeping to reflect the
 - staged changes being committed. -}
preCommitDirect :: Annex Bool
preCommitDirect = do
	(diffs, clean) <- inRepo $ DiffTree.diffIndex Git.Ref.headRef
	makeabs <- flip fromTopFilePath <$> gitRepo
	forM_ diffs (go makeabs)
	liftIO clean
  where
	go makeabs diff = do
		withkey (DiffTree.srcsha diff) (DiffTree.srcmode diff) removeAssociatedFile
		withkey (DiffTree.dstsha diff) (DiffTree.dstmode diff) addAssociatedFile
	  where
		withkey sha mode a = when (sha /= nullSha) $ do
			k <- catKey sha mode
			case k of
				Nothing -> noop
				Just key -> void $ a key $
					makeabs $ DiffTree.file diff

{- Adds a file to the annex in direct mode. Can fail, if the file is
 - modified or deleted while it's being added. -}
addDirect :: FilePath -> InodeCache -> Annex Bool
addDirect file cache = do
	showStart "add" file
	let source = KeySource
		{ keyFilename = file
		, contentLocation = file
		, inodeCache = Just cache
		}
	got =<< genKey source =<< chooseBackend file
  where
	got Nothing = do
		showEndFail
		return False
	got (Just (key, _)) = ifM (sameInodeCache file [cache])
		( do
			l <- inRepo $ gitAnnexLink file key
			stageSymlink file =<< hashSymlink l
			addInodeCache key cache
			void $ addAssociatedFile key file
			logStatus key InfoPresent
			showEndOk
			return True
		, do
			showEndFail
			return False
		)

{- In direct mode, git merge would usually refuse to do anything, since it
 - sees present direct mode files as type changed files.
 -
 - So, to handle a merge, it's run with the work tree set to a temp
 - directory, and the merge is staged into a copy of the index.
 - Then the work tree is updated to reflect the merge, and
 - finally, the merge is committed and the real index updated.
 -
 - A lock file is used to avoid races with any other caller of mergeDirect.
 -
 - To avoid other git processes from making change to the index while our
 - merge is in progress, the index lock file is used as the temp index
 - file. This is the same as what git does when updating the index
 - normally.
 -}
mergeDirect :: Maybe Git.Ref -> Maybe Git.Ref -> Git.Branch -> Annex Bool -> Git.Branch.CommitMode -> Annex Bool
mergeDirect startbranch oldref branch resolvemerge commitmode = exclusively $ do
	reali <- fromRepo indexFile
	tmpi <- fromRepo indexFileLock
	liftIO $ copyFile reali tmpi

	d <- fromRepo gitAnnexMergeDir
	liftIO $ do
		whenM (doesDirectoryExist d) $
			removeDirectoryRecursive d
		createDirectoryIfMissing True d

	withIndexFile tmpi $ do
		merged <- stageMerge d branch commitmode
		r <- if merged
			then return True
			else resolvemerge
		mergeDirectCleanup d (fromMaybe Git.Sha.emptyTree oldref)
		mergeDirectCommit merged startbranch branch commitmode

		liftIO $ rename tmpi reali

		return r
  where
	exclusively = withExclusiveLock gitAnnexMergeLock

{- Stage a merge into the index, avoiding changing HEAD or the current
 - branch. -}
stageMerge :: FilePath -> Git.Branch -> Git.Branch.CommitMode -> Annex Bool
stageMerge d branch commitmode = do
	-- XXX A bug in git makes stageMerge unsafe to use if the git repo
	-- is configured with core.symlinks=false
	-- Using mergeNonInteractive is not ideal though, since it will
	-- update the current branch immediately, before the work tree
	-- has been updated, which would leave things in an inconsistent
	-- state if mergeDirectCleanup is interrupted.
	-- <http://marc.info/?l=git&m=140262402204212&w=2>
	merger <- ifM (coreSymlinks <$> Annex.getGitConfig)
		( return Git.Merge.stageMerge
		, return $ \ref -> Git.Merge.mergeNonInteractive ref commitmode
		)
	inRepo $ \g -> merger branch $
		g { location = Local { gitdir = Git.localGitDir g, worktree = Just d } }

{- Commits after a direct mode merge is complete, and after the work
 - tree has been updated by mergeDirectCleanup.
 -}
mergeDirectCommit :: Bool -> Maybe Git.Ref -> Git.Branch -> Git.Branch.CommitMode -> Annex ()
mergeDirectCommit allowff old branch commitmode = do
	void preCommitDirect
	d <- fromRepo Git.localGitDir
	let merge_head = d </> "MERGE_HEAD"
	let merge_msg = d </> "MERGE_MSG"
	let merge_mode = d </> "MERGE_MODE"
	ifM (pure allowff <&&> canff)
		( inRepo $ Git.Branch.update Git.Ref.headRef branch -- fast forward
		, do
			msg <- liftIO $
				catchDefaultIO ("merge " ++ fromRef branch) $
					readFile merge_msg
			void $ inRepo $ Git.Branch.commit commitmode False msg
				Git.Ref.headRef [Git.Ref.headRef, branch]
		)
	liftIO $ mapM_ nukeFile [merge_head, merge_msg, merge_mode]
  where
	canff = maybe (return False) (\o -> inRepo $ Git.Branch.fastForwardable o branch) old

{- Cleans up after a direct mode merge. The merge must have been staged
 - in the index. Uses diff-index to compare the staged changes with
 - the tree before the merge, and applies those changes to the work tree.
 -
 - There are really only two types of changes: An old item can be deleted,
 - or a new item added. Two passes are made, first deleting and then
 - adding. This is to handle cases where eg, a file is deleted and a
 - directory is added. (The diff-tree output may list these in the opposite
 - order, but we cannot add the directory until the file with the
 - same name is removed.)
 -}
mergeDirectCleanup :: FilePath -> Git.Ref -> Annex ()
mergeDirectCleanup d oldref = do
	(items, cleanup) <- inRepo $ DiffTree.diffIndex oldref
	makeabs <- flip fromTopFilePath <$> gitRepo
	let fsitems = zip (map (makeabs . DiffTree.file) items) items
	forM_ fsitems $
		go makeabs DiffTree.srcsha DiffTree.srcmode moveout moveout_raw
	forM_ fsitems $
		go makeabs DiffTree.dstsha DiffTree.dstmode movein movein_raw
	void $ liftIO cleanup
	liftIO $ removeDirectoryRecursive d
  where
	go makeabs getsha getmode a araw (f, item)
		| getsha item == nullSha = noop
		| otherwise = void $
			tryAnnex . maybe (araw item makeabs f) (\k -> void $ a item makeabs k f)
				=<< catKey (getsha item) (getmode item)

	moveout _ _ = removeDirect

	{- Files deleted by the merge are removed from the work tree.
	 - Empty work tree directories are removed, per git behavior. -}
	moveout_raw _ _ f = liftIO $ do
		nukeFile f
		void $ tryIO $ removeDirectory $ parentDir f

	{- If the file is already present, with the right content for the
	 - key, it's left alone.
	 -
	 - If the file is already present, and does not exist in the
	 - oldref, preserve this local file.
	 -
	 - Otherwise, create the symlink and then if possible, replace it
	 - with the content. -}
	movein item makeabs k f = unlessM (goodContent k f) $ do
		preserveUnannexed item makeabs f oldref
		l <- inRepo $ gitAnnexLink f k
		replaceFile f $ makeAnnexLink l
		toDirect k f

	{- Any new, modified, or renamed files were written to the temp
	 - directory by the merge, and are moved to the real work tree. -}
	movein_raw item makeabs f = do
		preserveUnannexed item makeabs f oldref
		liftIO $ do
			createDirectoryIfMissing True $ parentDir f
			void $ tryIO $ rename (d </> getTopFilePath (DiffTree.file item)) f

{- If the file that's being moved in is already present in the work
 - tree, but did not exist in the oldref, preserve this
 - local, unannexed file (or directory), as "variant-local".
 -
 - It's also possible that the file that's being moved in
 - is in a directory that collides with an exsting, non-annexed
 - file (not a directory), which should be preserved.
 -}
preserveUnannexed :: DiffTree.DiffTreeItem -> (TopFilePath -> FilePath) -> FilePath -> Ref -> Annex ()
preserveUnannexed item makeabs absf oldref = do
	whenM (liftIO (collidingitem absf) <&&> unannexed absf) $
		liftIO $ findnewname absf 0
	checkdirs (DiffTree.file item)
  where
	checkdirs from = do
		let p = parentDir (getTopFilePath from)
		let d = asTopFilePath p
		unless (null p) $ do
			let absd = makeabs d
			whenM (liftIO (colliding_nondir absd) <&&> unannexed absd) $
				liftIO $ findnewname absd 0
			checkdirs d

	collidingitem f = isJust
		<$> catchMaybeIO (getSymbolicLinkStatus f)
	colliding_nondir f = maybe False (not . isDirectory)
		<$> catchMaybeIO (getSymbolicLinkStatus f)

	unannexed f = (isNothing <$> isAnnexLink f)
		<&&> (isNothing <$> catFileDetails oldref f)

	findnewname :: FilePath -> Int -> IO ()
	findnewname f n = do
		let localf = mkVariant f
			("local" ++ if n > 0 then show n else "")
		ifM (collidingitem localf)
			( findnewname f (n+1)
			, rename f localf
				`catchIO` const (findnewname f (n+1))
			)

{- If possible, converts a symlink in the working tree into a direct
 - mode file. If the content is not available, leaves the symlink
 - unchanged. -}
toDirect :: Key -> FilePath -> Annex ()
toDirect k f = fromMaybe noop =<< toDirectGen k f

toDirectGen :: Key -> FilePath -> Annex (Maybe (Annex ()))
toDirectGen k f = do
	loc <- calcRepo $ gitAnnexLocation k
	ifM (liftIO $ doesFileExist loc)
		( return $ Just $ fromindirect loc
		, do
			{- Copy content from another direct file. -}
			absf <- liftIO $ absPath f
			dlocs <- filterM (goodContent k) =<<
				filterM (\l -> isNothing <$> getAnnexLinkTarget l) =<<
				(filter (/= absf) <$> addAssociatedFile k f)
			case dlocs of
				[] -> return Nothing
				(dloc:_) -> return $ Just $ fromdirect dloc
		)
  where
  	fromindirect loc = do
		{- Move content from annex to direct file. -}
		updateInodeCache k loc
		void $ addAssociatedFile k f
		modifyContent loc $ do
			thawContent loc
			replaceFileOr f
				(liftIO . moveFile loc)
				$ \tmp -> do -- rollback
					liftIO (moveFile tmp loc)
					freezeContent loc
	fromdirect loc = do
		replaceFile f $
			liftIO . void . copyFileExternal loc
		updateInodeCache k f

{- Removes a direct mode file, while retaining its content in the annex
 - (unless its content has already been changed). -}
removeDirect :: Key -> FilePath -> Annex ()
removeDirect k f = do
	void $ removeAssociatedFileUnchecked k f
	unlessM (inAnnex k) $
		ifM (goodContent k f)
			( moveAnnex k f
			, logStatus k InfoMissing
			)
	liftIO $ do
		nukeFile f
		void $ tryIO $ removeDirectory $ parentDir f

{- Called when a direct mode file has been changed. Its old content may be
 - lost. -}
changedDirect :: Key -> FilePath -> Annex ()
changedDirect oldk f = do
	locs <- removeAssociatedFile oldk f
	whenM (pure (null locs) <&&> not <$> inAnnex oldk) $
		logStatus oldk InfoMissing

{- Enable/disable direct mode. -}
setDirect :: Bool -> Annex ()
setDirect wantdirect = do
	if wantdirect
		then do
			switchHEAD
			setbare
		else do
			setbare
			switchHEADBack
	setConfig (annexConfig "direct") val
	Annex.changeGitConfig $ \c -> c { annexDirect = wantdirect }
  where
	val = Git.Config.boolConfig wantdirect
	setbare = setConfig (ConfigKey Git.Config.coreBare) val

{- Since direct mode sets core.bare=true, incoming pushes could change
 - the currently checked out branch. To avoid this problem, HEAD
 - is changed to a internal ref that nothing is going to push to.
 -
 - For refs/heads/master, use refs/heads/annex/direct/master;
 - this way things that show HEAD (eg shell prompts) will
 - hopefully show just "master". -}
directBranch :: Ref -> Ref
directBranch orighead = case split "/" $ fromRef orighead of
	("refs":"heads":"annex":"direct":_) -> orighead
	("refs":"heads":rest) ->
		Ref $ "refs/heads/annex/direct/" ++ intercalate "/" rest
	_ -> Ref $ "refs/heads/" ++ fromRef (Git.Ref.base orighead)

{- Converts a directBranch back to the original branch.
 -
 - Any other ref is left unchanged.
 -}
fromDirectBranch :: Ref -> Ref
fromDirectBranch directhead = case split "/" $ fromRef directhead of
	("refs":"heads":"annex":"direct":rest) ->
		Ref $ "refs/heads/" ++ intercalate "/" rest
	_ -> directhead

switchHEAD :: Annex ()
switchHEAD = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
  where
	switch orighead = do
		let newhead = directBranch orighead
		maybe noop (inRepo . Git.Branch.update newhead)
			=<< inRepo (Git.Ref.sha orighead)
		inRepo $ Git.Branch.checkout newhead

switchHEADBack :: Annex ()
switchHEADBack = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
  where
	switch currhead = do
		let orighead = fromDirectBranch currhead
		v <- inRepo $ Git.Ref.sha currhead
		case v of
			Just headsha
				| orighead /= currhead -> do
					inRepo $ Git.Branch.update orighead headsha
					inRepo $ Git.Branch.checkout orighead
					inRepo $ Git.Branch.delete currhead
			_ -> inRepo $ Git.Branch.checkout orighead


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

module Annex.Direct.Fixup where

import Git.Types
import Git.Config
import qualified Git.Construct as Construct
import Utility.Path
import Utility.SafeCommand

{- Direct mode repos have core.bare=true, but are not really bare.
 - Fix up the Repo to be a non-bare repo, and arrange for git commands
 - run by git-annex to be passed parameters that override this setting. -}
fixupDirect :: Repo -> IO Repo
fixupDirect r@(Repo { location = l@(Local { gitdir = d, worktree = Nothing }) }) = do
	let r' = r
		{ location = l { worktree = Just (parentDir d) }
		, gitGlobalOpts = gitGlobalOpts r ++
			[ Param "-c"
			, Param $ coreBare ++ "=" ++ boolConfig False
			]
		}
	-- Recalc now that the worktree is correct.
	rs' <- Construct.fromRemotes r'
	return $ r' { remotes = rs' }
fixupDirect r = return r


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

module Annex.Drop where

import Common.Annex
import Logs.Trust
import Config.NumCopies
import Types.Remote (uuid)
import Types.Key (key2file)
import qualified Remote
import qualified Command.Drop
import Command
import Annex.Wanted
import Annex.Exception
import Config
import Annex.Content.Direct

import qualified Data.Set as S
import System.Log.Logger (debugM)

type Reason = String

{- Drop a key from local and/or remote when allowed by the preferred content
 - and numcopies settings.
 -
 - The UUIDs are ones where the content is believed to be present.
 - The Remote list can include other remotes that do not have the content;
 - only ones that match the UUIDs will be dropped from.
 - If allowed to drop fromhere, that drop will be tried first.
 -
 - A remote can be specified that is known to have the key. This can be
 - used an an optimisation when eg, a key has just been uploaded to a
 - remote.
 -
 - In direct mode, all associated files are checked, and only if all
 - of them are unwanted are they dropped.
 -
 - The runner is used to run commands, and so can be either callCommand
 - or commandAction.
 -}
handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> CommandActionRunner -> Annex ()
handleDropsFrom locs rs reason fromhere key afile knownpresentremote runner = do
	fs <- ifM isDirect
		( do
			l <- associatedFilesRelative key
			return $ if null l
				then maybeToList afile
				else l
		, return $ maybeToList afile
		)
	n <- getcopies fs
	if fromhere && checkcopies n Nothing
		then go fs rs =<< dropl fs n
		else go fs rs n
  where
	getcopies fs = do
		(untrusted, have) <- trustPartition UnTrusted locs
		numcopies <- if null fs
			then getNumCopies
			else maximum <$> mapM getFileNumCopies fs
		return (NumCopies (length have), numcopies, S.fromList untrusted)

	{- Check that we have enough copies still to drop the content.
	 - When the remote being dropped from is untrusted, it was not
	 - counted as a copy, so having only numcopies suffices. Otherwise,
	 - we need more than numcopies to safely drop. -}
	checkcopies (have, numcopies, _untrusted) Nothing = have > numcopies
	checkcopies (have, numcopies, untrusted) (Just u)
		| S.member u untrusted = have >= numcopies
		| otherwise = have > numcopies

	decrcopies (have, numcopies, untrusted) Nothing =
		(NumCopies (fromNumCopies have - 1), numcopies, untrusted)
	decrcopies v@(_have, _numcopies, untrusted) (Just u)
		| S.member u untrusted = v
		| otherwise = decrcopies v Nothing

	go _ [] _ = noop
	go fs (r:rest) n
		| uuid r `S.notMember` slocs = go fs rest n
		| checkcopies n (Just $ Remote.uuid r) =
			dropr fs r n >>= go fs rest
		| otherwise = noop

	checkdrop fs n u a
		| null fs = check $ -- no associated files; unused content
			wantDrop True u (Just key) Nothing
		| otherwise = check $
			allM (wantDrop True u (Just key) . Just) fs
		where
			check c = ifM c
				( dodrop n u a
				, return n
				)

	dodrop n@(have, numcopies, _untrusted) u a =
		ifM (safely $ runner $ a numcopies)
			( do
				liftIO $ debugM "drop" $ unwords
					[ "dropped"
					, fromMaybe (key2file key) afile
					, "(from " ++ maybe "here" show u ++ ")"
					, "(copies now " ++ show (fromNumCopies have - 1) ++ ")"
					, ": " ++ reason
					]
				return $ decrcopies n u
			, return n
			)

	dropl fs n = checkdrop fs n Nothing $ \numcopies ->
		Command.Drop.startLocal afile numcopies key knownpresentremote

	dropr fs r n  = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies ->
		Command.Drop.startRemote afile numcopies key r

	slocs = S.fromList locs

	safely a = either (const False) id <$> tryAnnex a


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

{-# LANGUAGE CPP #-}

module Annex.Environment where

import Common.Annex
import Utility.UserInfo
import qualified Git.Config
import Config
import Annex.Exception

#ifndef mingw32_HOST_OS
import Utility.Env
#endif

{- Checks that the system's environment allows git to function.
 - Git requires a GECOS username, or suitable git configuration, or
 - environment variables.
 -
 - Git also requires the system have a hostname containing a dot.
 - Otherwise, it tries various methods to find a FQDN, and will fail if it
 - does not. To avoid replicating that code here, which would break if its
 - methods change, this function does not check the hostname is valid.
 - Instead, code that commits can use ensureCommit.
 -}
checkEnvironment :: Annex ()
checkEnvironment = do
	gitusername <- fromRepo $ Git.Config.getMaybe "user.name"
	when (isNothing gitusername || gitusername == Just "") $
		liftIO checkEnvironmentIO

checkEnvironmentIO :: IO ()
checkEnvironmentIO =
#ifdef mingw32_HOST_OS
	noop
#else
	whenM (null <$> myUserGecos) $ do
		username <- myUserName
		ensureEnv "GIT_AUTHOR_NAME" username
		ensureEnv "GIT_COMMITTER_NAME" username
  where
#ifndef __ANDROID__
  	-- existing environment is not overwritten
	ensureEnv var val = void $ setEnv var val False
#else
	-- Environment setting is broken on Android, so this is dealt with
	-- in runshell instead.
	ensureEnv _ _ = noop
#endif
#endif

{- Runs an action that commits to the repository, and if it fails,
 - sets user.email and user.name to a dummy value and tries the action again. -}
ensureCommit :: Annex a -> Annex a
ensureCommit a = either retry return =<< tryAnnex a
  where
  	retry _ = do
		name <- liftIO myUserName
		setConfig (ConfigKey "user.name") name
		setConfig (ConfigKey "user.email") name
		a


code:
{- exception handling in the git-annex monad
 -
 - Note that when an Annex action fails and the exception is handled
 - by these functions, any changes the action has made to the
 - AnnexState are retained. This works because the Annex monad
 - internally stores the AnnexState in a MVar.
 -
 - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Annex.Exception (
	bracketIO,
	bracketAnnex,
	tryAnnex,
	tryAnnexIO,
	throwAnnex,
	catchAnnex,
	catchNonAsyncAnnex,
	tryNonAsyncAnnex,
) where

import qualified Control.Monad.Catch as M
import Control.Exception

import Common.Annex

{- Runs an Annex action, with setup and cleanup both in the IO monad. -}
bracketIO :: IO v -> (v -> IO b) -> (v -> Annex a) -> Annex a
bracketIO setup cleanup = M.bracket (liftIO setup) (liftIO . cleanup)

bracketAnnex :: Annex v -> (v -> Annex b) -> (v -> Annex a) -> Annex a
bracketAnnex = M.bracket

{- try in the Annex monad -}
tryAnnex :: Annex a -> Annex (Either SomeException a)
tryAnnex = M.try

{- try in the Annex monad, but only catching IO exceptions -}
tryAnnexIO :: Annex a -> Annex (Either IOException a)
tryAnnexIO = M.try

{- throw in the Annex monad -}
throwAnnex :: Exception e => e -> Annex a
throwAnnex = M.throwM

{- catch in the Annex monad -}
catchAnnex :: Exception e => Annex a -> (e -> Annex a) -> Annex a
catchAnnex = M.catch

{- catchs all exceptions except for async exceptions -}
catchNonAsyncAnnex :: Annex a -> (SomeException -> Annex a) -> Annex a
catchNonAsyncAnnex a onerr = a `M.catches`
	[ M.Handler (\ (e :: AsyncException) -> throwAnnex e)
	, M.Handler (\ (e :: SomeException) -> onerr e)
	]

tryNonAsyncAnnex :: Annex a -> Annex (Either SomeException a)
tryNonAsyncAnnex a = (Right <$> a) `catchNonAsyncAnnex` (return . Left)


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

module Annex.FileMatcher where

import qualified Data.Map as M

import Common.Annex
import Limit
import Utility.Matcher
import Types.Group
import Logs.Group
import Logs.Remote
import Annex.UUID
import qualified Annex
import Types.FileMatcher
import Git.FilePath
import Types.Remote (RemoteConfig)

import Data.Either
import qualified Data.Set as S

checkFileMatcher :: (FileMatcher Annex) -> FilePath -> Annex Bool
checkFileMatcher matcher file = checkMatcher matcher Nothing (Just file) S.empty True

checkMatcher :: (FileMatcher Annex) -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Bool -> Annex Bool
checkMatcher matcher mkey afile notpresent def
	| isEmpty matcher = return def
	| otherwise = case (mkey, afile) of
		(_, Just file) -> go =<< fileMatchInfo file
		(Just key, _) -> go (MatchingKey key)
		_ -> return def
  where
	go mi = matchMrun matcher $ \a -> a notpresent mi

fileMatchInfo :: FilePath -> Annex MatchInfo
fileMatchInfo file = do
	matchfile <- getTopFilePath <$> inRepo (toTopFilePath file)
	return $ MatchingFile FileInfo
		{ matchFile = matchfile
		, relFile = file
		}

matchAll :: FileMatcher Annex
matchAll = generate []

parsedToMatcher :: [Either String (Token (MatchFiles Annex))] -> Either String (FileMatcher Annex)
parsedToMatcher parsed = case partitionEithers parsed of
	([], vs) -> Right $ generate vs
	(es, _) -> Left $ unwords $ map ("Parse failure: " ++) es

exprParser :: FileMatcher Annex -> FileMatcher Annex -> GroupMap -> M.Map UUID RemoteConfig -> Maybe UUID -> String -> [Either String (Token (MatchFiles Annex))]
exprParser matchstandard matchgroupwanted groupmap configmap mu expr =
	map parse $ tokenizeMatcher expr
  where
	parse = parseToken
		matchstandard
		matchgroupwanted
		(limitPresent mu)
		(limitInDir preferreddir)
		groupmap
	preferreddir = fromMaybe "public" $
		M.lookup "preferreddir" =<< (`M.lookup` configmap) =<< mu

parseToken :: FileMatcher Annex -> FileMatcher Annex -> MkLimit Annex -> MkLimit Annex -> GroupMap -> String -> Either String (Token (MatchFiles Annex))
parseToken matchstandard matchgroupwanted checkpresent checkpreferreddir groupmap t
	| t `elem` tokens = Right $ token t
	| t == "standard" = call matchstandard
	| t == "groupwanted" = call matchgroupwanted
	| t == "present" = use checkpresent
	| t == "inpreferreddir" = use checkpreferreddir
	| t == "unused" = Right $ Operation limitUnused
	| otherwise = maybe (Left $ "near " ++ show t) use $ M.lookup k $
		M.fromList
			[ ("include", limitInclude)
			, ("exclude", limitExclude)
			, ("copies", limitCopies)
			, ("lackingcopies", limitLackingCopies False)
			, ("approxlackingcopies", limitLackingCopies True)
			, ("inbackend", limitInBackend)
			, ("largerthan", limitSize (>))
			, ("smallerthan", limitSize (<))
			, ("metadata", limitMetaData)
			, ("inallgroup", limitInAllGroup groupmap)
			]
  where
	(k, v) = separate (== '=') t
	use a = Operation <$> a v
	call sub = Right $ Operation $ \notpresent mi ->
		matchMrun sub $ \a -> a notpresent mi

{- This is really dumb tokenization; there's no support for quoted values.
 - Open and close parens are always treated as standalone tokens;
 - otherwise tokens must be separated by whitespace. -}
tokenizeMatcher :: String -> [String]
tokenizeMatcher = filter (not . null ) . concatMap splitparens . words
  where
	splitparens = segmentDelim (`elem` "()")

{- Generates a matcher for files large enough (or meeting other criteria)
 - to be added to the annex, rather than directly to git. -}
largeFilesMatcher :: Annex (FileMatcher Annex)
largeFilesMatcher = go =<< annexLargeFiles <$> Annex.getGitConfig
  where
  	go Nothing = return matchAll
	go (Just expr) = do
		gm <- groupMap
		rc <- readRemoteLog
		u <- getUUID
		either badexpr return $
			parsedToMatcher $ exprParser matchAll matchAll gm rc (Just u) expr
	badexpr e = error $ "bad annex.largefiles configuration: " ++ e


code:
{- git-annex git hooks
 -
 - Note that it's important that the scripts installed by git-annex
 - not change, otherwise removing old hooks using an old version of
 - the script would fail.
 -
 - Copyright 2013-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Annex.Hook where

import Common.Annex
import qualified Git.Hook as Git
import Config
import qualified Annex
import Utility.Shell
import Utility.FileMode

import qualified Data.Map as M

preCommitHook :: Git.Hook
preCommitHook = Git.Hook "pre-commit" (mkHookScript "git annex pre-commit .")

preCommitAnnexHook :: Git.Hook
preCommitAnnexHook = Git.Hook "pre-commit-annex" ""

mkHookScript :: String -> String
mkHookScript s = unlines
	[ shebang_local
	, "# automatically configured by git-annex"
	, s
	]

hookWrite :: Git.Hook -> Annex ()
hookWrite h =
	-- cannot have git hooks in a crippled filesystem (no execute bit)
	unlessM crippledFileSystem $
		unlessM (inRepo $ Git.hookWrite h) $
			hookWarning h "already exists, not configuring"

hookUnWrite :: Git.Hook -> Annex ()
hookUnWrite h = unlessM (inRepo $ Git.hookUnWrite h) $
	hookWarning h "contents modified; not deleting. Edit it to remove call to git annex."

hookWarning :: Git.Hook -> String -> Annex ()
hookWarning h msg = do
	r <- gitRepo
	warning $ Git.hookName h ++ " hook (" ++ Git.hookFile h r ++ ") " ++ msg

{- Runs a hook. To avoid checking if the hook exists every time,
 - the existing hooks are cached. -}
runAnnexHook :: Git.Hook -> Annex ()
runAnnexHook hook = do
	cmd <- fromRepo $ Git.hookFile hook
	m <- Annex.getState Annex.existinghooks
	case M.lookup hook m of
		Just True -> run cmd
		Just False -> noop
		Nothing -> do
			exists <- hookexists cmd
			Annex.changeState $ \s -> s
				{ Annex.existinghooks = M.insert hook exists m }
			when exists $
				run cmd
  where
	hookexists f = liftIO $ catchBoolIO $
		isExecutable . fileMode <$> getFileStatus f
	run cmd = unlessM (liftIO $ boolSystem cmd []) $
		warning $ cmd ++ " failed"


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

{-# LANGUAGE CPP #-}

module Annex.Index (
	withIndexFile,
	addGitEnv,
) where

import qualified Control.Exception as E

import Common.Annex
import Git.Types
import qualified Annex
import Utility.Env
import Annex.Exception

{- Runs an action using a different git index file. -}
withIndexFile :: FilePath -> Annex a -> Annex a
withIndexFile f a = do
	g <- gitRepo
	g' <- liftIO $ addGitEnv g "GIT_INDEX_FILE" f

	r <- tryAnnex $ do
		Annex.changeState $ \s -> s { Annex.repo = g' }
		a
	Annex.changeState $ \s -> s { Annex.repo = (Annex.repo s) { gitEnv = gitEnv g} }
	either E.throw return r

addGitEnv :: Repo -> String -> String -> IO Repo
addGitEnv g var val = do
	e <- maybe copyenv return (gitEnv g)
	let e' = addEntry var val e
	return $ g { gitEnv = Just e' }
  where
	copyenv = do
#ifdef __ANDROID__
		{- This should not be necessary on Android, but there is some
		 - weird getEnvironment breakage. See
		 - https://github.com/neurocyte/ghc-android/issues/7
		 - Use getEnv to get some key environment variables that
		 - git expects to have. -}
		let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME"
		let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k
		liftIO $ catMaybes <$> forM keyenv getEnvPair
#else
		liftIO getEnvironment
#endif


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

{-# LANGUAGE CPP #-}

module Annex.Init (
	ensureInitialized,
	isInitialized,
	initialize,
	initialize',
	uninitialize,
	probeCrippledFileSystem,
) where

import Common.Annex
import qualified Annex
import qualified Git
import qualified Git.LsFiles
import qualified Git.Config
import qualified Git.Construct
import qualified Git.Types as Git
import qualified Annex.Branch
import Logs.UUID
import Annex.Version
import Annex.UUID
import Config
import Annex.Direct
import Annex.Content.Direct
import Annex.Environment
import Annex.Perms
import Backend
#ifndef mingw32_HOST_OS
import Utility.UserInfo
import Utility.FileMode
#endif
import Annex.Hook
import Git.Hook (hookFile)
import Upgrade
import Annex.Content
import Logs.Location

import System.Log.Logger

genDescription :: Maybe String -> Annex String
genDescription (Just d) = return d
genDescription Nothing = do
	reldir <- liftIO . relHome =<< fromRepo Git.repoPath
	hostname <- fromMaybe "" <$> liftIO getHostname
#ifndef mingw32_HOST_OS
	let at = if null hostname then "" else "@"
	username <- liftIO myUserName
	return $ concat [username, at, hostname, ":", reldir]
#else
	return $ concat [hostname, ":", reldir]
#endif

initialize :: Maybe String -> Annex ()
initialize mdescription = do
	prepUUID
	initialize'

	u <- getUUID
	{- This will make the first commit to git, so ensure git is set up
	 - properly to allow commits when running it. -}
	ensureCommit $ do
		Annex.Branch.create
		describeUUID u =<< genDescription mdescription

initialize' :: Annex ()
initialize' = do
	checkFifoSupport
	checkCrippledFileSystem
	unlessM isBare $
		hookWrite preCommitHook
	setVersion supportedVersion
	ifM (crippledFileSystem <&&> not <$> isBare)
		( do
			enableDirectMode
			setDirect True
		-- Handle case where this repo was cloned from a
		-- direct mode repo
		, unlessM isBare
			switchHEADBack
		)
	createInodeSentinalFile

uninitialize :: Annex ()
uninitialize = do
	hookUnWrite preCommitHook
	removeRepoUUID
	removeVersion

{- Will automatically initialize if there is already a git-annex
 - branch from somewhere. Otherwise, require a manual init
 - to avoid git-annex accidentially being run in git
 - repos that did not intend to use it.
 -
 - Checks repository version and handles upgrades too.
 -}
ensureInitialized :: Annex ()
ensureInitialized = do
	getVersion >>= maybe needsinit checkUpgrade
	fixBadBare
  where
	needsinit = ifM Annex.Branch.hasSibling
			( initialize Nothing
			, error "First run: git-annex init"
			)

{- Checks if a repository is initialized. Does not check version for ugrade. -}
isInitialized :: Annex Bool
isInitialized = maybe Annex.Branch.hasSibling (const $ return True) =<< getVersion

isBare :: Annex Bool
isBare = fromRepo Git.repoIsLocalBare

{- A crippled filesystem is one that does not allow making symlinks,
 - or removing write access from files. -}
probeCrippledFileSystem :: Annex Bool
probeCrippledFileSystem = do
#ifdef mingw32_HOST_OS
	return True
#else
	tmp <- fromRepo gitAnnexTmpMiscDir
	let f = tmp </> "gaprobe"
	createAnnexDirectory tmp
	liftIO $ writeFile f ""
	uncrippled <- liftIO $ probe f
	liftIO $ removeFile f
	return $ not uncrippled
  where
	probe f = catchBoolIO $ do
		let f2 = f ++ "2"
		nukeFile f2
		createSymbolicLink f f2
		nukeFile f2
		preventWrite f
		allowWrite f
		return True
#endif

checkCrippledFileSystem :: Annex ()
checkCrippledFileSystem = whenM probeCrippledFileSystem $ do
	warning "Detected a crippled filesystem."
	setCrippledFileSystem True

	{- Normally git disables core.symlinks itself when the
	 - filesystem does not support them, but in Cygwin, git
	 - does support symlinks, while git-annex, not linking
	 - with Cygwin, does not. -}
	whenM (coreSymlinks <$> Annex.getGitConfig) $ do
		warning "Disabling core.symlinks."
		setConfig (ConfigKey "core.symlinks")
			(Git.Config.boolConfig False)

probeFifoSupport :: Annex Bool
probeFifoSupport = do
#ifdef mingw32_HOST_OS
	return False
#else
	tmp <- fromRepo gitAnnexTmpMiscDir
	let f = tmp </> "gaprobe"
	createAnnexDirectory tmp
	liftIO $ do
		nukeFile f
		ms <- tryIO $ do
			createNamedPipe f ownerReadMode
			getFileStatus f
		nukeFile f
		return $ either (const False) isNamedPipe ms
#endif

checkFifoSupport :: Annex ()
checkFifoSupport = unlessM probeFifoSupport $ do
	warning "Detected a filesystem without fifo support."
	warning "Disabling ssh connection caching."
	setConfig (annexConfig "sshcaching") (Git.Config.boolConfig False)

enableDirectMode :: Annex ()
enableDirectMode = unlessM isDirect $ do
	warning "Enabling direct mode."
	top <- fromRepo Git.repoPath
	(l, clean) <- inRepo $ Git.LsFiles.inRepo [top]
	forM_ l $ \f ->
		maybe noop (`toDirect` f) =<< isAnnexLink f
	void $ liftIO clean

{- Work around for git-annex version 5.20131118 - 5.20131127, which
 - had a bug that unset core.bare when initializing a bare repository.
 -
 - This resulted in objects sent to the repository being stored in
 - repo/.git/annex/objects, so move them to repo/annex/objects.
 -
 - This check slows down every git-annex run somewhat (by one file stat),
 - so should be removed after a suitable period of time has passed.
 - Since the bare repository may be on an offline USB drive, best to
 - keep it for a while. However, git-annex was only buggy for a few
 - weeks, so not too long.
 -}
fixBadBare :: Annex ()
fixBadBare = whenM checkBadBare $ do
	ks <- getKeysPresent InAnnex
	liftIO $ debugM "Init" $ unwords
		[ "Detected bad bare repository with"
		, show (length ks)
		, "objects; fixing"
		]
	g <- Annex.gitRepo
	gc <- Annex.getGitConfig
	d <- Git.repoPath <$> Annex.gitRepo
	void $ liftIO $ boolSystem "git"
		[ Param $ "--git-dir=" ++ d
		, Param "config"
		, Param Git.Config.coreBare
		, Param $ Git.Config.boolConfig True
		]
	g' <- liftIO $ Git.Construct.fromPath d
	s' <- liftIO $ Annex.new $ g' { Git.location = Git.Local { Git.gitdir = d, Git.worktree = Nothing } }
	Annex.changeState $ \s -> s
		{ Annex.repo = Annex.repo s'
		, Annex.gitconfig = Annex.gitconfig s'
		}
	forM_ ks $ \k -> do
		oldloc <- liftIO $ gitAnnexLocation k g gc
		thawContentDir oldloc
		moveAnnex k oldloc
		logStatus k InfoPresent
	let dotgit = d </> ".git"
	liftIO $ removeDirectoryRecursive dotgit
		`catchIO` const (renameDirectory dotgit (d </> "removeme"))

{- A repostory with the problem won't know it's a bare repository, but will
 - have no pre-commit hook (which is not set up in a bare repository),
 - and will not have a HEAD file in its .git directory. -}
checkBadBare :: Annex Bool
checkBadBare = allM (not <$>)
	[isBare, hasPreCommitHook, hasDotGitHEAD]
  where
	hasPreCommitHook = inRepo $ doesFileExist . hookFile preCommitHook
	hasDotGitHEAD = inRepo $ \r -> doesFileExist $ Git.localGitDir r </> "HEAD"