convert TopFilePath to use RawFilePath
Adds a dependency on filepath-bytestring, an as yet unreleased fork of filepath that operates on RawFilePath. Git.Repo also changed to use RawFilePath for the path to the repo. This does eliminate some RawFilePath -> FilePath -> RawFilePath conversions. And filepath-bytestring's </> is probably faster. But I don't expect a major performance improvement from this. This is mostly groundwork for making Annex.Location use RawFilePath, which will allow for a conversion-free pipleline.
This commit is contained in:
		
					parent
					
						
							
								a7004375ec
							
						
					
				
			
			
				commit
				
					
						bdec7fed9c
					
				
			
		
					 97 changed files with 323 additions and 271 deletions
				
			
		| 
						 | 
				
			
			@ -113,7 +113,7 @@ adjustToSymlink' :: (FilePath -> Key -> Git.Repo -> GitConfig -> IO FilePath) ->
 | 
			
		|||
adjustToSymlink' gitannexlink ti@(TreeItem f _m s) = catKey s >>= \case
 | 
			
		||||
	Just k -> do
 | 
			
		||||
		absf <- inRepo $ \r -> absPath $ 
 | 
			
		||||
			fromTopFilePath f r
 | 
			
		||||
			fromRawFilePath $ fromTopFilePath f r
 | 
			
		||||
		linktarget <- calcRepo $ gitannexlink absf k
 | 
			
		||||
		Just . TreeItem f (fromTreeItemType TreeSymlink)
 | 
			
		||||
			<$> hashSymlink linktarget
 | 
			
		||||
| 
						 | 
				
			
			@ -376,7 +376,7 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm
 | 
			
		|||
	 -}
 | 
			
		||||
	changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do
 | 
			
		||||
		tmpwt <- fromRepo gitAnnexMergeDir
 | 
			
		||||
		git_dir <- fromRepo Git.localGitDir
 | 
			
		||||
		git_dir <- fromRawFilePath <$> fromRepo Git.localGitDir
 | 
			
		||||
		withTmpDirIn othertmpdir "git" $ \tmpgit -> withWorkTreeRelated tmpgit $
 | 
			
		||||
			withemptydir tmpwt $ withWorkTree tmpwt $ do
 | 
			
		||||
				liftIO $ writeFile (tmpgit </> "HEAD") (fromRef updatedorig)
 | 
			
		||||
| 
						 | 
				
			
			@ -580,7 +580,7 @@ reverseAdjustedTree basis adj csha = do
 | 
			
		|||
	  where
 | 
			
		||||
		m = M.fromList $ map (\i@(TreeItem f' _ _) -> (norm f', i)) $
 | 
			
		||||
			map diffTreeToTreeItem changes
 | 
			
		||||
		norm = normalise . getTopFilePath
 | 
			
		||||
		norm = normalise . fromRawFilePath . getTopFilePath
 | 
			
		||||
 | 
			
		||||
diffTreeToTreeItem :: Git.DiffTree.DiffTreeItem -> TreeItem
 | 
			
		||||
diffTreeToTreeItem dti = TreeItem
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -5,6 +5,8 @@
 | 
			
		|||
 - Licensed under the GNU AGPL version 3 or higher.
 | 
			
		||||
 -}
 | 
			
		||||
 | 
			
		||||
{-# LANGUAGE OverloadedStrings #-}
 | 
			
		||||
 | 
			
		||||
module Annex.AutoMerge
 | 
			
		||||
	( autoMergeFrom
 | 
			
		||||
	, resolveMerge
 | 
			
		||||
| 
						 | 
				
			
			@ -104,7 +106,7 @@ autoMergeFrom branch currbranch mergeconfig canresolvemerge commitmode = do
 | 
			
		|||
 -}
 | 
			
		||||
resolveMerge :: Maybe Git.Ref -> Git.Ref -> Bool -> Annex Bool
 | 
			
		||||
resolveMerge us them inoverlay = do
 | 
			
		||||
	top <- toRawFilePath <$> if inoverlay
 | 
			
		||||
	top <- if inoverlay
 | 
			
		||||
		then pure "."
 | 
			
		||||
		else fromRepo Git.repoPath
 | 
			
		||||
	(fs, cleanup) <- inRepo (LsFiles.unmerged [top])
 | 
			
		||||
| 
						 | 
				
			
			@ -196,7 +198,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
 | 
			
		|||
 | 
			
		||||
	stagefile :: FilePath -> Annex FilePath
 | 
			
		||||
	stagefile f
 | 
			
		||||
		| inoverlay = (</> f) <$> fromRepo Git.repoPath
 | 
			
		||||
		| inoverlay = (</> f) . fromRawFilePath <$> fromRepo Git.repoPath
 | 
			
		||||
		| otherwise = pure f
 | 
			
		||||
 | 
			
		||||
	makesymlink key dest = do
 | 
			
		||||
| 
						 | 
				
			
			@ -219,7 +221,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
 | 
			
		|||
		stagePointerFile dest' destmode =<< hashPointerFile key
 | 
			
		||||
		unless inoverlay $
 | 
			
		||||
			Database.Keys.addAssociatedFile key
 | 
			
		||||
				=<< inRepo (toTopFilePath dest)
 | 
			
		||||
				=<< inRepo (toTopFilePath (toRawFilePath dest))
 | 
			
		||||
 | 
			
		||||
	withworktree f a = a f
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -482,7 +482,7 @@ stageJournal jl commitindex = withIndex $ withOtherTmp $ \tmpdir -> do
 | 
			
		|||
				sha <- Git.HashObject.hashFile h path
 | 
			
		||||
				hPutStrLn jlogh file
 | 
			
		||||
				streamer $ Git.UpdateIndex.updateIndexLine
 | 
			
		||||
					sha TreeFile (asTopFilePath $ fileJournal file)
 | 
			
		||||
					sha TreeFile (asTopFilePath $ toRawFilePath $ 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
 | 
			
		||||
| 
						 | 
				
			
			@ -600,7 +600,7 @@ performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do
 | 
			
		|||
				else do
 | 
			
		||||
					sha <- hashBlob content'
 | 
			
		||||
					Annex.Queue.addUpdateIndex $ Git.UpdateIndex.pureStreamer $
 | 
			
		||||
						Git.UpdateIndex.updateIndexLine sha TreeFile (asTopFilePath (fromRawFilePath file))
 | 
			
		||||
						Git.UpdateIndex.updateIndexLine sha TreeFile (asTopFilePath file)
 | 
			
		||||
					apply rest file content'
 | 
			
		||||
 | 
			
		||||
checkBranchDifferences :: Git.Ref -> Annex ()
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -76,7 +76,7 @@ watchChangedRefs = do
 | 
			
		|||
	chan <- liftIO $ newTBMChanIO 100
 | 
			
		||||
	
 | 
			
		||||
	g <- gitRepo
 | 
			
		||||
	let refdir = Git.localGitDir g </> "refs"
 | 
			
		||||
	let refdir = fromRawFilePath (Git.localGitDir g) </> "refs"
 | 
			
		||||
	liftIO $ createDirectoryIfMissing True refdir
 | 
			
		||||
 | 
			
		||||
	let notifyhook = Just $ notifyHook chan
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -483,7 +483,7 @@ moveAnnex key src = ifM (checkSecureHashes key)
 | 
			
		|||
			fs <- map (`fromTopFilePath` g)
 | 
			
		||||
				<$> Database.Keys.getAssociatedFiles key
 | 
			
		||||
			unless (null fs) $ do
 | 
			
		||||
				ics <- mapM (populatePointerFile (Restage True) key (toRawFilePath dest) . toRawFilePath) fs
 | 
			
		||||
				ics <- mapM (populatePointerFile (Restage True) key (toRawFilePath dest)) fs
 | 
			
		||||
				Database.Keys.storeInodeCaches' key [dest] (catMaybes ics)
 | 
			
		||||
		)
 | 
			
		||||
	alreadyhave = liftIO $ removeFile src
 | 
			
		||||
| 
						 | 
				
			
			@ -643,7 +643,7 @@ removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file ->
 | 
			
		|||
		secureErase file
 | 
			
		||||
		liftIO $ nukeFile file
 | 
			
		||||
		g <- Annex.gitRepo 
 | 
			
		||||
		mapM_ (\f -> void $ tryIO $ resetpointer $ fromTopFilePath f g)
 | 
			
		||||
		mapM_ (\f -> void $ tryIO $ resetpointer $ fromRawFilePath $ fromTopFilePath f g)
 | 
			
		||||
			=<< Database.Keys.getAssociatedFiles key
 | 
			
		||||
		Database.Keys.removeInodeCaches key
 | 
			
		||||
  where
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -49,7 +49,7 @@ type Reason = String
 | 
			
		|||
handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> [VerifiedCopy] -> (CommandStart -> CommandCleanup) -> Annex ()
 | 
			
		||||
handleDropsFrom locs rs reason fromhere key afile preverified runner = do
 | 
			
		||||
	g <- Annex.gitRepo
 | 
			
		||||
	l <- map toRawFilePath . map (`fromTopFilePath` g)
 | 
			
		||||
	l <- map (`fromTopFilePath` g)
 | 
			
		||||
		<$> Database.Keys.getAssociatedFiles key
 | 
			
		||||
	let fs = case afile of
 | 
			
		||||
		AssociatedFile (Just f) -> nub (f : l)
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -62,7 +62,7 @@ checkMatcher :: FileMatcher Annex -> Maybe Key -> AssociatedFile -> AssumeNotPre
 | 
			
		|||
checkMatcher matcher mkey afile notpresent notconfigured d
 | 
			
		||||
	| isEmpty matcher = notconfigured
 | 
			
		||||
	| otherwise = case (mkey, afile) of
 | 
			
		||||
		(_, AssociatedFile (Just file)) -> go =<< fileMatchInfo (fromRawFilePath file)
 | 
			
		||||
		(_, AssociatedFile (Just file)) -> go =<< fileMatchInfo file
 | 
			
		||||
		(Just key, _) -> go (MatchingKey key afile)
 | 
			
		||||
		_ -> d
 | 
			
		||||
  where
 | 
			
		||||
| 
						 | 
				
			
			@ -72,7 +72,7 @@ checkMatcher' :: FileMatcher Annex -> MatchInfo -> AssumeNotPresent -> Annex Boo
 | 
			
		|||
checkMatcher' matcher mi notpresent =
 | 
			
		||||
	matchMrun matcher $ \a -> a notpresent mi
 | 
			
		||||
 | 
			
		||||
fileMatchInfo :: FilePath -> Annex MatchInfo
 | 
			
		||||
fileMatchInfo :: RawFilePath -> Annex MatchInfo
 | 
			
		||||
fileMatchInfo file = do
 | 
			
		||||
	matchfile <- getTopFilePath <$> inRepo (toTopFilePath file)
 | 
			
		||||
	return $ MatchingFile FileInfo
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -19,6 +19,7 @@ import Utility.SafeCommand
 | 
			
		|||
import Utility.Directory
 | 
			
		||||
import Utility.Exception
 | 
			
		||||
import Utility.Monad
 | 
			
		||||
import Utility.FileSystemEncoding
 | 
			
		||||
import Utility.PartialPrelude
 | 
			
		||||
 | 
			
		||||
import System.IO
 | 
			
		||||
| 
						 | 
				
			
			@ -29,6 +30,8 @@ import Data.Maybe
 | 
			
		|||
import Control.Monad
 | 
			
		||||
import Control.Monad.IfElse
 | 
			
		||||
import qualified Data.Map as M
 | 
			
		||||
import qualified System.FilePath.ByteString as P
 | 
			
		||||
import qualified Data.ByteString as S
 | 
			
		||||
import Control.Applicative
 | 
			
		||||
import Prelude
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -52,7 +55,7 @@ disableWildcardExpansion r = r
 | 
			
		|||
fixupDirect :: Repo -> Repo
 | 
			
		||||
fixupDirect r@(Repo { location = l@(Local { gitdir = d, worktree = Nothing }) }) = do
 | 
			
		||||
	r
 | 
			
		||||
		{ location = l { worktree = Just (parentDir d) }
 | 
			
		||||
		{ location = l { worktree = Just (toRawFilePath (parentDir (fromRawFilePath d))) }
 | 
			
		||||
		, gitGlobalOpts = gitGlobalOpts r ++
 | 
			
		||||
			[ Param "-c"
 | 
			
		||||
			, Param $ fromConfigKey coreBare ++ "=" ++ boolConfig False
 | 
			
		||||
| 
						 | 
				
			
			@ -110,12 +113,13 @@ fixupUnusualRepos r@(Repo { location = l@(Local { worktree = Just w, gitdir = d
 | 
			
		|||
		, return r
 | 
			
		||||
		)
 | 
			
		||||
  where
 | 
			
		||||
	dotgit = w </> ".git"
 | 
			
		||||
	dotgit = w P.</> ".git"
 | 
			
		||||
	dotgit' = fromRawFilePath dotgit
 | 
			
		||||
 | 
			
		||||
	replacedotgit = whenM (doesFileExist dotgit) $ do
 | 
			
		||||
		linktarget <- relPathDirToFile w d
 | 
			
		||||
		nukeFile dotgit
 | 
			
		||||
		createSymbolicLink linktarget dotgit
 | 
			
		||||
	replacedotgit = whenM (doesFileExist dotgit') $ do
 | 
			
		||||
		linktarget <- relPathDirToFile (fromRawFilePath w) (fromRawFilePath d)
 | 
			
		||||
		nukeFile dotgit'
 | 
			
		||||
		createSymbolicLink linktarget dotgit'
 | 
			
		||||
	
 | 
			
		||||
	unsetcoreworktree =
 | 
			
		||||
		maybe (error "unset core.worktree failed") (\_ -> return ())
 | 
			
		||||
| 
						 | 
				
			
			@ -125,13 +129,13 @@ fixupUnusualRepos r@(Repo { location = l@(Local { worktree = Just w, gitdir = d
 | 
			
		|||
		-- git-worktree sets up a "commondir" file that contains
 | 
			
		||||
		-- the path to the main git directory.
 | 
			
		||||
		-- Using --separate-git-dir does not.
 | 
			
		||||
		catchDefaultIO Nothing (headMaybe . lines <$> readFile (d </> "commondir")) >>= \case
 | 
			
		||||
		catchDefaultIO Nothing (headMaybe . lines <$> readFile (fromRawFilePath (d P.</> "commondir"))) >>= \case
 | 
			
		||||
			Just gd -> do
 | 
			
		||||
				-- Make the worktree's git directory
 | 
			
		||||
				-- contain an annex symlink to the main
 | 
			
		||||
				-- repository's annex directory.
 | 
			
		||||
				let linktarget = gd </> "annex"
 | 
			
		||||
				createSymbolicLink linktarget (dotgit </> "annex")
 | 
			
		||||
				createSymbolicLink linktarget (dotgit' </> "annex")
 | 
			
		||||
			Nothing -> return ()
 | 
			
		||||
 | 
			
		||||
	-- Repo adjusted, so that symlinks to objects that get checked
 | 
			
		||||
| 
						 | 
				
			
			@ -141,12 +145,12 @@ fixupUnusualRepos r@(Repo { location = l@(Local { worktree = Just w, gitdir = d
 | 
			
		|||
		| coreSymlinks c = r { location = l { gitdir = dotgit } }
 | 
			
		||||
		| otherwise = r
 | 
			
		||||
 | 
			
		||||
	notnoannex = isNothing <$> noAnnexFileContent (Git.repoWorkTree r)
 | 
			
		||||
	notnoannex = isNothing <$> noAnnexFileContent (fmap fromRawFilePath (Git.repoWorkTree r))
 | 
			
		||||
fixupUnusualRepos r _ = return r
 | 
			
		||||
 | 
			
		||||
needsSubmoduleFixup :: Repo -> Bool
 | 
			
		||||
needsSubmoduleFixup (Repo { location = (Local { worktree = Just _, gitdir = d }) }) =
 | 
			
		||||
	(".git" </> "modules") `isInfixOf` d
 | 
			
		||||
	(".git" P.</> "modules") `S.isInfixOf` d
 | 
			
		||||
needsSubmoduleFixup _ = False
 | 
			
		||||
 | 
			
		||||
needsGitLinkFixup :: Repo -> IO Bool
 | 
			
		||||
| 
						 | 
				
			
			@ -154,6 +158,6 @@ needsGitLinkFixup (Repo { location = (Local { worktree = Just wt, gitdir = d })
 | 
			
		|||
	-- Optimization: Avoid statting .git in the common case; only
 | 
			
		||||
	-- when the gitdir is not in the usual place inside the worktree
 | 
			
		||||
	-- might .git be a file.
 | 
			
		||||
	| wt </> ".git" == d = return False
 | 
			
		||||
	| otherwise = doesFileExist (wt </> ".git")
 | 
			
		||||
	| wt P.</> ".git" == d = return False
 | 
			
		||||
	| otherwise = doesFileExist (fromRawFilePath (wt P.</> ".git"))
 | 
			
		||||
needsGitLinkFixup _ = return False
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -54,7 +54,7 @@ withWorkTree d = withAltRepo
 | 
			
		|||
	(\g -> return $ g { location = modlocation (location g), gitGlobalOpts = gitGlobalOpts g ++ disableSmudgeConfig })
 | 
			
		||||
	(\g g' -> g' { location = location g, gitGlobalOpts = gitGlobalOpts g })
 | 
			
		||||
  where
 | 
			
		||||
	modlocation l@(Local {}) = l { worktree = Just d }
 | 
			
		||||
	modlocation l@(Local {}) = l { worktree = Just (toRawFilePath d) }
 | 
			
		||||
	modlocation _ = error "withWorkTree of non-local git repo"
 | 
			
		||||
	disableSmudgeConfig = map Param
 | 
			
		||||
		[ "-c", "filter.annex.smudge="
 | 
			
		||||
| 
						 | 
				
			
			@ -73,7 +73,8 @@ withWorkTreeRelated :: FilePath -> Annex a -> Annex a
 | 
			
		|||
withWorkTreeRelated d = withAltRepo modrepo unmodrepo
 | 
			
		||||
  where
 | 
			
		||||
	modrepo g = liftIO $ do
 | 
			
		||||
		g' <- addGitEnv g "GIT_COMMON_DIR" =<< absPath (localGitDir g)
 | 
			
		||||
		g' <- addGitEnv g "GIT_COMMON_DIR"
 | 
			
		||||
			=<< absPath (fromRawFilePath (localGitDir g))
 | 
			
		||||
		g'' <- addGitEnv g' "GIT_DIR" d
 | 
			
		||||
		return (g'' { gitEnvOverridesGitDir = True })
 | 
			
		||||
	unmodrepo g g' = g'
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -57,6 +57,7 @@ import Control.Concurrent.STM
 | 
			
		|||
import qualified Data.Map.Strict as M
 | 
			
		||||
import qualified Data.Set as S
 | 
			
		||||
import qualified System.FilePath.Posix as Posix
 | 
			
		||||
import qualified System.FilePath.ByteString as P
 | 
			
		||||
 | 
			
		||||
{- Configures how to build an import tree. -}
 | 
			
		||||
data ImportTreeConfig
 | 
			
		||||
| 
						 | 
				
			
			@ -123,7 +124,7 @@ buildImportCommit remote importtreeconfig importcommitconfig importable =
 | 
			
		|||
			Nothing -> pure committedtree
 | 
			
		||||
			Just dir -> 
 | 
			
		||||
				let subtreeref = Ref $
 | 
			
		||||
					fromRef committedtree ++ ":" ++ getTopFilePath dir
 | 
			
		||||
					fromRef committedtree ++ ":" ++ fromRawFilePath (getTopFilePath dir)
 | 
			
		||||
				in fromMaybe emptyTree
 | 
			
		||||
					<$> inRepo (Git.Ref.tree subtreeref)
 | 
			
		||||
		updateexportdb importedtree
 | 
			
		||||
| 
						 | 
				
			
			@ -264,12 +265,12 @@ buildImportTrees basetree msubdir importable = History
 | 
			
		|||
				graftTree' importtree subdir basetree repo hdl
 | 
			
		||||
	
 | 
			
		||||
	mktreeitem (loc, k) = do
 | 
			
		||||
		let lf = fromRawFilePath (fromImportLocation loc)
 | 
			
		||||
		let lf = fromImportLocation loc
 | 
			
		||||
		let treepath = asTopFilePath lf
 | 
			
		||||
		let topf = asTopFilePath $
 | 
			
		||||
			maybe lf (\sd -> getTopFilePath sd </> lf) msubdir
 | 
			
		||||
			maybe lf (\sd -> getTopFilePath sd P.</> lf) msubdir
 | 
			
		||||
		relf <- fromRepo $ fromTopFilePath topf
 | 
			
		||||
		symlink <- calcRepo $ gitAnnexLink relf k
 | 
			
		||||
		symlink <- calcRepo $ gitAnnexLink (fromRawFilePath relf) k
 | 
			
		||||
		linksha <- hashSymlink symlink
 | 
			
		||||
		return $ TreeItem treepath (fromTreeItemType TreeSymlink) linksha
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -368,18 +369,18 @@ downloadImport remote importtreeconfig importablecontents = do
 | 
			
		|||
	
 | 
			
		||||
	mkkey loc tmpfile = do
 | 
			
		||||
		f <- fromRepo $ fromTopFilePath $ locworktreefilename loc
 | 
			
		||||
		backend <- chooseBackend f
 | 
			
		||||
		backend <- chooseBackend (fromRawFilePath f)
 | 
			
		||||
		let ks = KeySource
 | 
			
		||||
			{ keyFilename = f
 | 
			
		||||
			{ keyFilename = (fromRawFilePath f)
 | 
			
		||||
			, contentLocation = tmpfile
 | 
			
		||||
			, inodeCache = Nothing
 | 
			
		||||
			}
 | 
			
		||||
		fmap fst <$> genKey ks nullMeterUpdate backend
 | 
			
		||||
 | 
			
		||||
	locworktreefilename loc = asTopFilePath $ case importtreeconfig of
 | 
			
		||||
		ImportTree -> fromRawFilePath (fromImportLocation loc)
 | 
			
		||||
		ImportTree -> fromImportLocation loc
 | 
			
		||||
		ImportSubTree subdir _ ->
 | 
			
		||||
			getTopFilePath subdir </> fromRawFilePath (fromImportLocation loc)
 | 
			
		||||
			getTopFilePath subdir P.</> fromImportLocation loc
 | 
			
		||||
 | 
			
		||||
	getcidkey cidmap db cid = liftIO $
 | 
			
		||||
		CIDDb.getContentIdentifierKeys db rs cid >>= \case
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -202,7 +202,8 @@ finishIngestUnlocked key source = do
 | 
			
		|||
 | 
			
		||||
finishIngestUnlocked' :: Key -> KeySource -> Restage -> Annex ()
 | 
			
		||||
finishIngestUnlocked' key source restage = do
 | 
			
		||||
	Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath (keyFilename source))
 | 
			
		||||
	Database.Keys.addAssociatedFile key
 | 
			
		||||
		=<< inRepo (toTopFilePath (toRawFilePath (keyFilename source)))
 | 
			
		||||
	populateAssociatedFiles key source restage
 | 
			
		||||
 | 
			
		||||
{- Copy to any other locations using the same key. -}
 | 
			
		||||
| 
						 | 
				
			
			@ -211,10 +212,10 @@ populateAssociatedFiles key source restage = do
 | 
			
		|||
	obj <- toRawFilePath <$> calcRepo (gitAnnexLocation key)
 | 
			
		||||
	g <- Annex.gitRepo
 | 
			
		||||
	ingestedf <- flip fromTopFilePath g
 | 
			
		||||
		<$> inRepo (toTopFilePath (keyFilename source))
 | 
			
		||||
		<$> inRepo (toTopFilePath (toRawFilePath (keyFilename source)))
 | 
			
		||||
	afs <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key
 | 
			
		||||
	forM_ (filter (/= ingestedf) afs) $
 | 
			
		||||
		populatePointerFile restage key obj . toRawFilePath
 | 
			
		||||
		populatePointerFile restage key obj
 | 
			
		||||
 | 
			
		||||
cleanCruft :: KeySource -> Annex ()
 | 
			
		||||
cleanCruft source = when (contentLocation source /= keyFilename source) $
 | 
			
		||||
| 
						 | 
				
			
			@ -226,15 +227,16 @@ cleanCruft source = when (contentLocation source /= keyFilename source) $
 | 
			
		|||
cleanOldKeys :: FilePath -> Key -> Annex ()
 | 
			
		||||
cleanOldKeys file newkey = do
 | 
			
		||||
	g <- Annex.gitRepo
 | 
			
		||||
	ingestedf <- flip fromTopFilePath g <$> inRepo (toTopFilePath file)
 | 
			
		||||
	topf <- inRepo (toTopFilePath file)
 | 
			
		||||
	topf <- inRepo (toTopFilePath (toRawFilePath file))
 | 
			
		||||
	ingestedf <- fromRepo $ fromTopFilePath topf
 | 
			
		||||
	oldkeys <- filter (/= newkey)
 | 
			
		||||
		<$> Database.Keys.getAssociatedKey topf
 | 
			
		||||
	forM_ oldkeys $ \key ->
 | 
			
		||||
		unlessM (isUnmodified key =<< calcRepo (gitAnnexLocation key)) $ do
 | 
			
		||||
			caches <- Database.Keys.getInodeCaches key
 | 
			
		||||
			unlinkAnnex key
 | 
			
		||||
			fs <- filter (/= ingestedf)
 | 
			
		||||
			fs <- map fromRawFilePath
 | 
			
		||||
				. filter (/= ingestedf)
 | 
			
		||||
				. map (`fromTopFilePath` g)
 | 
			
		||||
				<$> Database.Keys.getAssociatedFiles key
 | 
			
		||||
			filterM (`sameInodeCache` caches) fs >>= \case
 | 
			
		||||
| 
						 | 
				
			
			@ -330,7 +332,7 @@ addAnnexedFile file key mtmp = ifM addUnlocked
 | 
			
		|||
			(\tmp -> liftIO $ catchMaybeIO $ fileMode <$> getFileStatus tmp)
 | 
			
		||||
			mtmp
 | 
			
		||||
		stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key
 | 
			
		||||
		Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)
 | 
			
		||||
		Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath (toRawFilePath file))
 | 
			
		||||
		case mtmp of
 | 
			
		||||
			Just tmp -> ifM (moveAnnex key tmp)
 | 
			
		||||
				( linkunlocked mode >> return True
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -56,7 +56,7 @@ import Data.Either
 | 
			
		|||
import qualified Data.Map as M
 | 
			
		||||
 | 
			
		||||
checkCanInitialize :: Annex a -> Annex a
 | 
			
		||||
checkCanInitialize a = inRepo (noAnnexFileContent . Git.repoWorkTree) >>= \case
 | 
			
		||||
checkCanInitialize a = inRepo (noAnnexFileContent . fmap fromRawFilePath . Git.repoWorkTree) >>= \case
 | 
			
		||||
	Nothing -> a
 | 
			
		||||
	Just noannexmsg -> do
 | 
			
		||||
		warning "Initialization prevented by .noannex file (remove the file to override)"
 | 
			
		||||
| 
						 | 
				
			
			@ -67,7 +67,9 @@ checkCanInitialize a = inRepo (noAnnexFileContent . Git.repoWorkTree) >>= \case
 | 
			
		|||
genDescription :: Maybe String -> Annex UUIDDesc
 | 
			
		||||
genDescription (Just d) = return $ UUIDDesc $ encodeBS d
 | 
			
		||||
genDescription Nothing = do
 | 
			
		||||
	reldir <- liftIO . relHome =<< liftIO . absPath =<< fromRepo Git.repoPath
 | 
			
		||||
	reldir <- liftIO . relHome
 | 
			
		||||
		=<< liftIO . absPath . fromRawFilePath
 | 
			
		||||
		=<< fromRepo Git.repoPath
 | 
			
		||||
	hostname <- fromMaybe "" <$> liftIO getHostname
 | 
			
		||||
	let at = if null hostname then "" else "@"
 | 
			
		||||
	v <- liftIO myUserName
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -200,7 +200,7 @@ restagePointerFile (Restage True) f orig = withTSDelta $ \tsd -> do
 | 
			
		|||
		    unlockindex = liftIO . maybe noop Git.LockFile.closeLock
 | 
			
		||||
		    showwarning = warning $ unableToRestage Nothing
 | 
			
		||||
		    go Nothing = showwarning
 | 
			
		||||
		    go (Just _) = withTmpDirIn (Git.localGitDir r) "annexindex" $ \tmpdir -> do
 | 
			
		||||
		    go (Just _) = withTmpDirIn (fromRawFilePath $ Git.localGitDir r) "annexindex" $ \tmpdir -> do
 | 
			
		||||
			let tmpindex = tmpdir </> "index"
 | 
			
		||||
			let updatetmpindex = do
 | 
			
		||||
				r' <- Git.Env.addGitEnv r Git.Index.indexEnv 
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -93,6 +93,7 @@ module Annex.Locations (
 | 
			
		|||
import Data.Char
 | 
			
		||||
import Data.Default
 | 
			
		||||
import qualified Data.ByteString.Char8 as S8
 | 
			
		||||
import qualified System.FilePath.ByteString as P
 | 
			
		||||
 | 
			
		||||
import Common
 | 
			
		||||
import Key
 | 
			
		||||
| 
						 | 
				
			
			@ -158,7 +159,12 @@ gitAnnexLocationDepth config = hashlevels + 1
 | 
			
		|||
 - the actual location of the file's content.
 | 
			
		||||
 -}
 | 
			
		||||
gitAnnexLocation :: Key -> Git.Repo -> GitConfig -> IO FilePath
 | 
			
		||||
gitAnnexLocation key r config = gitAnnexLocation' key r config (annexCrippledFileSystem config) (coreSymlinks config) doesFileExist (Git.localGitDir r)
 | 
			
		||||
gitAnnexLocation key r config = gitAnnexLocation' key r config
 | 
			
		||||
	(annexCrippledFileSystem config)
 | 
			
		||||
	(coreSymlinks config)
 | 
			
		||||
	doesFileExist
 | 
			
		||||
	(fromRawFilePath (Git.localGitDir r))
 | 
			
		||||
 | 
			
		||||
gitAnnexLocation' :: Key -> Git.Repo -> GitConfig -> Bool -> Bool -> (FilePath -> IO Bool) -> FilePath -> IO FilePath
 | 
			
		||||
gitAnnexLocation' key r config crippled symlinkssupported checker gitdir
 | 
			
		||||
	{- Bare repositories default to hashDirLower for new
 | 
			
		||||
| 
						 | 
				
			
			@ -200,8 +206,9 @@ gitAnnexLink file key r config = do
 | 
			
		|||
		 - supporting symlinks; generate link target that will
 | 
			
		||||
		 - work portably. -}
 | 
			
		||||
		| not (coreSymlinks config) && needsSubmoduleFixup r =
 | 
			
		||||
			absNormPathUnix currdir $ Git.repoPath r </> ".git"
 | 
			
		||||
		| otherwise = Git.localGitDir r
 | 
			
		||||
			absNormPathUnix currdir $ fromRawFilePath $
 | 
			
		||||
				Git.repoPath r P.</> ".git"
 | 
			
		||||
		| otherwise = fromRawFilePath $ Git.localGitDir r
 | 
			
		||||
	absNormPathUnix d p = fromRawFilePath $ toInternalGitPath $ toRawFilePath $
 | 
			
		||||
		absPathFrom
 | 
			
		||||
			(fromRawFilePath $ toInternalGitPath $ toRawFilePath d)
 | 
			
		||||
| 
						 | 
				
			
			@ -214,7 +221,7 @@ gitAnnexLinkCanonical file key r config = gitAnnexLink file key r' config'
 | 
			
		|||
  where
 | 
			
		||||
	r' = case r of
 | 
			
		||||
		Git.Repo { Git.location = l@Git.Local { Git.worktree = Just wt } } ->
 | 
			
		||||
			r { Git.location = l { Git.gitdir = wt </> ".git" } }
 | 
			
		||||
			r { Git.location = l { Git.gitdir = wt P.</> ".git" } }
 | 
			
		||||
		_ -> r
 | 
			
		||||
	config' = config
 | 
			
		||||
		{ annexCrippledFileSystem = False
 | 
			
		||||
| 
						 | 
				
			
			@ -250,11 +257,11 @@ gitAnnexInodeSentinalCache r = gitAnnexInodeSentinal r ++ ".cache"
 | 
			
		|||
 | 
			
		||||
{- The annex directory of a repository. -}
 | 
			
		||||
gitAnnexDir :: Git.Repo -> FilePath
 | 
			
		||||
gitAnnexDir r = addTrailingPathSeparator $ Git.localGitDir r </> annexDir
 | 
			
		||||
gitAnnexDir r = addTrailingPathSeparator $ fromRawFilePath (Git.localGitDir r) </> annexDir
 | 
			
		||||
 | 
			
		||||
{- The part of the annex directory where file contents are stored. -}
 | 
			
		||||
gitAnnexObjectDir :: Git.Repo -> FilePath
 | 
			
		||||
gitAnnexObjectDir r = addTrailingPathSeparator $ Git.localGitDir r </> objectDir
 | 
			
		||||
gitAnnexObjectDir r = addTrailingPathSeparator $ fromRawFilePath (Git.localGitDir r) </> objectDir
 | 
			
		||||
 | 
			
		||||
{- .git/annex/tmp/ is used for temp files for key's contents -}
 | 
			
		||||
gitAnnexTmpObjectDir :: Git.Repo -> FilePath
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -5,6 +5,8 @@
 | 
			
		|||
 - Licensed under the GNU AGPL version 3 or higher.
 | 
			
		||||
 -}
 | 
			
		||||
 | 
			
		||||
{-# LANGUAGE OverloadedStrings #-}
 | 
			
		||||
 | 
			
		||||
module Annex.View where
 | 
			
		||||
 | 
			
		||||
import Annex.Common
 | 
			
		||||
| 
						 | 
				
			
			@ -80,7 +82,7 @@ parseViewParam s = case separate (== '=') s of
 | 
			
		|||
			)
 | 
			
		||||
  where
 | 
			
		||||
	mkFilterValues v
 | 
			
		||||
		| any (`elem` v) "*?" = FilterGlob v
 | 
			
		||||
		| any (`elem` v) ['*', '?'] = FilterGlob v
 | 
			
		||||
		| otherwise = FilterValues $ S.singleton $ toMetaValue $ encodeBS v
 | 
			
		||||
	mkExcludeValues = ExcludeValues . S.singleton . toMetaValue . encodeBS
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -343,11 +345,11 @@ narrowView = applyView' viewedFileReuse getViewedFileMetaData
 | 
			
		|||
applyView' :: MkViewedFile -> (FilePath -> MetaData) -> View -> Annex Git.Branch
 | 
			
		||||
applyView' mkviewedfile getfilemetadata view = do
 | 
			
		||||
	top <- fromRepo Git.repoPath
 | 
			
		||||
	(l, clean) <- inRepo $ Git.LsFiles.stagedDetails [toRawFilePath top]
 | 
			
		||||
	(l, clean) <- inRepo $ Git.LsFiles.stagedDetails [top]
 | 
			
		||||
	liftIO . nukeFile =<< fromRepo gitAnnexViewIndex
 | 
			
		||||
	uh <- withViewIndex $ inRepo Git.UpdateIndex.startUpdateIndex
 | 
			
		||||
	forM_ l $ \(f, sha, mode) -> do
 | 
			
		||||
		topf <- inRepo (toTopFilePath $ fromRawFilePath f)
 | 
			
		||||
		topf <- inRepo (toTopFilePath f)
 | 
			
		||||
		go uh topf sha (toTreeItemType =<< mode) =<< lookupFile f
 | 
			
		||||
	liftIO $ do
 | 
			
		||||
		void $ stopUpdateIndex uh
 | 
			
		||||
| 
						 | 
				
			
			@ -358,13 +360,14 @@ applyView' mkviewedfile getfilemetadata view = do
 | 
			
		|||
 | 
			
		||||
	go uh topf _sha _mode (Just k) = do
 | 
			
		||||
		metadata <- getCurrentMetaData k
 | 
			
		||||
		let f = getTopFilePath topf
 | 
			
		||||
		let f = fromRawFilePath $ getTopFilePath topf
 | 
			
		||||
		let metadata' = getfilemetadata f `unionMetaData` metadata
 | 
			
		||||
		forM_ (genviewedfiles f metadata') $ \fv -> do
 | 
			
		||||
			f' <- fromRepo $ fromTopFilePath $ asTopFilePath fv
 | 
			
		||||
			f' <- fromRawFilePath <$> 
 | 
			
		||||
				fromRepo (fromTopFilePath $ asTopFilePath $ toRawFilePath fv)
 | 
			
		||||
			stagesymlink uh f' =<< calcRepo (gitAnnexLink f' k)
 | 
			
		||||
	go uh topf (Just sha) (Just treeitemtype) Nothing
 | 
			
		||||
		| "." `isPrefixOf` getTopFilePath topf =
 | 
			
		||||
		| "." `B.isPrefixOf` getTopFilePath topf =
 | 
			
		||||
			liftIO $ Git.UpdateIndex.streamUpdateIndex' uh $
 | 
			
		||||
				pureStreamer $ updateIndexLine sha treeitemtype topf
 | 
			
		||||
	go _ _ _ _  _ = noop
 | 
			
		||||
| 
						 | 
				
			
			@ -403,7 +406,7 @@ withViewChanges addmeta removemeta = do
 | 
			
		|||
				=<< catKey (DiffTree.dstsha item)
 | 
			
		||||
		| otherwise = noop
 | 
			
		||||
	handlechange item a = maybe noop
 | 
			
		||||
		(void . commandAction . a (getTopFilePath $ DiffTree.file item))
 | 
			
		||||
		(void . commandAction . a (fromRawFilePath $ getTopFilePath $ DiffTree.file item))
 | 
			
		||||
 | 
			
		||||
{- Runs an action using the view index file.
 | 
			
		||||
 - Note that the file does not necessarily exist, or can contain
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -23,6 +23,7 @@ import Database.Types
 | 
			
		|||
import qualified Database.Keys
 | 
			
		||||
import qualified Database.Keys.SQL
 | 
			
		||||
import Config
 | 
			
		||||
import qualified Utility.RawFilePath as R
 | 
			
		||||
 | 
			
		||||
{- Looks up the key corresponding to an annexed file in the work tree,
 | 
			
		||||
 - by examining what the file links to.
 | 
			
		||||
| 
						 | 
				
			
			@ -96,10 +97,11 @@ scanUnlockedFiles = whenM (inRepo Git.Ref.headExists <&&> not <$> isBareRepo) $
 | 
			
		|||
			liftIO . Database.Keys.SQL.addAssociatedFileFast (toIKey k) tf
 | 
			
		||||
		whenM (inAnnex k) $ do
 | 
			
		||||
			f <- fromRepo $ fromTopFilePath tf
 | 
			
		||||
			liftIO (isPointerFile (toRawFilePath f)) >>= \case
 | 
			
		||||
			liftIO (isPointerFile f) >>= \case
 | 
			
		||||
				Just k' | k' == k -> do
 | 
			
		||||
					destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f
 | 
			
		||||
					ic <- replaceFile f $ \tmp ->
 | 
			
		||||
					destmode <- liftIO $ catchMaybeIO $
 | 
			
		||||
						fileMode <$> R.getFileStatus f
 | 
			
		||||
					ic <- replaceFile (fromRawFilePath f) $ \tmp ->
 | 
			
		||||
						linkFromAnnex k tmp destmode >>= \case
 | 
			
		||||
							LinkAnnexOk -> 
 | 
			
		||||
								withTSDelta (liftIO . genInodeCache tmp)
 | 
			
		||||
| 
						 | 
				
			
			@ -107,5 +109,5 @@ scanUnlockedFiles = whenM (inRepo Git.Ref.headExists <&&> not <$> isBareRepo) $
 | 
			
		|||
							LinkAnnexFailed -> liftIO $ do
 | 
			
		||||
								writePointerFile (toRawFilePath tmp) k destmode
 | 
			
		||||
								return Nothing
 | 
			
		||||
					maybe noop (restagePointerFile (Restage True) (toRawFilePath f)) ic
 | 
			
		||||
					maybe noop (restagePointerFile (Restage True) f) ic
 | 
			
		||||
				_ -> noop
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -91,7 +91,7 @@ runRepair u mrmt destructiverepair = do
 | 
			
		|||
	remoterepair fsckresults = case Remote.repairRepo =<< mrmt of
 | 
			
		||||
		Nothing -> return False
 | 
			
		||||
		Just mkrepair -> do
 | 
			
		||||
			thisrepopath <- liftIO . absPath
 | 
			
		||||
			thisrepopath <- liftIO . absPath . fromRawFilePath
 | 
			
		||||
				=<< liftAnnex (fromRepo Git.repoPath)
 | 
			
		||||
			a <- liftAnnex $ mkrepair $
 | 
			
		||||
				repair fsckresults (Just thisrepopath)
 | 
			
		||||
| 
						 | 
				
			
			@ -130,7 +130,7 @@ repairStaleGitLocks r = do
 | 
			
		|||
	repairStaleLocks lockfiles
 | 
			
		||||
	return $ not $ null lockfiles
 | 
			
		||||
  where
 | 
			
		||||
	findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator annexDir) True . Git.localGitDir
 | 
			
		||||
	findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator annexDir) True . fromRawFilePath . Git.localGitDir
 | 
			
		||||
	islock f
 | 
			
		||||
		| "gc.pid" `isInfixOf` f = False
 | 
			
		||||
		| ".lock" `isSuffixOf` f = True
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -91,4 +91,4 @@ getConfigs = S.fromList . map extract
 | 
			
		|||
	<$> liftAnnex (inRepo $ LsTree.lsTreeFiles Annex.Branch.fullname files)
 | 
			
		||||
  where
 | 
			
		||||
	files = map (fromRawFilePath . fst) configFilesActions
 | 
			
		||||
	extract treeitem = (toRawFilePath $ getTopFilePath $ LsTree.file treeitem, LsTree.sha treeitem)
 | 
			
		||||
	extract treeitem = (getTopFilePath $ LsTree.file treeitem, LsTree.sha treeitem)
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -26,7 +26,7 @@ import qualified Command.Sync
 | 
			
		|||
mergeThread :: NamedThread
 | 
			
		||||
mergeThread = namedThread "Merger" $ do
 | 
			
		||||
	g <- liftAnnex gitRepo
 | 
			
		||||
	let dir = Git.localGitDir g </> "refs"
 | 
			
		||||
	let dir = fromRawFilePath (Git.localGitDir g) </> "refs"
 | 
			
		||||
	liftIO $ createDirectoryIfMissing True dir
 | 
			
		||||
	let hook a = Just <$> asIO2 (runHandler a)
 | 
			
		||||
	changehook <- hook onChange
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -159,7 +159,7 @@ handleMount urlrenderer dir = do
 | 
			
		|||
 -}
 | 
			
		||||
remotesUnder :: FilePath -> Assistant [Remote]
 | 
			
		||||
remotesUnder dir = do
 | 
			
		||||
	repotop <- liftAnnex $ fromRepo Git.repoPath
 | 
			
		||||
	repotop <- liftAnnex $ fromRawFilePath <$> fromRepo Git.repoPath
 | 
			
		||||
	rs <- liftAnnex remoteList
 | 
			
		||||
	pairs <- liftAnnex $ mapM (checkremote repotop) rs
 | 
			
		||||
	let (waschanged, rs') = unzip pairs
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -119,7 +119,7 @@ pairReqReceived False urlrenderer msg = do
 | 
			
		|||
pairAckReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> [PairingInProgress] -> Assistant [PairingInProgress]
 | 
			
		||||
pairAckReceived True (Just pip) msg cache = do
 | 
			
		||||
	stopSending pip
 | 
			
		||||
	repodir <- repoPath <$> liftAnnex gitRepo
 | 
			
		||||
	repodir <- fromRawFilePath . repoPath <$> liftAnnex gitRepo
 | 
			
		||||
	liftIO $ setupAuthorizedKeys msg repodir
 | 
			
		||||
	finishedLocalPairing msg (inProgressSshKeyPair pip)
 | 
			
		||||
	startSending pip PairDone $ multicastPairMsg
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -269,5 +269,5 @@ checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGit
 | 
			
		|||
checkRepoExists :: Assistant ()
 | 
			
		||||
checkRepoExists = do
 | 
			
		||||
	g <- liftAnnex gitRepo
 | 
			
		||||
	liftIO $ unlessM (doesDirectoryExist $ Git.repoPath g) $
 | 
			
		||||
	liftIO $ unlessM (doesDirectoryExist $ fromRawFilePath $ Git.repoPath g) $
 | 
			
		||||
		terminateSelf
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -136,8 +136,7 @@ startupScan scanner = do
 | 
			
		|||
		-- Notice any files that were deleted before
 | 
			
		||||
		-- watching was started.
 | 
			
		||||
		top <- liftAnnex $ fromRepo Git.repoPath
 | 
			
		||||
		(fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted
 | 
			
		||||
			[toRawFilePath top]
 | 
			
		||||
		(fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted [top]
 | 
			
		||||
		forM_ fs $ \f -> do
 | 
			
		||||
			let f' = fromRawFilePath f
 | 
			
		||||
			liftAnnex $ onDel' f'
 | 
			
		||||
| 
						 | 
				
			
			@ -215,7 +214,7 @@ onAddUnlocked symlinkssupported matcher f fs = do
 | 
			
		|||
  where
 | 
			
		||||
	addassociatedfile key file = 
 | 
			
		||||
		Database.Keys.addAssociatedFile key
 | 
			
		||||
			=<< inRepo (toTopFilePath file)
 | 
			
		||||
			=<< inRepo (toTopFilePath (toRawFilePath file))
 | 
			
		||||
	samefilestatus key file status = do
 | 
			
		||||
		cache <- Database.Keys.getInodeCaches key
 | 
			
		||||
		curr <- withTSDelta $ \delta -> liftIO $ toInodeCache delta file status
 | 
			
		||||
| 
						 | 
				
			
			@ -225,7 +224,7 @@ onAddUnlocked symlinkssupported matcher f fs = do
 | 
			
		|||
			_ -> return False
 | 
			
		||||
	contentchanged oldkey file = do
 | 
			
		||||
		Database.Keys.removeAssociatedFile oldkey
 | 
			
		||||
			=<< inRepo (toTopFilePath file)
 | 
			
		||||
			=<< inRepo (toTopFilePath (toRawFilePath file))
 | 
			
		||||
		unlessM (inAnnex oldkey) $
 | 
			
		||||
			logStatus oldkey InfoMissing
 | 
			
		||||
	addlink file key = do
 | 
			
		||||
| 
						 | 
				
			
			@ -347,7 +346,7 @@ onDel file _ = do
 | 
			
		|||
 | 
			
		||||
onDel' :: FilePath -> Annex ()
 | 
			
		||||
onDel' file = do
 | 
			
		||||
	topfile <- inRepo (toTopFilePath file)
 | 
			
		||||
	topfile <- inRepo (toTopFilePath (toRawFilePath file))
 | 
			
		||||
	withkey $ flip Database.Keys.removeAssociatedFile topfile
 | 
			
		||||
	Annex.Queue.addUpdateIndex =<<
 | 
			
		||||
		inRepo (Git.UpdateIndex.unstageFile file)
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -100,7 +100,7 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
 | 
			
		|||
	getreldir
 | 
			
		||||
		| noannex = return Nothing
 | 
			
		||||
		| otherwise = Just <$>
 | 
			
		||||
			(relHome =<< absPath
 | 
			
		||||
			(relHome =<< absPath . fromRawFilePath
 | 
			
		||||
				=<< getAnnex' (fromRepo repoPath))
 | 
			
		||||
	go tlssettings addr webapp htmlshim urlfile = do
 | 
			
		||||
		let url = myUrl tlssettings webapp addr
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -64,7 +64,7 @@ describeUnused' whenbig = liftAnnex $ go =<< readUnusedLog ""
 | 
			
		|||
 | 
			
		||||
	sumkeysize s k = s + fromMaybe 0 (fromKey keySize k)
 | 
			
		||||
 | 
			
		||||
	forpath a = inRepo $ liftIO . a . Git.repoPath
 | 
			
		||||
	forpath a = inRepo $ liftIO . a . fromRawFilePath . Git.repoPath
 | 
			
		||||
 | 
			
		||||
{- With a duration, expires all unused files that are older.
 | 
			
		||||
 - With Nothing, expires *all* unused files. -}
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -78,7 +78,7 @@ deleteCurrentRepository = dangerPage $ do
 | 
			
		|||
			sanityVerifierAForm $ SanityVerifier magicphrase
 | 
			
		||||
	case result of
 | 
			
		||||
		FormSuccess _ -> liftH $ do
 | 
			
		||||
			dir <- liftAnnex $ fromRepo Git.repoPath
 | 
			
		||||
			dir <- liftAnnex $ fromRawFilePath <$> fromRepo Git.repoPath
 | 
			
		||||
			liftIO $ removeAutoStartFile dir
 | 
			
		||||
 | 
			
		||||
			{- Disable syncing to this repository, and all
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -238,7 +238,7 @@ checkAssociatedDirectory cfg (Just r) = do
 | 
			
		|||
		RepoGroupStandard gr -> case associatedDirectory repoconfig gr of
 | 
			
		||||
			Just d -> inRepo $ \g ->
 | 
			
		||||
				createDirectoryIfMissing True $
 | 
			
		||||
					Git.repoPath g </> d
 | 
			
		||||
					fromRawFilePath (Git.repoPath g) </> d
 | 
			
		||||
			Nothing -> noop
 | 
			
		||||
		_ -> noop
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -173,7 +173,7 @@ getFinishLocalPairR = postFinishLocalPairR
 | 
			
		|||
postFinishLocalPairR :: PairMsg -> Handler Html
 | 
			
		||||
#ifdef WITH_PAIRING
 | 
			
		||||
postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
 | 
			
		||||
	repodir <- liftH $ repoPath <$> liftAnnex gitRepo
 | 
			
		||||
	repodir <- liftH $ fromRawFilePath . repoPath <$> liftAnnex gitRepo
 | 
			
		||||
	liftIO $ setup repodir
 | 
			
		||||
	startLocalPairing PairAck (cleanup repodir) alert uuid "" secret
 | 
			
		||||
  where
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -94,7 +94,7 @@ storePrefs p = do
 | 
			
		|||
	unsetConfig (annexConfig "numcopies") -- deprecated
 | 
			
		||||
	setConfig (annexConfig "autoupgrade") (fromAutoUpgrade $ autoUpgrade p)
 | 
			
		||||
	unlessM ((==) <$> pure (autoStart p) <*> inAutoStartFile) $ do
 | 
			
		||||
		here <- fromRepo Git.repoPath
 | 
			
		||||
		here <- fromRawFilePath <$> fromRepo Git.repoPath
 | 
			
		||||
		liftIO $ if autoStart p
 | 
			
		||||
			then addAutoStartFile here
 | 
			
		||||
			else removeAutoStartFile here
 | 
			
		||||
| 
						 | 
				
			
			@ -118,5 +118,5 @@ postPreferencesR = page "Preferences" (Just Configuration) $ do
 | 
			
		|||
 | 
			
		||||
inAutoStartFile :: Annex Bool
 | 
			
		||||
inAutoStartFile = do
 | 
			
		||||
	here <- liftIO . absPath =<< fromRepo Git.repoPath
 | 
			
		||||
	here <- liftIO . absPath . fromRawFilePath =<< fromRepo Git.repoPath
 | 
			
		||||
	any (`equalFilePath` here) <$> liftIO readAutoStartFile
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -118,7 +118,8 @@ getFileBrowserR = whenM openFileBrowser redirectBack
 | 
			
		|||
 - blocking the response to the browser on it. -}
 | 
			
		||||
openFileBrowser :: Handler Bool
 | 
			
		||||
openFileBrowser = do
 | 
			
		||||
	path <- liftIO . absPath =<< liftAnnex (fromRepo Git.repoPath)
 | 
			
		||||
	path <- liftIO . absPath . fromRawFilePath
 | 
			
		||||
		=<< liftAnnex (fromRepo Git.repoPath)
 | 
			
		||||
#ifdef darwin_HOST_OS
 | 
			
		||||
	let cmd = "open"
 | 
			
		||||
	let p = proc cmd [path]
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -38,7 +38,8 @@ keyValue source _ = do
 | 
			
		|||
	let f = contentLocation source
 | 
			
		||||
	stat <- liftIO $ getFileStatus f
 | 
			
		||||
	sz <- liftIO $ getFileSize' f stat
 | 
			
		||||
	relf <- getTopFilePath <$> inRepo (toTopFilePath $ keyFilename source)
 | 
			
		||||
	relf <- fromRawFilePath . getTopFilePath
 | 
			
		||||
		<$> inRepo (toTopFilePath $ toRawFilePath $ keyFilename source)
 | 
			
		||||
	return $ Just $ mkKey $ \k -> k
 | 
			
		||||
		{ keyName = genKeyName relf
 | 
			
		||||
		, keyVariety = WORMKey
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -102,7 +102,8 @@ batchFilesMatching :: BatchFormat -> (FilePath -> CommandStart) -> Annex ()
 | 
			
		|||
batchFilesMatching fmt a = do
 | 
			
		||||
	matcher <- getMatcher
 | 
			
		||||
	batchStart fmt $ \f ->
 | 
			
		||||
		ifM (matcher $ MatchingFile $ FileInfo f f)
 | 
			
		||||
		let f' = toRawFilePath f
 | 
			
		||||
		in ifM (matcher $ MatchingFile $ FileInfo f' f')
 | 
			
		||||
			( a f
 | 
			
		||||
			, return Nothing
 | 
			
		||||
			)
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -94,8 +94,8 @@ withPathContents a params = do
 | 
			
		|||
		, return [(p, takeFileName p)]
 | 
			
		||||
		)
 | 
			
		||||
	checkmatch matcher (f, relf) = matcher $ MatchingFile $ FileInfo
 | 
			
		||||
		{ currFile = f
 | 
			
		||||
		, matchFile = relf
 | 
			
		||||
		{ currFile = toRawFilePath f
 | 
			
		||||
		, matchFile = toRawFilePath relf
 | 
			
		||||
		}
 | 
			
		||||
 | 
			
		||||
withWords :: ([String] -> CommandSeek) -> CmdParams -> CommandSeek
 | 
			
		||||
| 
						 | 
				
			
			@ -170,7 +170,7 @@ withKeyOptions ko auto keyaction = withKeyOptions' ko auto mkkeyaction
 | 
			
		|||
		return $ \v@(k, ai) ->
 | 
			
		||||
			let i = case ai of
 | 
			
		||||
				ActionItemBranchFilePath (BranchFilePath _ topf) _ ->
 | 
			
		||||
					MatchingKey k (AssociatedFile $ Just $ toRawFilePath $ getTopFilePath topf)
 | 
			
		||||
					MatchingKey k (AssociatedFile $ Just $ getTopFilePath topf)
 | 
			
		||||
				_ -> MatchingKey k (AssociatedFile Nothing)
 | 
			
		||||
			in whenM (matcher i) $
 | 
			
		||||
				keyaction v
 | 
			
		||||
| 
						 | 
				
			
			@ -232,8 +232,7 @@ prepFiltered a fs = do
 | 
			
		|||
	map (process matcher) <$> fs
 | 
			
		||||
  where
 | 
			
		||||
	process matcher f =
 | 
			
		||||
		let f' = fromRawFilePath f
 | 
			
		||||
		in whenM (matcher $ MatchingFile $ FileInfo f' f') $ a f
 | 
			
		||||
		whenM (matcher $ MatchingFile $ FileInfo f f) $ a f
 | 
			
		||||
 | 
			
		||||
seekActions :: Annex [CommandSeek] -> Annex ()
 | 
			
		||||
seekActions gen = sequence_ =<< gen
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -114,7 +114,7 @@ start file = do
 | 
			
		|||
			cleanup key =<< inAnnex key
 | 
			
		||||
	fixuppointer key = starting "add" (ActionItemWorkTreeFile file) $ do
 | 
			
		||||
		-- the pointer file is present, but not yet added to git
 | 
			
		||||
		Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath (fromRawFilePath file))
 | 
			
		||||
		Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)
 | 
			
		||||
		next $ addFile file
 | 
			
		||||
 | 
			
		||||
perform :: RawFilePath -> CommandPerform
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -251,7 +251,7 @@ startExport :: Remote -> ExportHandle -> MVar FileUploaded -> MVar AllFilled ->
 | 
			
		|||
startExport r db cvar allfilledvar ti = do
 | 
			
		||||
	ek <- exportKey (Git.LsTree.sha ti)
 | 
			
		||||
	stopUnless (notrecordedpresent ek) $
 | 
			
		||||
		starting ("export " ++ name r) (ActionItemOther (Just f)) $
 | 
			
		||||
		starting ("export " ++ name r) (ActionItemOther (Just (fromRawFilePath f))) $
 | 
			
		||||
			ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) (asKey ek) loc))
 | 
			
		||||
				( next $ cleanupExport r db ek loc False
 | 
			
		||||
				, do
 | 
			
		||||
| 
						 | 
				
			
			@ -259,9 +259,9 @@ startExport r db cvar allfilledvar ti = do
 | 
			
		|||
					performExport r db ek af (Git.LsTree.sha ti) loc allfilledvar
 | 
			
		||||
				)
 | 
			
		||||
  where
 | 
			
		||||
	loc = mkExportLocation (toRawFilePath f)
 | 
			
		||||
	loc = mkExportLocation f
 | 
			
		||||
	f = getTopFilePath (Git.LsTree.file ti)
 | 
			
		||||
	af = AssociatedFile (Just (toRawFilePath f))
 | 
			
		||||
	af = AssociatedFile (Just f)
 | 
			
		||||
	notrecordedpresent ek = (||)
 | 
			
		||||
		<$> liftIO (notElem loc <$> getExportedLocation db (asKey ek))
 | 
			
		||||
		-- If content was removed from the remote, the export db
 | 
			
		||||
| 
						 | 
				
			
			@ -314,17 +314,17 @@ startUnexport r db f shas = do
 | 
			
		|||
	eks <- forM (filter (/= nullSha) shas) exportKey
 | 
			
		||||
	if null eks
 | 
			
		||||
		then stop
 | 
			
		||||
		else starting ("unexport " ++ name r) (ActionItemOther (Just f')) $
 | 
			
		||||
		else starting ("unexport " ++ name r) (ActionItemOther (Just (fromRawFilePath f'))) $
 | 
			
		||||
			performUnexport r db eks loc
 | 
			
		||||
  where
 | 
			
		||||
	loc = mkExportLocation (toRawFilePath f')
 | 
			
		||||
	loc = mkExportLocation f'
 | 
			
		||||
	f' = getTopFilePath f
 | 
			
		||||
 | 
			
		||||
startUnexport' :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
 | 
			
		||||
startUnexport' r db f ek = starting ("unexport " ++ name r) (ActionItemOther (Just f')) $
 | 
			
		||||
startUnexport' r db f ek = starting ("unexport " ++ name r) (ActionItemOther (Just (fromRawFilePath f'))) $
 | 
			
		||||
	performUnexport r db [ek] loc
 | 
			
		||||
  where
 | 
			
		||||
	loc = mkExportLocation (toRawFilePath f')
 | 
			
		||||
	loc = mkExportLocation f'
 | 
			
		||||
	f' = getTopFilePath f
 | 
			
		||||
 | 
			
		||||
-- Unlike a usual drop from a repository, this does not check that
 | 
			
		||||
| 
						 | 
				
			
			@ -368,15 +368,14 @@ startRecoverIncomplete r db sha oldf
 | 
			
		|||
			liftIO $ removeExportedLocation db (asKey ek) oldloc
 | 
			
		||||
			performUnexport r db [ek] loc
 | 
			
		||||
  where
 | 
			
		||||
	oldloc = mkExportLocation (toRawFilePath oldf')
 | 
			
		||||
	oldf' = getTopFilePath oldf
 | 
			
		||||
	oldloc = mkExportLocation $ getTopFilePath oldf
 | 
			
		||||
 | 
			
		||||
startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
 | 
			
		||||
startMoveToTempName r db f ek = starting ("rename " ++ name r) 
 | 
			
		||||
	(ActionItemOther $ Just $ f' ++ " -> " ++ fromRawFilePath (fromExportLocation tmploc))
 | 
			
		||||
	(ActionItemOther $ Just $ fromRawFilePath f' ++ " -> " ++ fromRawFilePath (fromExportLocation tmploc))
 | 
			
		||||
	(performRename r db ek loc tmploc)
 | 
			
		||||
  where
 | 
			
		||||
	loc = mkExportLocation (toRawFilePath f')
 | 
			
		||||
	loc = mkExportLocation f'
 | 
			
		||||
	f' = getTopFilePath f
 | 
			
		||||
	tmploc = exportTempName ek
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -384,10 +383,10 @@ startMoveFromTempName :: Remote -> ExportHandle -> ExportKey -> TopFilePath -> C
 | 
			
		|||
startMoveFromTempName r db ek f = do
 | 
			
		||||
	let tmploc = exportTempName ek
 | 
			
		||||
	stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $
 | 
			
		||||
		starting ("rename " ++ name r) (ActionItemOther (Just (fromRawFilePath (fromExportLocation tmploc) ++ " -> " ++ f'))) $
 | 
			
		||||
		starting ("rename " ++ name r) (ActionItemOther (Just (fromRawFilePath (fromExportLocation tmploc) ++ " -> " ++ fromRawFilePath f'))) $
 | 
			
		||||
			performRename r db ek tmploc loc
 | 
			
		||||
  where
 | 
			
		||||
	loc = mkExportLocation (toRawFilePath f')
 | 
			
		||||
	loc = mkExportLocation f'
 | 
			
		||||
	f' = getTopFilePath f
 | 
			
		||||
 | 
			
		||||
performRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform
 | 
			
		||||
| 
						 | 
				
			
			@ -469,7 +468,7 @@ filterPreferredContent r tree = logExportExcluded (uuid r) $ \logwriter -> do
 | 
			
		|||
				-- Match filename relative to the
 | 
			
		||||
				-- top of the tree.
 | 
			
		||||
				let af = AssociatedFile $ Just $
 | 
			
		||||
					toRawFilePath $ getTopFilePath topf
 | 
			
		||||
					getTopFilePath topf
 | 
			
		||||
				let mi = MatchingKey k af
 | 
			
		||||
				ifM (checkMatcher' matcher mi mempty)
 | 
			
		||||
					( return (Just ti)
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -74,7 +74,7 @@ start o file key =
 | 
			
		|||
 | 
			
		||||
startKeys :: FindOptions -> (Key, ActionItem) -> CommandStart
 | 
			
		||||
startKeys o (key, ActionItemBranchFilePath (BranchFilePath _ topf) _) = 
 | 
			
		||||
	start o (toRawFilePath (getTopFilePath topf)) key
 | 
			
		||||
	start o (getTopFilePath topf) key
 | 
			
		||||
startKeys _ _ = stop
 | 
			
		||||
 | 
			
		||||
showFormatted :: Maybe Utility.Format.Format -> S.ByteString -> [(String, String)] -> Annex ()
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -313,7 +313,7 @@ verifyRequiredContent _ _ = return True
 | 
			
		|||
verifyAssociatedFiles :: Key -> KeyStatus -> RawFilePath -> Annex Bool
 | 
			
		||||
verifyAssociatedFiles key keystatus file = do
 | 
			
		||||
	when (isKeyUnlockedThin keystatus) $ do
 | 
			
		||||
		f <- inRepo $ toTopFilePath $ fromRawFilePath file
 | 
			
		||||
		f <- inRepo $ toTopFilePath file
 | 
			
		||||
		afs <- Database.Keys.getAssociatedFiles key
 | 
			
		||||
		unless (getTopFilePath f `elem` map getTopFilePath afs) $
 | 
			
		||||
			Database.Keys.addAssociatedFile key f
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -97,7 +97,7 @@ duplicateModeParser =
 | 
			
		|||
 | 
			
		||||
seek :: ImportOptions -> CommandSeek
 | 
			
		||||
seek o@(LocalImportOptions {}) = startConcurrency commandStages $ do
 | 
			
		||||
	repopath <- liftIO . absPath =<< fromRepo Git.repoPath
 | 
			
		||||
	repopath <- liftIO . absPath . fromRawFilePath =<< fromRepo Git.repoPath
 | 
			
		||||
	inrepops <- liftIO $ filter (dirContains repopath) <$> mapM absPath (importFiles o)
 | 
			
		||||
	unless (null inrepops) $ do
 | 
			
		||||
		giveup $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords inrepops
 | 
			
		||||
| 
						 | 
				
			
			@ -110,7 +110,7 @@ seek o@(RemoteImportOptions {}) = startConcurrency commandStages $ do
 | 
			
		|||
		giveup "That remote does not support imports."
 | 
			
		||||
	subdir <- maybe
 | 
			
		||||
		(pure Nothing)
 | 
			
		||||
		(Just <$$> inRepo . toTopFilePath)
 | 
			
		||||
		(Just <$$> inRepo . toTopFilePath . toRawFilePath)
 | 
			
		||||
		(importToSubDir o)
 | 
			
		||||
	seekRemote r (importToBranch o) subdir
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -566,7 +566,7 @@ getDirStatInfo o dir = do
 | 
			
		|||
  where
 | 
			
		||||
	initial = (emptyKeyInfo, emptyKeyInfo, emptyNumCopiesStats, M.empty)
 | 
			
		||||
	update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats, repodata) =
 | 
			
		||||
		ifM (matcher $ MatchingFile $ FileInfo file' file')
 | 
			
		||||
		ifM (matcher $ MatchingFile $ FileInfo file file)
 | 
			
		||||
			( do
 | 
			
		||||
				!presentdata' <- ifM (inAnnex key)
 | 
			
		||||
					( return $ addKey key presentdata
 | 
			
		||||
| 
						 | 
				
			
			@ -577,13 +577,11 @@ getDirStatInfo o dir = do
 | 
			
		|||
					then return (numcopiesstats, repodata)
 | 
			
		||||
					else do
 | 
			
		||||
						locs <- Remote.keyLocations key
 | 
			
		||||
						nc <- updateNumCopiesStats file' numcopiesstats locs
 | 
			
		||||
						nc <- updateNumCopiesStats (fromRawFilePath file) numcopiesstats locs
 | 
			
		||||
						return (nc, updateRepoData key locs repodata)
 | 
			
		||||
				return $! (presentdata', referenceddata', numcopiesstats', repodata')
 | 
			
		||||
			, return vs
 | 
			
		||||
			)
 | 
			
		||||
	  where
 | 
			
		||||
		file' = fromRawFilePath file
 | 
			
		||||
 | 
			
		||||
getTreeStatInfo :: InfoOptions -> Git.Ref -> Annex (Maybe StatInfo)
 | 
			
		||||
getTreeStatInfo o r = do
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -80,7 +80,7 @@ performNew file key = do
 | 
			
		|||
	-- Try to repopulate obj from an unmodified associated file.
 | 
			
		||||
	repopulate obj = modifyContent obj $ do
 | 
			
		||||
		g <- Annex.gitRepo
 | 
			
		||||
		fs <- map (`fromTopFilePath` g)
 | 
			
		||||
		fs <- map fromRawFilePath . map (`fromTopFilePath` g)
 | 
			
		||||
			<$> Database.Keys.getAssociatedFiles key
 | 
			
		||||
		mfile <- firstM (isUnmodified key) fs
 | 
			
		||||
		liftIO $ nukeFile obj
 | 
			
		||||
| 
						 | 
				
			
			@ -94,7 +94,7 @@ performNew file key = do
 | 
			
		|||
 | 
			
		||||
cleanupNew :: RawFilePath -> Key -> CommandCleanup
 | 
			
		||||
cleanupNew file key = do
 | 
			
		||||
	Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath (fromRawFilePath file))
 | 
			
		||||
	Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath file)
 | 
			
		||||
	return True
 | 
			
		||||
 | 
			
		||||
startOld :: RawFilePath -> CommandStart
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -199,7 +199,7 @@ compareChanges format changes = concatMap diff changes
 | 
			
		|||
getKeyLog :: Key -> [CommandParam] -> Annex ([RefChange], IO Bool)
 | 
			
		||||
getKeyLog key os = do
 | 
			
		||||
	top <- fromRepo Git.repoPath
 | 
			
		||||
	p <- liftIO $ relPathCwdToFile top
 | 
			
		||||
	p <- liftIO $ relPathCwdToFile $ fromRawFilePath top
 | 
			
		||||
	config <- Annex.getGitConfig
 | 
			
		||||
	let logfile = p </> fromRawFilePath (locationLogFile config key)
 | 
			
		||||
	getGitLog [logfile] (Param "--remove-empty" : os)
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -176,7 +176,8 @@ absRepo reference r
 | 
			
		|||
	| Git.repoIsUrl reference = return $ Git.Construct.localToUrl reference r
 | 
			
		||||
	| Git.repoIsUrl r = return r
 | 
			
		||||
	| otherwise = liftIO $ do
 | 
			
		||||
		r' <- Git.Construct.fromAbsPath =<< absPath (Git.repoPath r)
 | 
			
		||||
		r' <- Git.Construct.fromAbsPath
 | 
			
		||||
			=<< absPath (fromRawFilePath (Git.repoPath r))
 | 
			
		||||
		r'' <- safely $ flip Annex.eval Annex.gitRepo =<< Annex.new r'
 | 
			
		||||
		return (fromMaybe r' r'')
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -234,7 +235,7 @@ tryScan r
 | 
			
		|||
	  where
 | 
			
		||||
		remotecmd = "sh -c " ++ shellEscape
 | 
			
		||||
			(cddir ++ " && " ++ "git config --null --list")
 | 
			
		||||
		dir = Git.repoPath r
 | 
			
		||||
		dir = fromRawFilePath $ Git.repoPath r
 | 
			
		||||
		cddir
 | 
			
		||||
			| "/~" `isPrefixOf` dir =
 | 
			
		||||
				let (userhome, reldir) = span (/= '/') (drop 1 dir)
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -137,7 +137,7 @@ send ups fs = do
 | 
			
		|||
				mk <- lookupFile f
 | 
			
		||||
				case mk of
 | 
			
		||||
					Nothing -> noop
 | 
			
		||||
					Just k -> withObjectLoc k (addlist (fromRawFilePath f))
 | 
			
		||||
					Just k -> withObjectLoc k (addlist f)
 | 
			
		||||
			liftIO $ hClose h
 | 
			
		||||
			
 | 
			
		||||
			serverkey <- uftpKey
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -5,6 +5,8 @@
 | 
			
		|||
 - Licensed under the GNU AGPL version 3 or higher.
 | 
			
		||||
 -}
 | 
			
		||||
 | 
			
		||||
{-# LANGUAGE OverloadedStrings #-}
 | 
			
		||||
 | 
			
		||||
module Command.PostReceive where
 | 
			
		||||
 | 
			
		||||
import Command
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -123,7 +123,7 @@ cleanup file oldkey newkey = do
 | 
			
		|||
				writePointerFile file newkey mode
 | 
			
		||||
			stagePointerFile file mode =<< hashPointerFile newkey
 | 
			
		||||
			Database.Keys.removeAssociatedFile oldkey 
 | 
			
		||||
				=<< inRepo (toTopFilePath (fromRawFilePath file))
 | 
			
		||||
				=<< inRepo (toTopFilePath file)
 | 
			
		||||
		)
 | 
			
		||||
	whenM (inAnnex newkey) $
 | 
			
		||||
		logStatus newkey InfoPresent
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -24,7 +24,7 @@ seek = withNothing (commandAction start)
 | 
			
		|||
start :: CommandStart
 | 
			
		||||
start = starting "resolvemerge" (ActionItemOther Nothing) $ do
 | 
			
		||||
	us <- fromMaybe nobranch <$> inRepo Git.Branch.current
 | 
			
		||||
	d <- fromRepo Git.localGitDir
 | 
			
		||||
	d <- fromRawFilePath <$> fromRepo Git.localGitDir
 | 
			
		||||
	let merge_head = d </> "MERGE_HEAD"
 | 
			
		||||
	them <- fromMaybe (error nomergehead) . extractSha
 | 
			
		||||
		<$> liftIO (readFile merge_head)
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -70,7 +70,7 @@ smudge file = do
 | 
			
		|||
	case parseLinkTargetOrPointerLazy b of
 | 
			
		||||
		Nothing -> noop
 | 
			
		||||
		Just k -> do
 | 
			
		||||
			topfile <- inRepo (toTopFilePath file)
 | 
			
		||||
			topfile <- inRepo (toTopFilePath (toRawFilePath file))
 | 
			
		||||
			Database.Keys.addAssociatedFile k topfile
 | 
			
		||||
			void $ smudgeLog k topfile
 | 
			
		||||
	liftIO $ L.putStr b
 | 
			
		||||
| 
						 | 
				
			
			@ -141,7 +141,8 @@ clean file = do
 | 
			
		|||
	-- git diff can run the clean filter on files outside the
 | 
			
		||||
	-- repository; can't annex those
 | 
			
		||||
	fileoutsiderepo = do
 | 
			
		||||
	        repopath <- liftIO . absPath =<< fromRepo Git.repoPath
 | 
			
		||||
	        repopath <- liftIO . absPath . fromRawFilePath
 | 
			
		||||
			=<< fromRepo Git.repoPath
 | 
			
		||||
		filepath <- liftIO $ absPath file
 | 
			
		||||
		return $ not $ dirContains repopath filepath
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -204,7 +205,7 @@ update = do
 | 
			
		|||
 | 
			
		||||
updateSmudged :: Restage -> Annex ()
 | 
			
		||||
updateSmudged restage = streamSmudged $ \k topf -> do
 | 
			
		||||
	f <- toRawFilePath <$> fromRepo (fromTopFilePath topf)
 | 
			
		||||
	f <- fromRepo (fromTopFilePath topf)
 | 
			
		||||
	whenM (inAnnex k) $ do
 | 
			
		||||
		obj <- toRawFilePath <$> calcRepo (gitAnnexLocation k)
 | 
			
		||||
		unlessM (isJust <$> populatePointerFile restage k obj f) $
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -61,6 +61,6 @@ displayStatus (Renamed _ _) = noop
 | 
			
		|||
displayStatus s = do
 | 
			
		||||
	let c = statusChar s
 | 
			
		||||
	absf <- fromRepo $ fromTopFilePath (statusFile s)
 | 
			
		||||
	f <- liftIO $ relPathCwdToFile absf
 | 
			
		||||
	f <- liftIO $ relPathCwdToFile $ fromRawFilePath absf
 | 
			
		||||
	unlessM (showFullJSON $ JSONChunk [("status", [c]), ("file", f)]) $
 | 
			
		||||
		liftIO $ putStrLn $ [c] ++ " " ++ f
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -226,7 +226,7 @@ seek' o = do
 | 
			
		|||
 - of the repo. This also means that sync always acts on all files in the
 | 
			
		||||
 - repository, not just on a subdirectory. -}
 | 
			
		||||
prepMerge :: Annex ()
 | 
			
		||||
prepMerge = Annex.changeDirectory =<< fromRepo Git.repoPath
 | 
			
		||||
prepMerge = Annex.changeDirectory . fromRawFilePath =<< fromRepo Git.repoPath
 | 
			
		||||
 | 
			
		||||
mergeConfig :: [Git.Merge.MergeConfig]	
 | 
			
		||||
mergeConfig = 
 | 
			
		||||
| 
						 | 
				
			
			@ -409,7 +409,7 @@ importRemote o mergeconfig remote currbranch
 | 
			
		|||
			let branch = Git.Ref b
 | 
			
		||||
			let subdir = if null s
 | 
			
		||||
				then Nothing
 | 
			
		||||
				else Just (asTopFilePath s)
 | 
			
		||||
				else Just (asTopFilePath (toRawFilePath s))
 | 
			
		||||
			Command.Import.seekRemote remote branch subdir
 | 
			
		||||
			void $ mergeRemote remote currbranch mergeconfig
 | 
			
		||||
				(resolveMergeOverride o)
 | 
			
		||||
| 
						 | 
				
			
			@ -468,7 +468,7 @@ pushRemote o remote (Just branch, _) = stopUnless (pure (pushOption o) <&&> need
 | 
			
		|||
			( liftIO $ do
 | 
			
		||||
				p <- readProgramFile
 | 
			
		||||
				boolSystem' p [Param "post-receive"]
 | 
			
		||||
					(\cp -> cp { cwd = Just wt })
 | 
			
		||||
					(\cp -> cp { cwd = Just (fromRawFilePath wt) })
 | 
			
		||||
			, return True
 | 
			
		||||
			)
 | 
			
		||||
	  where
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -28,22 +28,22 @@ seek ps = (withFilesInGit $ commandAction . whenAnnexed start) =<< workTreeItems
 | 
			
		|||
start :: RawFilePath -> Key -> CommandStart
 | 
			
		||||
start file key = stopUnless (inAnnex key) $
 | 
			
		||||
	starting "unannex" (mkActionItem (key, file)) $
 | 
			
		||||
		perform (fromRawFilePath file) key
 | 
			
		||||
		perform file key
 | 
			
		||||
 | 
			
		||||
perform :: FilePath -> Key -> CommandPerform
 | 
			
		||||
perform :: RawFilePath -> Key -> CommandPerform
 | 
			
		||||
perform file key = do
 | 
			
		||||
	liftIO $ removeFile file
 | 
			
		||||
	liftIO $ removeFile (fromRawFilePath file)
 | 
			
		||||
	inRepo $ Git.Command.run
 | 
			
		||||
		[ Param "rm"
 | 
			
		||||
		, Param "--cached"
 | 
			
		||||
		, Param "--force"
 | 
			
		||||
		, Param "--quiet"
 | 
			
		||||
		, Param "--"
 | 
			
		||||
		, File file
 | 
			
		||||
		, File (fromRawFilePath file)
 | 
			
		||||
		]
 | 
			
		||||
	next $ cleanup file key
 | 
			
		||||
 | 
			
		||||
cleanup :: FilePath -> Key -> CommandCleanup
 | 
			
		||||
cleanup :: RawFilePath -> Key -> CommandCleanup
 | 
			
		||||
cleanup file key = do
 | 
			
		||||
	Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath file)
 | 
			
		||||
	src <- calcRepo $ gitAnnexLocation key
 | 
			
		||||
| 
						 | 
				
			
			@ -61,11 +61,12 @@ cleanup file key = do
 | 
			
		|||
		, copyfrom src
 | 
			
		||||
		)
 | 
			
		||||
  where
 | 
			
		||||
	file' = fromRawFilePath file
 | 
			
		||||
	copyfrom src = 
 | 
			
		||||
		thawContent file `after` liftIO (copyFileExternal CopyAllMetaData src file)
 | 
			
		||||
		thawContent file' `after` liftIO (copyFileExternal CopyAllMetaData src file')
 | 
			
		||||
	hardlinkfrom src =
 | 
			
		||||
		-- creating a hard link could fall; fall back to copying
 | 
			
		||||
		ifM (liftIO $ catchBoolIO $ createLink src file >> return True)
 | 
			
		||||
		ifM (liftIO $ catchBoolIO $ createLink src file' >> return True)
 | 
			
		||||
			( return True
 | 
			
		||||
			, copyfrom src
 | 
			
		||||
			)
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -51,7 +51,7 @@ perform p = do
 | 
			
		|||
	-- Get the reversed diff that needs to be applied to undo.
 | 
			
		||||
	(diff, cleanup) <- inRepo $
 | 
			
		||||
		diffLog [Param "-R", Param "--", Param p]
 | 
			
		||||
	top <- inRepo $ toTopFilePath p
 | 
			
		||||
	top <- inRepo $ toTopFilePath $ toRawFilePath p
 | 
			
		||||
	let diff' = filter (`isDiffOf` top) diff
 | 
			
		||||
	liftIO $ streamUpdateIndex g (map stageDiffTreeItem diff')
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -59,7 +59,8 @@ perform p = do
 | 
			
		|||
	-- and then any adds. This order is necessary to handle eg, removing
 | 
			
		||||
	-- a directory and replacing it with a file.
 | 
			
		||||
	let (removals, adds) = partition (\di -> dstsha di == nullSha) diff'
 | 
			
		||||
	let mkrel di = liftIO $ relPathCwdToFile $ fromTopFilePath (file di) g
 | 
			
		||||
	let mkrel di = liftIO $ relPathCwdToFile $ fromRawFilePath $
 | 
			
		||||
		fromTopFilePath (file di) g
 | 
			
		||||
 | 
			
		||||
	forM_ removals $ \di -> do
 | 
			
		||||
		f <- mkrel di
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -29,7 +29,7 @@ check = do
 | 
			
		|||
	b <- current_branch
 | 
			
		||||
	when (b == Annex.Branch.name) $ giveup $
 | 
			
		||||
		"cannot uninit when the " ++ Git.fromRef b ++ " branch is checked out"
 | 
			
		||||
	top <- fromRepo Git.repoPath
 | 
			
		||||
	top <- fromRawFilePath <$> fromRepo Git.repoPath
 | 
			
		||||
	currdir <- liftIO getCurrentDirectory
 | 
			
		||||
	whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $
 | 
			
		||||
		giveup "can only run uninit from the top of the git repository"
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -57,5 +57,5 @@ perform dest key = do
 | 
			
		|||
cleanup ::  RawFilePath -> Key -> Maybe FileMode -> CommandCleanup
 | 
			
		||||
cleanup dest key destmode = do
 | 
			
		||||
	stagePointerFile dest destmode =<< hashPointerFile key
 | 
			
		||||
	Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath (fromRawFilePath dest))
 | 
			
		||||
	Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath dest)
 | 
			
		||||
	return True
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -207,7 +207,7 @@ withKeysReferenced' mdir initial a = do
 | 
			
		|||
			( return ([], return True)
 | 
			
		||||
			, do
 | 
			
		||||
				top <- fromRepo Git.repoPath
 | 
			
		||||
				inRepo $ LsFiles.allFiles [toRawFilePath top]
 | 
			
		||||
				inRepo $ LsFiles.allFiles [top]
 | 
			
		||||
			)
 | 
			
		||||
		Just dir -> inRepo $ LsFiles.inRepo [toRawFilePath dir]
 | 
			
		||||
	go v [] = return v
 | 
			
		||||
| 
						 | 
				
			
			@ -283,7 +283,7 @@ associatedFilesFilter = filterM go
 | 
			
		|||
	checkunmodified _ [] = return True
 | 
			
		||||
	checkunmodified cs (f:fs) = do
 | 
			
		||||
		relf <- fromRepo $ fromTopFilePath f
 | 
			
		||||
		ifM (sameInodeCache relf cs)
 | 
			
		||||
		ifM (sameInodeCache (fromRawFilePath relf) cs)
 | 
			
		||||
			( return False
 | 
			
		||||
			, checkunmodified cs fs
 | 
			
		||||
			)
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -99,7 +99,7 @@ checkoutViewBranch view mkbranch = do
 | 
			
		|||
		 - and this pollutes the view, so remove them.
 | 
			
		||||
		 - (However, emptry directories used by submodules are not
 | 
			
		||||
		 - removed.) -}
 | 
			
		||||
		top <- liftIO . absPath =<< fromRepo Git.repoPath
 | 
			
		||||
		top <- liftIO . absPath . fromRawFilePath =<< fromRepo Git.repoPath
 | 
			
		||||
		(l, cleanup) <- inRepo $
 | 
			
		||||
			LsFiles.notInRepoIncludingEmptyDirectories False
 | 
			
		||||
				[toRawFilePath top]
 | 
			
		||||
| 
						 | 
				
			
			@ -110,8 +110,8 @@ checkoutViewBranch view mkbranch = do
 | 
			
		|||
	return ok
 | 
			
		||||
  where
 | 
			
		||||
	removeemptydir top d = do
 | 
			
		||||
		p <- inRepo $ toTopFilePath $ fromRawFilePath d
 | 
			
		||||
		liftIO $ tryIO $ removeDirectory (top </> getTopFilePath p)
 | 
			
		||||
		p <- inRepo $ toTopFilePath d
 | 
			
		||||
		liftIO $ tryIO $ removeDirectory (top </> fromRawFilePath (getTopFilePath p))
 | 
			
		||||
	cwdmissing top = unlines
 | 
			
		||||
		[ "This view does not include the subdirectory you are currently in."
 | 
			
		||||
		, "Perhaps you should:  cd " ++ top
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -145,7 +145,7 @@ updateFromLog db (oldtree, currtree) = do
 | 
			
		|||
		recordAnnexBranchTree db currtree
 | 
			
		||||
		flushDbQueue db
 | 
			
		||||
  where
 | 
			
		||||
	go ti = case extLogFileKey remoteContentIdentifierExt (toRawFilePath (getTopFilePath (DiffTree.file ti))) of
 | 
			
		||||
	go ti = case extLogFileKey remoteContentIdentifierExt (getTopFilePath (DiffTree.file ti)) of
 | 
			
		||||
		Nothing -> return ()
 | 
			
		||||
		Just k -> do
 | 
			
		||||
			l <- Log.getContentIdentifiers k
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -220,7 +220,7 @@ mkExportDiffUpdater removeold addnew h srcek dstek i = do
 | 
			
		|||
		Nothing -> return ()
 | 
			
		||||
		Just k -> liftIO $ addnew h (asKey k) loc
 | 
			
		||||
  where
 | 
			
		||||
	loc = mkExportLocation $ toRawFilePath $ getTopFilePath $ Git.DiffTree.file i
 | 
			
		||||
	loc = mkExportLocation $ getTopFilePath $ Git.DiffTree.file i
 | 
			
		||||
 | 
			
		||||
runExportDiffUpdater :: ExportDiffUpdater -> ExportHandle -> Sha -> Sha -> Annex ()
 | 
			
		||||
runExportDiffUpdater updater h old new = do
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -279,7 +279,7 @@ reconcileStaged qh = do
 | 
			
		|||
		((':':_srcmode):dstmode:_srcsha:dstsha:_change:[])
 | 
			
		||||
			-- Only want files, not symlinks
 | 
			
		||||
			| dstmode /= decodeBS' (fmtTreeItemType TreeSymlink) -> do
 | 
			
		||||
				maybe noop (reconcile (asTopFilePath file)) 
 | 
			
		||||
				maybe noop (reconcile (asTopFilePath (toRawFilePath file)))
 | 
			
		||||
					=<< catKey (Ref dstsha)
 | 
			
		||||
				procdiff rest True
 | 
			
		||||
			| otherwise -> procdiff rest changed
 | 
			
		||||
| 
						 | 
				
			
			@ -294,7 +294,7 @@ reconcileStaged qh = do
 | 
			
		|||
		caches <- liftIO $ SQL.getInodeCaches ikey (SQL.ReadHandle qh)
 | 
			
		||||
		keyloc <- calcRepo (gitAnnexLocation key)
 | 
			
		||||
		keypopulated <- sameInodeCache keyloc caches
 | 
			
		||||
		p <- fromRepo $ toRawFilePath . fromTopFilePath file
 | 
			
		||||
		p <- fromRepo $ fromTopFilePath file
 | 
			
		||||
		filepopulated <- sameInodeCache (fromRawFilePath p) caches
 | 
			
		||||
		case (keypopulated, filepopulated) of
 | 
			
		||||
			(True, False) ->
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -17,6 +17,7 @@ import Database.Types
 | 
			
		|||
import Database.Handle
 | 
			
		||||
import qualified Database.Queue as H
 | 
			
		||||
import Utility.InodeCache
 | 
			
		||||
import Utility.FileSystemEncoding
 | 
			
		||||
import Git.FilePath
 | 
			
		||||
 | 
			
		||||
import Database.Persist.Sql
 | 
			
		||||
| 
						 | 
				
			
			@ -69,7 +70,7 @@ addAssociatedFile ik f = queueDb $ do
 | 
			
		|||
	deleteWhere [AssociatedFile ==. af, AssociatedKey !=. ik]
 | 
			
		||||
	void $ insertUnique $ Associated ik af
 | 
			
		||||
  where
 | 
			
		||||
	af = toSFilePath (getTopFilePath f)
 | 
			
		||||
	af = toSFilePath (fromRawFilePath (getTopFilePath f))
 | 
			
		||||
 | 
			
		||||
-- Does not remove any old association for a file, but less expensive
 | 
			
		||||
-- than addAssociatedFile. Calling dropAllAssociatedFiles first and then
 | 
			
		||||
| 
						 | 
				
			
			@ -77,7 +78,7 @@ addAssociatedFile ik f = queueDb $ do
 | 
			
		|||
addAssociatedFileFast :: IKey -> TopFilePath -> WriteHandle -> IO ()
 | 
			
		||||
addAssociatedFileFast ik f = queueDb $ void $ insertUnique $ Associated ik af
 | 
			
		||||
  where
 | 
			
		||||
	af = toSFilePath (getTopFilePath f)
 | 
			
		||||
	af = toSFilePath (fromRawFilePath (getTopFilePath f))
 | 
			
		||||
 | 
			
		||||
dropAllAssociatedFiles :: WriteHandle -> IO ()
 | 
			
		||||
dropAllAssociatedFiles = queueDb $
 | 
			
		||||
| 
						 | 
				
			
			@ -88,7 +89,7 @@ dropAllAssociatedFiles = queueDb $
 | 
			
		|||
getAssociatedFiles :: IKey -> ReadHandle -> IO [TopFilePath]
 | 
			
		||||
getAssociatedFiles ik = readDb $ do
 | 
			
		||||
	l <- selectList [AssociatedKey ==. ik] []
 | 
			
		||||
	return $ map (asTopFilePath . fromSFilePath . associatedFile . entityVal) l
 | 
			
		||||
	return $ map (asTopFilePath . toRawFilePath . fromSFilePath . associatedFile . entityVal) l
 | 
			
		||||
 | 
			
		||||
{- Gets any keys that are on record as having a particular associated file.
 | 
			
		||||
 - (Should be one or none but the database doesn't enforce that.) -}
 | 
			
		||||
| 
						 | 
				
			
			@ -97,13 +98,13 @@ getAssociatedKey f = readDb $ do
 | 
			
		|||
	l <- selectList [AssociatedFile ==. af] []
 | 
			
		||||
	return $ map (associatedKey . entityVal) l
 | 
			
		||||
  where
 | 
			
		||||
	af = toSFilePath (getTopFilePath f)
 | 
			
		||||
	af = toSFilePath (fromRawFilePath (getTopFilePath f))
 | 
			
		||||
 | 
			
		||||
removeAssociatedFile :: IKey -> TopFilePath -> WriteHandle -> IO ()
 | 
			
		||||
removeAssociatedFile ik f = queueDb $
 | 
			
		||||
	deleteWhere [AssociatedKey ==. ik, AssociatedFile ==. af]
 | 
			
		||||
  where
 | 
			
		||||
	af = toSFilePath (getTopFilePath f)
 | 
			
		||||
	af = toSFilePath (fromRawFilePath (getTopFilePath f))
 | 
			
		||||
 | 
			
		||||
addInodeCaches :: IKey -> [InodeCache] -> WriteHandle -> IO ()
 | 
			
		||||
addInodeCaches ik is = queueDb $
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
							
								
								
									
										39
									
								
								Git.hs
									
										
									
									
									
								
							
							
						
						
									
										39
									
								
								Git.hs
									
										
									
									
									
								
							| 
						 | 
				
			
			@ -51,35 +51,35 @@ import Utility.FileMode
 | 
			
		|||
repoDescribe :: Repo -> String
 | 
			
		||||
repoDescribe Repo { remoteName = Just name } = name
 | 
			
		||||
repoDescribe Repo { location = Url url } = show url
 | 
			
		||||
repoDescribe Repo { location = Local { worktree = Just dir } } = dir
 | 
			
		||||
repoDescribe Repo { location = Local { gitdir = dir } } = dir
 | 
			
		||||
repoDescribe Repo { location = LocalUnknown dir } = dir
 | 
			
		||||
repoDescribe Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir
 | 
			
		||||
repoDescribe Repo { location = Local { gitdir = dir } } = fromRawFilePath dir
 | 
			
		||||
repoDescribe Repo { location = LocalUnknown dir } = fromRawFilePath dir
 | 
			
		||||
repoDescribe Repo { location = Unknown } = "UNKNOWN"
 | 
			
		||||
 | 
			
		||||
{- Location of the repo, either as a path or url. -}
 | 
			
		||||
repoLocation :: Repo -> String
 | 
			
		||||
repoLocation Repo { location = Url url } = show url
 | 
			
		||||
repoLocation Repo { location = Local { worktree = Just dir } } = dir
 | 
			
		||||
repoLocation Repo { location = Local { gitdir = dir } } = dir
 | 
			
		||||
repoLocation Repo { location = LocalUnknown dir } = dir
 | 
			
		||||
repoLocation Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir
 | 
			
		||||
repoLocation Repo { location = Local { gitdir = dir } } = fromRawFilePath dir
 | 
			
		||||
repoLocation Repo { location = LocalUnknown dir } = fromRawFilePath dir
 | 
			
		||||
repoLocation Repo { location = Unknown } = error "unknown repoLocation"
 | 
			
		||||
 | 
			
		||||
{- Path to a repository. For non-bare, this is the worktree, for bare, 
 | 
			
		||||
 - it's the gitdir, and for URL repositories, is the path on the remote
 | 
			
		||||
 - host. -}
 | 
			
		||||
repoPath :: Repo -> FilePath
 | 
			
		||||
repoPath Repo { location = Url u } = unEscapeString $ uriPath u
 | 
			
		||||
repoPath :: Repo -> RawFilePath
 | 
			
		||||
repoPath Repo { location = Url u } = toRawFilePath $ unEscapeString $ uriPath u
 | 
			
		||||
repoPath Repo { location = Local { worktree = Just d } } = d
 | 
			
		||||
repoPath Repo { location = Local { gitdir = d } } = d
 | 
			
		||||
repoPath Repo { location = LocalUnknown dir } = dir
 | 
			
		||||
repoPath Repo { location = Unknown } = error "unknown repoPath"
 | 
			
		||||
 | 
			
		||||
repoWorkTree :: Repo -> Maybe FilePath
 | 
			
		||||
repoWorkTree :: Repo -> Maybe RawFilePath
 | 
			
		||||
repoWorkTree Repo { location = Local { worktree = Just d } } = Just d
 | 
			
		||||
repoWorkTree _ = Nothing
 | 
			
		||||
 | 
			
		||||
{- Path to a local repository's .git directory. -}
 | 
			
		||||
localGitDir :: Repo -> FilePath
 | 
			
		||||
localGitDir :: Repo -> RawFilePath
 | 
			
		||||
localGitDir Repo { location = Local { gitdir = d } } = d
 | 
			
		||||
localGitDir _ = error "unknown localGitDir"
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -132,16 +132,17 @@ assertLocal repo action
 | 
			
		|||
attributes :: Repo -> FilePath
 | 
			
		||||
attributes repo
 | 
			
		||||
	| repoIsLocalBare repo = attributesLocal repo
 | 
			
		||||
	| otherwise = repoPath repo </> ".gitattributes"
 | 
			
		||||
	| otherwise = fromRawFilePath (repoPath repo) </> ".gitattributes"
 | 
			
		||||
 | 
			
		||||
attributesLocal :: Repo -> FilePath
 | 
			
		||||
attributesLocal repo = localGitDir repo </> "info" </> "attributes"
 | 
			
		||||
attributesLocal repo = fromRawFilePath (localGitDir repo)
 | 
			
		||||
	</> "info" </> "attributes"
 | 
			
		||||
 | 
			
		||||
{- Path to a given hook script in a repository, only if the hook exists
 | 
			
		||||
 - and is executable. -}
 | 
			
		||||
hookPath :: String -> Repo -> IO (Maybe FilePath)
 | 
			
		||||
hookPath script repo = do
 | 
			
		||||
	let hook = localGitDir repo </> "hooks" </> script
 | 
			
		||||
	let hook = fromRawFilePath (localGitDir repo) </> "hooks" </> script
 | 
			
		||||
	ifM (catchBoolIO $ isexecutable hook)
 | 
			
		||||
		( return $ Just hook , return Nothing )
 | 
			
		||||
  where
 | 
			
		||||
| 
						 | 
				
			
			@ -157,22 +158,22 @@ relPath = adjustPath torel
 | 
			
		|||
  where
 | 
			
		||||
	torel p = do
 | 
			
		||||
		p' <- relPathCwdToFile p
 | 
			
		||||
		if null p'
 | 
			
		||||
			then return "."
 | 
			
		||||
			else return p'
 | 
			
		||||
		return $ if null p' then "." else p'
 | 
			
		||||
 | 
			
		||||
{- Adusts the path to a local Repo using the provided function. -}
 | 
			
		||||
adjustPath :: (FilePath -> IO FilePath) -> Repo -> IO Repo
 | 
			
		||||
adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do
 | 
			
		||||
	d' <- f d
 | 
			
		||||
	w' <- maybe (pure Nothing) (Just <$$> f) w
 | 
			
		||||
	d' <- f' d
 | 
			
		||||
	w' <- maybe (pure Nothing) (Just <$$> f') w
 | 
			
		||||
	return $ r 
 | 
			
		||||
		{ location = l 
 | 
			
		||||
			{ gitdir = d'
 | 
			
		||||
			, worktree = w'
 | 
			
		||||
			}
 | 
			
		||||
		}
 | 
			
		||||
  where
 | 
			
		||||
	f' v = toRawFilePath <$> f (fromRawFilePath v)
 | 
			
		||||
adjustPath f r@(Repo { location = LocalUnknown d }) = do
 | 
			
		||||
	d' <- f d
 | 
			
		||||
	d' <- toRawFilePath <$> f (fromRawFilePath d)
 | 
			
		||||
	return $ r { location = LocalUnknown d' }
 | 
			
		||||
adjustPath _ r = pure r
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -24,10 +24,10 @@ gitCommandLine params r@(Repo { location = l@(Local { } ) }) =
 | 
			
		|||
  where
 | 
			
		||||
	setdir
 | 
			
		||||
		| gitEnvOverridesGitDir r = []
 | 
			
		||||
		| otherwise = [Param $ "--git-dir=" ++ gitdir l]
 | 
			
		||||
		| otherwise = [Param $ "--git-dir=" ++ fromRawFilePath (gitdir l)]
 | 
			
		||||
	settree = case worktree l of
 | 
			
		||||
		Nothing -> []
 | 
			
		||||
		Just t -> [Param $ "--work-tree=" ++ t]
 | 
			
		||||
		Just t -> [Param $ "--work-tree=" ++ fromRawFilePath t]
 | 
			
		||||
gitCommandLine _ repo = assertLocal repo $ error "internal"
 | 
			
		||||
 | 
			
		||||
{- Runs git in the specified repo. -}
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -13,6 +13,7 @@ import qualified Data.Map as M
 | 
			
		|||
import qualified Data.ByteString as S
 | 
			
		||||
import qualified Data.ByteString.Char8 as S8
 | 
			
		||||
import Data.Char
 | 
			
		||||
import qualified System.FilePath.ByteString as P
 | 
			
		||||
 | 
			
		||||
import Common
 | 
			
		||||
import Git
 | 
			
		||||
| 
						 | 
				
			
			@ -61,7 +62,7 @@ read' repo = go repo
 | 
			
		|||
	  where
 | 
			
		||||
		params = ["config", "--null", "--list"]
 | 
			
		||||
		p = (proc "git" params)
 | 
			
		||||
			{ cwd = Just d
 | 
			
		||||
			{ cwd = Just (fromRawFilePath d)
 | 
			
		||||
			, env = gitEnv repo
 | 
			
		||||
			}
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -114,13 +115,13 @@ store' k v repo = repo
 | 
			
		|||
 -}
 | 
			
		||||
updateLocation :: Repo -> IO Repo
 | 
			
		||||
updateLocation r@(Repo { location = LocalUnknown d })
 | 
			
		||||
	| isBare r = ifM (doesDirectoryExist dotgit)
 | 
			
		||||
	| isBare r = ifM (doesDirectoryExist (fromRawFilePath dotgit))
 | 
			
		||||
			( updateLocation' r $ Local dotgit Nothing
 | 
			
		||||
			, updateLocation' r $ Local d Nothing
 | 
			
		||||
			)
 | 
			
		||||
	| otherwise = updateLocation' r $ Local dotgit (Just d)
 | 
			
		||||
  where
 | 
			
		||||
	dotgit = (d </> ".git")
 | 
			
		||||
	dotgit = d P.</> ".git"
 | 
			
		||||
updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l
 | 
			
		||||
updateLocation r = return r
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -130,9 +131,9 @@ updateLocation' r l = do
 | 
			
		|||
		Nothing -> return l
 | 
			
		||||
		Just (ConfigValue d) -> do
 | 
			
		||||
			{- core.worktree is relative to the gitdir -}
 | 
			
		||||
			top <- absPath $ gitdir l
 | 
			
		||||
			top <- absPath $ fromRawFilePath (gitdir l)
 | 
			
		||||
			let p = absPathFrom top (fromRawFilePath d)
 | 
			
		||||
			return $ l { worktree = Just p }
 | 
			
		||||
			return $ l { worktree = Just (toRawFilePath p) }
 | 
			
		||||
	return $ r { location = l' }
 | 
			
		||||
 | 
			
		||||
{- Parses git config --list or git config --null --list output into a
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -62,7 +62,7 @@ fromAbsPath dir
 | 
			
		|||
	| otherwise =
 | 
			
		||||
		error $ "internal error, " ++ dir ++ " is not absolute"
 | 
			
		||||
  where
 | 
			
		||||
	ret = pure . newFrom . LocalUnknown
 | 
			
		||||
	ret = pure . newFrom . LocalUnknown . toRawFilePath
 | 
			
		||||
	canondir = dropTrailingPathSeparator dir
 | 
			
		||||
	{- When dir == "foo/.git", git looks for "foo/.git/.git",
 | 
			
		||||
	 - and failing that, uses "foo" as the repository. -}
 | 
			
		||||
| 
						 | 
				
			
			@ -117,7 +117,7 @@ localToUrl reference r
 | 
			
		|||
				[ Url.scheme reference
 | 
			
		||||
				, "//"
 | 
			
		||||
				, auth
 | 
			
		||||
				, repoPath r
 | 
			
		||||
				, fromRawFilePath (repoPath r)
 | 
			
		||||
				]
 | 
			
		||||
			in r { location = Url $ fromJust $ parseURI absurl }
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -154,7 +154,7 @@ fromRemoteLocation s repo = gen $ parseRemoteLocation s repo
 | 
			
		|||
fromRemotePath :: FilePath -> Repo -> IO Repo
 | 
			
		||||
fromRemotePath dir repo = do
 | 
			
		||||
	dir' <- expandTilde dir
 | 
			
		||||
	fromPath $ repoPath repo </> dir'
 | 
			
		||||
	fromPath $ fromRawFilePath (repoPath repo) </> dir'
 | 
			
		||||
 | 
			
		||||
{- Git remotes can have a directory that is specified relative
 | 
			
		||||
 - to the user's home directory, or that contains tilde expansions.
 | 
			
		||||
| 
						 | 
				
			
			@ -204,7 +204,7 @@ checkForRepo dir =
 | 
			
		|||
  where
 | 
			
		||||
	check test cont = maybe cont (return . Just) =<< test
 | 
			
		||||
	checkdir c = ifM c
 | 
			
		||||
		( return $ Just $ LocalUnknown dir
 | 
			
		||||
		( return $ Just $ LocalUnknown $ toRawFilePath dir
 | 
			
		||||
		, return Nothing
 | 
			
		||||
		)
 | 
			
		||||
	isRepo = checkdir $ 
 | 
			
		||||
| 
						 | 
				
			
			@ -224,9 +224,9 @@ checkForRepo dir =
 | 
			
		|||
			catchDefaultIO "" (readFile $ dir </> ".git")
 | 
			
		||||
		return $ if gitdirprefix `isPrefixOf` c
 | 
			
		||||
			then Just $ Local 
 | 
			
		||||
				{ gitdir = absPathFrom dir $
 | 
			
		||||
				{ gitdir = toRawFilePath $ absPathFrom dir $
 | 
			
		||||
					drop (length gitdirprefix) c
 | 
			
		||||
				, worktree = Just dir
 | 
			
		||||
				, worktree = Just (toRawFilePath dir)
 | 
			
		||||
				}
 | 
			
		||||
			else Nothing
 | 
			
		||||
	  where
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -37,7 +37,7 @@ get = do
 | 
			
		|||
	gd <- getpathenv "GIT_DIR"
 | 
			
		||||
	r <- configure gd =<< fromCwd
 | 
			
		||||
	prefix <- getpathenv "GIT_PREFIX"
 | 
			
		||||
	wt <- maybe (worktree $ location r) Just
 | 
			
		||||
	wt <- maybe (fromRawFilePath <$> worktree (location r)) Just
 | 
			
		||||
		<$> getpathenvprefix "GIT_WORK_TREE" prefix
 | 
			
		||||
	case wt of
 | 
			
		||||
		Nothing -> return r
 | 
			
		||||
| 
						 | 
				
			
			@ -68,13 +68,18 @@ get = do
 | 
			
		|||
		absd <- absPath d
 | 
			
		||||
		curr <- getCurrentDirectory
 | 
			
		||||
		r <- Git.Config.read $ newFrom $
 | 
			
		||||
			Local { gitdir = absd, worktree = Just curr }
 | 
			
		||||
			Local
 | 
			
		||||
				{ gitdir = toRawFilePath absd
 | 
			
		||||
				, worktree = Just (toRawFilePath curr)
 | 
			
		||||
				}
 | 
			
		||||
		return $ if Git.Config.isBare r
 | 
			
		||||
			then r { location = (location r) { worktree = Nothing } }
 | 
			
		||||
			else r
 | 
			
		||||
 | 
			
		||||
	configure Nothing Nothing = giveup "Not in a git repository."
 | 
			
		||||
 | 
			
		||||
	addworktree w r = changelocation r $
 | 
			
		||||
		Local { gitdir = gitdir (location r), worktree = w }
 | 
			
		||||
	addworktree w r = changelocation r $ Local
 | 
			
		||||
		{ gitdir = gitdir (location r)
 | 
			
		||||
		, worktree = fmap toRawFilePath w
 | 
			
		||||
		}
 | 
			
		||||
	changelocation r l = r { location = l }
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -31,9 +31,9 @@ import qualified Git.Ref
 | 
			
		|||
{- Checks if the DiffTreeItem modifies a file with a given name
 | 
			
		||||
 - or under a directory by that name. -}
 | 
			
		||||
isDiffOf :: DiffTreeItem -> TopFilePath -> Bool
 | 
			
		||||
isDiffOf diff f = case getTopFilePath f of
 | 
			
		||||
isDiffOf diff f = case fromRawFilePath (getTopFilePath f) of
 | 
			
		||||
	"" -> True -- top of repo contains all
 | 
			
		||||
	d -> d `dirContains` getTopFilePath (file diff)
 | 
			
		||||
	d -> d `dirContains` fromRawFilePath (getTopFilePath (file diff))
 | 
			
		||||
 | 
			
		||||
{- Diffs two tree Refs. -}
 | 
			
		||||
diffTree :: Ref -> Ref -> Repo -> IO ([DiffTreeItem], IO Bool)
 | 
			
		||||
| 
						 | 
				
			
			@ -113,7 +113,7 @@ parseDiffRaw l = go l
 | 
			
		|||
		, srcsha = fromMaybe (error "bad srcsha") $ extractSha ssha
 | 
			
		||||
		, dstsha = fromMaybe (error "bad dstsha") $ extractSha dsha
 | 
			
		||||
		, status = s
 | 
			
		||||
		, file = asTopFilePath $ fromRawFilePath $ fromInternalGitPath $ Git.Filename.decode $ toRawFilePath f
 | 
			
		||||
		, file = asTopFilePath $ fromInternalGitPath $ Git.Filename.decode $ toRawFilePath f
 | 
			
		||||
		}
 | 
			
		||||
	  where
 | 
			
		||||
		readmode = fst . Prelude.head . readOct
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -30,8 +30,10 @@ addGitEnv g var val = adjustGitEnv g (addEntry var val)
 | 
			
		|||
 - and a copy of the rest of the system environment. -}
 | 
			
		||||
propGitEnv :: Repo -> IO [(String, String)]
 | 
			
		||||
propGitEnv g = do
 | 
			
		||||
	g' <- addGitEnv g "GIT_DIR" (localGitDir g)
 | 
			
		||||
	g'' <- maybe (pure g') (addGitEnv g' "GIT_WORK_TREE") (repoWorkTree g)
 | 
			
		||||
	g' <- addGitEnv g "GIT_DIR" (fromRawFilePath (localGitDir g))
 | 
			
		||||
	g'' <- maybe (pure g')
 | 
			
		||||
		(addGitEnv g' "GIT_WORK_TREE" . fromRawFilePath)
 | 
			
		||||
		(repoWorkTree g)
 | 
			
		||||
	return $ fromMaybe [] (gitEnv g'')
 | 
			
		||||
 | 
			
		||||
{- Use with any action that makes a commit to set metadata. -}
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -5,7 +5,7 @@
 | 
			
		|||
 - top of the repository even when run in a subdirectory. Adding some
 | 
			
		||||
 - types helps keep that straight.
 | 
			
		||||
 -
 | 
			
		||||
 - Copyright 2012-2013 Joey Hess <id@joeyh.name>
 | 
			
		||||
 - Copyright 2012-2019 Joey Hess <id@joeyh.name>
 | 
			
		||||
 -
 | 
			
		||||
 - Licensed under the GNU AGPL version 3 or higher.
 | 
			
		||||
 -}
 | 
			
		||||
| 
						 | 
				
			
			@ -31,13 +31,14 @@ module Git.FilePath (
 | 
			
		|||
import Common
 | 
			
		||||
import Git
 | 
			
		||||
 | 
			
		||||
import qualified System.FilePath.Posix
 | 
			
		||||
import qualified System.FilePath.ByteString as P
 | 
			
		||||
import qualified System.FilePath.Posix.ByteString
 | 
			
		||||
import GHC.Generics
 | 
			
		||||
import Control.DeepSeq
 | 
			
		||||
import qualified Data.ByteString as S
 | 
			
		||||
 | 
			
		||||
{- A RawFilePath, relative to the top of the git repository. -}
 | 
			
		||||
newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath }
 | 
			
		||||
newtype TopFilePath = TopFilePath { getTopFilePath :: RawFilePath }
 | 
			
		||||
	deriving (Show, Eq, Ord, Generic)
 | 
			
		||||
 | 
			
		||||
instance NFData TopFilePath
 | 
			
		||||
| 
						 | 
				
			
			@ -49,19 +50,20 @@ data BranchFilePath = BranchFilePath Ref TopFilePath
 | 
			
		|||
{- Git uses the branch:file form to refer to a BranchFilePath -}
 | 
			
		||||
descBranchFilePath :: BranchFilePath -> S.ByteString
 | 
			
		||||
descBranchFilePath (BranchFilePath b f) =
 | 
			
		||||
	encodeBS' (fromRef b) <> ":" <> toRawFilePath (getTopFilePath f)
 | 
			
		||||
	encodeBS' (fromRef b) <> ":" <> getTopFilePath f
 | 
			
		||||
 | 
			
		||||
{- Path to a TopFilePath, within the provided git repo. -}
 | 
			
		||||
fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath
 | 
			
		||||
fromTopFilePath p repo = combine (repoPath repo) (getTopFilePath p)
 | 
			
		||||
fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath
 | 
			
		||||
fromTopFilePath p repo = P.combine (repoPath repo) (getTopFilePath p)
 | 
			
		||||
 | 
			
		||||
{- The input FilePath can be absolute, or relative to the CWD. -}
 | 
			
		||||
toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath
 | 
			
		||||
toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file
 | 
			
		||||
toTopFilePath :: RawFilePath -> Git.Repo -> IO TopFilePath
 | 
			
		||||
toTopFilePath file repo = TopFilePath . toRawFilePath
 | 
			
		||||
	<$> relPathDirToFile (fromRawFilePath (repoPath repo)) (fromRawFilePath file)
 | 
			
		||||
 | 
			
		||||
{- The input FilePath must already be relative to the top of the git
 | 
			
		||||
{- The input RawFilePath must already be relative to the top of the git
 | 
			
		||||
 - repository -}
 | 
			
		||||
asTopFilePath :: FilePath -> TopFilePath
 | 
			
		||||
asTopFilePath :: RawFilePath -> TopFilePath
 | 
			
		||||
asTopFilePath file = TopFilePath file
 | 
			
		||||
 | 
			
		||||
{- Git may use a different representation of a path when storing
 | 
			
		||||
| 
						 | 
				
			
			@ -91,5 +93,5 @@ fromInternalGitPath = encodeBS . replace "/" "\\" . decodeBS
 | 
			
		|||
 - so try posix paths.
 | 
			
		||||
 -}
 | 
			
		||||
absoluteGitPath :: RawFilePath -> Bool
 | 
			
		||||
absoluteGitPath p = isAbsolute (decodeBS p) ||
 | 
			
		||||
	System.FilePath.Posix.isAbsolute (decodeBS (toInternalGitPath p))
 | 
			
		||||
absoluteGitPath p = P.isAbsolute p ||
 | 
			
		||||
	System.FilePath.Posix.ByteString.isAbsolute (toInternalGitPath p)
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -28,7 +28,7 @@ instance Eq Hook where
 | 
			
		|||
	a == b = hookName a == hookName b
 | 
			
		||||
 | 
			
		||||
hookFile :: Hook -> Repo -> FilePath
 | 
			
		||||
hookFile h r = localGitDir r </> "hooks" </> hookName h
 | 
			
		||||
hookFile h r = fromRawFilePath (localGitDir r) </> "hooks" </> hookName h
 | 
			
		||||
 | 
			
		||||
{- Writes a hook. Returns False if the hook already exists with a different
 | 
			
		||||
 - content. Upgrades old scripts.
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -49,7 +49,7 @@ override index _r = do
 | 
			
		|||
 | 
			
		||||
{- The normal index file. Does not check GIT_INDEX_FILE. -}
 | 
			
		||||
indexFile :: Repo -> FilePath
 | 
			
		||||
indexFile r = localGitDir r </> "index"
 | 
			
		||||
indexFile r = fromRawFilePath (localGitDir r) </> "index"
 | 
			
		||||
 | 
			
		||||
{- The index file git will currently use, checking GIT_INDEX_FILE. -}
 | 
			
		||||
currentIndexFile :: Repo -> IO FilePath
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -185,7 +185,7 @@ typeChanged' ps l repo = do
 | 
			
		|||
	(fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo
 | 
			
		||||
	-- git diff returns filenames relative to the top of the git repo;
 | 
			
		||||
	-- convert to filenames relative to the cwd, like git ls-files.
 | 
			
		||||
	top <- absPath (repoPath repo)
 | 
			
		||||
	top <- absPath (fromRawFilePath (repoPath repo))
 | 
			
		||||
	currdir <- getCurrentDirectory
 | 
			
		||||
	return (map (\f -> toRawFilePath (relPathDirToFileAbs currdir $ top </> decodeBL' f)) fs, cleanup)
 | 
			
		||||
  where
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -100,7 +100,7 @@ parserLsTree = TreeItem
 | 
			
		|||
	<*> (Ref . decodeBS' <$> A.take shaSize)
 | 
			
		||||
	<* A8.char '\t'
 | 
			
		||||
	-- file
 | 
			
		||||
	<*> (asTopFilePath . decodeBS' . Git.Filename.decode <$> A.takeByteString)
 | 
			
		||||
	<*> (asTopFilePath . Git.Filename.decode <$> A.takeByteString)
 | 
			
		||||
 | 
			
		||||
{- Inverse of parseLsTree -}
 | 
			
		||||
formatLsTree :: TreeItem -> String
 | 
			
		||||
| 
						 | 
				
			
			@ -108,5 +108,5 @@ formatLsTree ti = unwords
 | 
			
		|||
	[ showOct (mode ti) ""
 | 
			
		||||
	, decodeBS (typeobj ti)
 | 
			
		||||
	, fromRef (sha ti)
 | 
			
		||||
	, getTopFilePath (file ti)
 | 
			
		||||
	, fromRawFilePath (getTopFilePath (file ti))
 | 
			
		||||
	]
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -12,7 +12,7 @@ import Git
 | 
			
		|||
import Git.Sha
 | 
			
		||||
 | 
			
		||||
objectsDir :: Repo -> FilePath
 | 
			
		||||
objectsDir r = localGitDir r </> "objects"
 | 
			
		||||
objectsDir r = fromRawFilePath (localGitDir r) </> "objects"
 | 
			
		||||
 | 
			
		||||
packDir :: Repo -> FilePath
 | 
			
		||||
packDir r = objectsDir r </> "pack"
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -22,7 +22,7 @@ headRef :: Ref
 | 
			
		|||
headRef = Ref "HEAD"
 | 
			
		||||
 | 
			
		||||
headFile :: Repo -> FilePath
 | 
			
		||||
headFile r = localGitDir r </> "HEAD"
 | 
			
		||||
headFile r = fromRawFilePath (localGitDir r) </> "HEAD"
 | 
			
		||||
 | 
			
		||||
setHeadRef :: Ref -> Repo -> IO ()
 | 
			
		||||
setHeadRef ref r = writeFile (headFile r) ("ref: " ++ fromRef ref)
 | 
			
		||||
| 
						 | 
				
			
			@ -85,7 +85,7 @@ exists ref = runBool
 | 
			
		|||
{- The file used to record a ref. (Git also stores some refs in a
 | 
			
		||||
 - packed-refs file.) -}
 | 
			
		||||
file :: Ref -> Repo -> FilePath
 | 
			
		||||
file ref repo = localGitDir repo </> fromRef ref
 | 
			
		||||
file ref repo = fromRawFilePath (localGitDir repo) </> fromRef ref
 | 
			
		||||
 | 
			
		||||
{- Checks if HEAD exists. It generally will, except for in a repository
 | 
			
		||||
 - that was just created. -}
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -227,7 +227,7 @@ badBranches missing r = filterM isbad =<< getAllRefs r
 | 
			
		|||
 - Relies on packed refs being exploded before it's called.
 | 
			
		||||
 -}
 | 
			
		||||
getAllRefs :: Repo -> IO [Ref]
 | 
			
		||||
getAllRefs r = getAllRefs' (localGitDir r </> "refs")
 | 
			
		||||
getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) </> "refs")
 | 
			
		||||
 | 
			
		||||
getAllRefs' :: FilePath -> IO [Ref]
 | 
			
		||||
getAllRefs' refdir = do
 | 
			
		||||
| 
						 | 
				
			
			@ -245,13 +245,13 @@ explodePackedRefsFile r = do
 | 
			
		|||
		nukeFile f
 | 
			
		||||
  where
 | 
			
		||||
	makeref (sha, ref) = do
 | 
			
		||||
		let dest = localGitDir r </> fromRef ref
 | 
			
		||||
		let dest = fromRawFilePath (localGitDir r) </> fromRef ref
 | 
			
		||||
		createDirectoryIfMissing True (parentDir dest)
 | 
			
		||||
		unlessM (doesFileExist dest) $
 | 
			
		||||
			writeFile dest (fromRef sha)
 | 
			
		||||
 | 
			
		||||
packedRefsFile :: Repo -> FilePath
 | 
			
		||||
packedRefsFile r = localGitDir r </> "packed-refs"
 | 
			
		||||
packedRefsFile r = fromRawFilePath (localGitDir r) </> "packed-refs"
 | 
			
		||||
 | 
			
		||||
parsePacked :: String -> Maybe (Sha, Ref)
 | 
			
		||||
parsePacked l = case words l of
 | 
			
		||||
| 
						 | 
				
			
			@ -263,7 +263,7 @@ parsePacked l = case words l of
 | 
			
		|||
{- git-branch -d cannot be used to remove a branch that is directly
 | 
			
		||||
 - pointing to a corrupt commit. -}
 | 
			
		||||
nukeBranchRef :: Branch -> Repo -> IO ()
 | 
			
		||||
nukeBranchRef b r = nukeFile $ localGitDir r </> fromRef b
 | 
			
		||||
nukeBranchRef b r = nukeFile $ fromRawFilePath (localGitDir r) </> fromRef b
 | 
			
		||||
 | 
			
		||||
{- Finds the most recent commit to a branch that does not need any
 | 
			
		||||
 - of the missing objects. If the input branch is good as-is, returns it.
 | 
			
		||||
| 
						 | 
				
			
			@ -366,16 +366,16 @@ checkIndex r = do
 | 
			
		|||
 - itself is not corrupt. -}
 | 
			
		||||
checkIndexFast :: Repo -> IO Bool
 | 
			
		||||
checkIndexFast r = do
 | 
			
		||||
	(indexcontents, cleanup) <- LsFiles.stagedDetails [toRawFilePath (repoPath r)] r
 | 
			
		||||
	(indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r
 | 
			
		||||
	length indexcontents `seq` cleanup
 | 
			
		||||
 | 
			
		||||
missingIndex :: Repo -> IO Bool
 | 
			
		||||
missingIndex r = not <$> doesFileExist (localGitDir r </> "index")
 | 
			
		||||
missingIndex r = not <$> doesFileExist (fromRawFilePath (localGitDir r) </> "index")
 | 
			
		||||
 | 
			
		||||
{- Finds missing and ok files staged in the index. -}
 | 
			
		||||
partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool)
 | 
			
		||||
partitionIndex r = do
 | 
			
		||||
	(indexcontents, cleanup) <- LsFiles.stagedDetails [toRawFilePath (repoPath r)] r
 | 
			
		||||
	(indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r
 | 
			
		||||
	l <- forM indexcontents $ \i -> case i of
 | 
			
		||||
		(_file, Just sha, Just _mode) -> (,) <$> isMissing sha r <*> pure i
 | 
			
		||||
		_ -> pure (False, i)
 | 
			
		||||
| 
						 | 
				
			
			@ -446,7 +446,7 @@ preRepair g = do
 | 
			
		|||
		let f = indexFile g
 | 
			
		||||
		void $ tryIO $ allowWrite f
 | 
			
		||||
  where
 | 
			
		||||
	headfile = localGitDir g </> "HEAD"
 | 
			
		||||
	headfile = fromRawFilePath (localGitDir g) </> "HEAD"
 | 
			
		||||
	validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s)
 | 
			
		||||
 | 
			
		||||
{- Put it all together. -}
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -57,13 +57,13 @@ parseStatusZ = go []
 | 
			
		|||
					in go (v : c) xs'
 | 
			
		||||
		_ -> go c xs
 | 
			
		||||
 | 
			
		||||
	cparse 'M' f _ = (Just (Modified (asTopFilePath f)), Nothing)
 | 
			
		||||
	cparse 'A' f _ = (Just (Added (asTopFilePath f)), Nothing)
 | 
			
		||||
	cparse 'D' f _ = (Just (Deleted (asTopFilePath f)), Nothing)
 | 
			
		||||
	cparse 'T' f _ = (Just (TypeChanged (asTopFilePath f)), Nothing)
 | 
			
		||||
	cparse '?' f _ = (Just (Untracked (asTopFilePath f)), Nothing)
 | 
			
		||||
	cparse 'M' f _ = (Just (Modified (asTopFilePath (toRawFilePath f))), Nothing)
 | 
			
		||||
	cparse 'A' f _ = (Just (Added (asTopFilePath (toRawFilePath f))), Nothing)
 | 
			
		||||
	cparse 'D' f _ = (Just (Deleted (asTopFilePath (toRawFilePath f))), Nothing)
 | 
			
		||||
	cparse 'T' f _ = (Just (TypeChanged (asTopFilePath (toRawFilePath f))), Nothing)
 | 
			
		||||
	cparse '?' f _ = (Just (Untracked (asTopFilePath (toRawFilePath f))), Nothing)
 | 
			
		||||
	cparse 'R' f (oldf:xs) =
 | 
			
		||||
		(Just (Renamed (asTopFilePath oldf) (asTopFilePath f)), Just xs)
 | 
			
		||||
		(Just (Renamed (asTopFilePath (toRawFilePath oldf)) (asTopFilePath (toRawFilePath f))), Just xs)
 | 
			
		||||
	cparse _ _ _ = (Nothing, Nothing)
 | 
			
		||||
 | 
			
		||||
getStatus :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedUnstaged Status], IO Bool)
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
							
								
								
									
										10
									
								
								Git/Tree.hs
									
										
									
									
									
								
							
							
						
						
									
										10
									
								
								Git/Tree.hs
									
										
									
									
									
								
							| 
						 | 
				
			
			@ -119,7 +119,7 @@ mkTreeOutput fm ot s f = concat
 | 
			
		|||
	, " "
 | 
			
		||||
	, fromRef s
 | 
			
		||||
	, "\t"
 | 
			
		||||
	, takeFileName (getTopFilePath f)
 | 
			
		||||
	, takeFileName (fromRawFilePath (getTopFilePath f))
 | 
			
		||||
	, "\NUL"
 | 
			
		||||
	]
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -156,7 +156,7 @@ treeItemsToTree = go M.empty
 | 
			
		|||
			Just (NewSubTree d l) ->
 | 
			
		||||
				go (addsubtree idir m (NewSubTree d (c:l))) is
 | 
			
		||||
			_ ->
 | 
			
		||||
				go (addsubtree idir m (NewSubTree (asTopFilePath idir) [c])) is
 | 
			
		||||
				go (addsubtree idir m (NewSubTree (asTopFilePath (toRawFilePath idir)) [c])) is
 | 
			
		||||
	  where
 | 
			
		||||
		p = gitPath i
 | 
			
		||||
		idir = takeDirectory p
 | 
			
		||||
| 
						 | 
				
			
			@ -169,7 +169,7 @@ treeItemsToTree = go M.empty
 | 
			
		|||
				Just (NewSubTree d' l) ->
 | 
			
		||||
					let l' = filter (\ti -> gitPath ti /= d) l
 | 
			
		||||
					in addsubtree parent m' (NewSubTree d' (t:l'))
 | 
			
		||||
				_ -> addsubtree parent m' (NewSubTree (asTopFilePath parent) [t])
 | 
			
		||||
				_ -> addsubtree parent m' (NewSubTree (asTopFilePath (toRawFilePath parent)) [t])
 | 
			
		||||
		| otherwise = M.insert d t m
 | 
			
		||||
	  where
 | 
			
		||||
		parent = takeDirectory d
 | 
			
		||||
| 
						 | 
				
			
			@ -328,7 +328,7 @@ graftTree' subtree graftloc basetree repo hdl = go basetree graftdirs
 | 
			
		|||
	
 | 
			
		||||
	-- For a graftloc of "foo/bar/baz", this generates
 | 
			
		||||
	-- ["foo", "foo/bar", "foo/bar/baz"]
 | 
			
		||||
	graftdirs = map (asTopFilePath . decodeBS . toInternalGitPath . encodeBS) $
 | 
			
		||||
	graftdirs = map (asTopFilePath . toInternalGitPath . encodeBS) $
 | 
			
		||||
		mkpaths [] $ splitDirectories $ gitPath graftloc
 | 
			
		||||
	mkpaths _ [] = []
 | 
			
		||||
	mkpaths base (d:rest) = (joinPath base </> d) : mkpaths (base ++ [d]) rest
 | 
			
		||||
| 
						 | 
				
			
			@ -366,7 +366,7 @@ instance GitPath FilePath where
 | 
			
		|||
	gitPath = id
 | 
			
		||||
 | 
			
		||||
instance GitPath TopFilePath where
 | 
			
		||||
	gitPath = getTopFilePath
 | 
			
		||||
	gitPath = fromRawFilePath . getTopFilePath
 | 
			
		||||
 | 
			
		||||
instance GitPath TreeItem where
 | 
			
		||||
	gitPath (TreeItem f _ _) = gitPath f
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -30,8 +30,8 @@ import Utility.FileSystemEncoding
 | 
			
		|||
 - else known about it.
 | 
			
		||||
 -}
 | 
			
		||||
data RepoLocation
 | 
			
		||||
	= Local { gitdir :: FilePath, worktree :: Maybe FilePath }
 | 
			
		||||
	| LocalUnknown FilePath
 | 
			
		||||
	= Local { gitdir :: RawFilePath, worktree :: Maybe RawFilePath }
 | 
			
		||||
	| LocalUnknown RawFilePath
 | 
			
		||||
	| Url URI
 | 
			
		||||
	| Unknown
 | 
			
		||||
	deriving (Show, Eq, Ord)
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -91,7 +91,7 @@ mergeFile info file hashhandle h = case filter (/= nullSha) [Ref asha, Ref bsha]
 | 
			
		|||
  where
 | 
			
		||||
	[_colonmode, _bmode, asha, bsha, _status] = words info
 | 
			
		||||
	use sha = return $ Just $
 | 
			
		||||
		updateIndexLine sha TreeFile $ asTopFilePath file
 | 
			
		||||
		updateIndexLine sha TreeFile $ asTopFilePath $ toRawFilePath file
 | 
			
		||||
	-- Get file and split into lines to union merge.
 | 
			
		||||
	-- The encoding of the file is assumed to be either ASCII or utf-8;
 | 
			
		||||
	-- in either case it's safe to split on \n
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -96,13 +96,13 @@ updateIndexLine sha treeitemtype file = L.fromStrict $
 | 
			
		|||
 | 
			
		||||
stageFile :: Sha -> TreeItemType -> FilePath -> Repo -> IO Streamer
 | 
			
		||||
stageFile sha treeitemtype file repo = do
 | 
			
		||||
	p <- toTopFilePath file repo
 | 
			
		||||
	p <- toTopFilePath (toRawFilePath file) repo
 | 
			
		||||
	return $ pureStreamer $ updateIndexLine sha treeitemtype p
 | 
			
		||||
 | 
			
		||||
{- A streamer that removes a file from the index. -}
 | 
			
		||||
unstageFile :: FilePath -> Repo -> IO Streamer
 | 
			
		||||
unstageFile file repo = do
 | 
			
		||||
	p <- toTopFilePath file repo
 | 
			
		||||
	p <- toTopFilePath (toRawFilePath file) repo
 | 
			
		||||
	return $ unstageFile' p
 | 
			
		||||
 | 
			
		||||
unstageFile' :: TopFilePath -> Streamer
 | 
			
		||||
| 
						 | 
				
			
			@ -118,7 +118,7 @@ stageSymlink file sha repo = do
 | 
			
		|||
	!line <- updateIndexLine
 | 
			
		||||
		<$> pure sha
 | 
			
		||||
		<*> pure TreeSymlink
 | 
			
		||||
		<*> toTopFilePath file repo
 | 
			
		||||
		<*> toTopFilePath (toRawFilePath file) repo
 | 
			
		||||
	return $ pureStreamer line
 | 
			
		||||
 | 
			
		||||
{- A streamer that applies a DiffTreeItem to the index. -}
 | 
			
		||||
| 
						 | 
				
			
			@ -128,7 +128,7 @@ stageDiffTreeItem d = case toTreeItemType (Diff.dstmode d) of
 | 
			
		|||
	Just t -> pureStreamer $ updateIndexLine (Diff.dstsha d) t (Diff.file d)
 | 
			
		||||
 | 
			
		||||
indexPath :: TopFilePath -> InternalGitPath
 | 
			
		||||
indexPath = toInternalGitPath . toRawFilePath . getTopFilePath
 | 
			
		||||
indexPath = toInternalGitPath . getTopFilePath
 | 
			
		||||
 | 
			
		||||
{- Refreshes the index, by checking file stat information.  -}
 | 
			
		||||
refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
							
								
								
									
										18
									
								
								Limit.hs
									
										
									
									
									
								
							
							
						
						
									
										18
									
								
								Limit.hs
									
										
									
									
									
								
							| 
						 | 
				
			
			@ -94,7 +94,7 @@ matchGlobFile :: String -> MatchInfo -> Annex Bool
 | 
			
		|||
matchGlobFile glob = go
 | 
			
		||||
  where
 | 
			
		||||
	cglob = compileGlob glob CaseSensative -- memoized
 | 
			
		||||
	go (MatchingFile fi) = pure $ matchGlob cglob (matchFile fi)
 | 
			
		||||
	go (MatchingFile fi) = pure $ matchGlob cglob (fromRawFilePath (matchFile fi))
 | 
			
		||||
	go (MatchingInfo p) = matchGlob cglob <$> getInfo (providedFilePath p)
 | 
			
		||||
	go (MatchingKey _ (AssociatedFile Nothing)) = pure False
 | 
			
		||||
	go (MatchingKey _ (AssociatedFile (Just af))) = pure $ matchGlob cglob (fromRawFilePath af)
 | 
			
		||||
| 
						 | 
				
			
			@ -127,7 +127,7 @@ matchMagic _limitname querymagic selectprovidedinfo (Just magic) glob = Right $
 | 
			
		|||
	go (MatchingKey _ _) = pure False
 | 
			
		||||
	go (MatchingFile fi) = catchBoolIO $
 | 
			
		||||
		maybe False (matchGlob cglob)
 | 
			
		||||
			<$> querymagic magic (currFile fi)
 | 
			
		||||
			<$> querymagic magic (fromRawFilePath (currFile fi))
 | 
			
		||||
	go (MatchingInfo p) =
 | 
			
		||||
		matchGlob cglob <$> getInfo (selectprovidedinfo p)
 | 
			
		||||
matchMagic limitname _ _ Nothing _ = 
 | 
			
		||||
| 
						 | 
				
			
			@ -143,10 +143,10 @@ matchLockStatus :: Bool -> MatchInfo -> Annex Bool
 | 
			
		|||
matchLockStatus _ (MatchingKey _ _) = pure False
 | 
			
		||||
matchLockStatus _ (MatchingInfo _) = pure False
 | 
			
		||||
matchLockStatus wantlocked (MatchingFile fi) = liftIO $ do
 | 
			
		||||
	islocked <- isPointerFile (toRawFilePath (currFile fi)) >>= \case
 | 
			
		||||
	islocked <- isPointerFile (currFile fi) >>= \case
 | 
			
		||||
		Just _key -> return False
 | 
			
		||||
		Nothing -> isSymbolicLink
 | 
			
		||||
			<$> getSymbolicLinkStatus (currFile fi)
 | 
			
		||||
			<$> getSymbolicLinkStatus (fromRawFilePath (currFile fi))
 | 
			
		||||
	return (islocked == wantlocked)
 | 
			
		||||
 | 
			
		||||
{- Adds a limit to skip files not believed to be present
 | 
			
		||||
| 
						 | 
				
			
			@ -190,7 +190,7 @@ limitPresent u _ = checkKey $ \key -> do
 | 
			
		|||
limitInDir :: FilePath -> MatchFiles Annex
 | 
			
		||||
limitInDir dir = const go
 | 
			
		||||
  where
 | 
			
		||||
	go (MatchingFile fi) = checkf $ matchFile fi
 | 
			
		||||
	go (MatchingFile fi) = checkf $ fromRawFilePath $ matchFile fi
 | 
			
		||||
	go (MatchingKey _ (AssociatedFile Nothing)) = return False
 | 
			
		||||
	go (MatchingKey _ (AssociatedFile (Just af))) = checkf (fromRawFilePath af)
 | 
			
		||||
	go (MatchingInfo p) = checkf =<< getInfo (providedFilePath p)
 | 
			
		||||
| 
						 | 
				
			
			@ -239,7 +239,8 @@ limitLackingCopies approx want = case readish want of
 | 
			
		|||
		NumCopies numcopies <- if approx
 | 
			
		||||
			then approxNumCopies
 | 
			
		||||
			else case mi of
 | 
			
		||||
				MatchingFile fi -> getGlobalFileNumCopies $ matchFile fi
 | 
			
		||||
				MatchingFile fi -> getGlobalFileNumCopies $
 | 
			
		||||
					fromRawFilePath $ matchFile fi
 | 
			
		||||
				MatchingKey _ _ -> approxNumCopies
 | 
			
		||||
				MatchingInfo {} -> approxNumCopies
 | 
			
		||||
		us <- filter (`S.notMember` notpresent)
 | 
			
		||||
| 
						 | 
				
			
			@ -321,7 +322,8 @@ limitSize lb vs s = case readSize dataUnits s of
 | 
			
		|||
			Just key -> checkkey sz key
 | 
			
		||||
			Nothing -> return False
 | 
			
		||||
		LimitDiskFiles -> do
 | 
			
		||||
			filesize <- liftIO $ catchMaybeIO $ getFileSize (currFile fi)
 | 
			
		||||
			filesize <- liftIO $ catchMaybeIO $
 | 
			
		||||
				getFileSize (fromRawFilePath (currFile fi))
 | 
			
		||||
			return $ filesize `vs` Just sz
 | 
			
		||||
	go sz _ (MatchingKey key _) = checkkey sz key
 | 
			
		||||
	go sz _ (MatchingInfo p) =
 | 
			
		||||
| 
						 | 
				
			
			@ -368,7 +370,7 @@ addAccessedWithin duration = do
 | 
			
		|||
	secs = fromIntegral (durationSeconds duration)
 | 
			
		||||
 | 
			
		||||
lookupFileKey :: FileInfo -> Annex (Maybe Key)
 | 
			
		||||
lookupFileKey = lookupFile . toRawFilePath . currFile
 | 
			
		||||
lookupFileKey = lookupFile . currFile
 | 
			
		||||
 | 
			
		||||
checkKey :: (Key -> Annex Bool) -> MatchInfo -> Annex Bool
 | 
			
		||||
checkKey a (MatchingFile fi) = lookupFileKey fi >>= maybe (return False) a
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -21,6 +21,6 @@ addWantDrop = addLimit $ Right $ const $ checkWant $
 | 
			
		|||
	wantDrop False Nothing Nothing
 | 
			
		||||
 | 
			
		||||
checkWant :: (AssociatedFile -> Annex Bool) -> MatchInfo -> Annex Bool
 | 
			
		||||
checkWant a (MatchingFile fi) = a (AssociatedFile (Just $ toRawFilePath $ matchFile fi))
 | 
			
		||||
checkWant a (MatchingFile fi) = a (AssociatedFile (Just $ matchFile fi))
 | 
			
		||||
checkWant a (MatchingKey _ af) = a af
 | 
			
		||||
checkWant _ (MatchingInfo {}) = return False
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -5,6 +5,8 @@
 | 
			
		|||
 - Licensed under the GNU AGPL version 3 or higher.
 | 
			
		||||
 -}
 | 
			
		||||
 | 
			
		||||
{-# LANGUAGE OverloadedStrings #-}
 | 
			
		||||
 | 
			
		||||
module Logs.Export (
 | 
			
		||||
	Exported,
 | 
			
		||||
	mkExported,
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -5,6 +5,8 @@
 | 
			
		|||
 - Licensed under the GNU AGPL version 3 or higher.
 | 
			
		||||
 -}
 | 
			
		||||
 | 
			
		||||
{-# LANGUAGE OverloadedStrings #-}
 | 
			
		||||
 | 
			
		||||
module Logs.Smudge where
 | 
			
		||||
 | 
			
		||||
import Annex.Common
 | 
			
		||||
| 
						 | 
				
			
			@ -15,8 +17,8 @@ import Logs.File
 | 
			
		|||
smudgeLog :: Key -> TopFilePath -> Annex ()
 | 
			
		||||
smudgeLog k f = do
 | 
			
		||||
	logf <- fromRepo gitAnnexSmudgeLog
 | 
			
		||||
	appendLogFile logf gitAnnexSmudgeLock $ 
 | 
			
		||||
		serializeKey k ++ " " ++ getTopFilePath f
 | 
			
		||||
	appendLogFile logf gitAnnexSmudgeLock $ fromRawFilePath $
 | 
			
		||||
		serializeKey' k <> " " <> getTopFilePath f
 | 
			
		||||
 | 
			
		||||
-- | Streams all smudged files, and then empties the log at the end.
 | 
			
		||||
--
 | 
			
		||||
| 
						 | 
				
			
			@ -37,4 +39,4 @@ streamSmudged a = do
 | 
			
		|||
		let (ks, f) = separate (== ' ') l
 | 
			
		||||
		in do
 | 
			
		||||
			k <- deserializeKey ks
 | 
			
		||||
			return (k, asTopFilePath f)
 | 
			
		||||
			return (k, asTopFilePath (toRawFilePath f))
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -93,7 +93,7 @@ knownUrls = do
 | 
			
		|||
	Annex.Branch.update
 | 
			
		||||
	Annex.Branch.commit =<< Annex.Branch.commitMessage
 | 
			
		||||
	Annex.Branch.withIndex $ do
 | 
			
		||||
		top <- toRawFilePath <$> fromRepo Git.repoPath
 | 
			
		||||
		top <- fromRepo Git.repoPath
 | 
			
		||||
		(l, cleanup) <- inRepo $ Git.LsFiles.stagedDetails [top]
 | 
			
		||||
		r <- mapM getkeyurls l
 | 
			
		||||
		void $ liftIO cleanup
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -293,7 +293,7 @@ runRelayService conn runner service =
 | 
			
		|||
	
 | 
			
		||||
	serviceproc = gitCreateProcess
 | 
			
		||||
		[ Param cmd
 | 
			
		||||
		, File (repoPath (connRepo conn))
 | 
			
		||||
		, File (fromRawFilePath (repoPath (connRepo conn)))
 | 
			
		||||
		] (connRepo conn)
 | 
			
		||||
 | 
			
		||||
	setup = do
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -230,7 +230,7 @@ onBupRemote r runner command params = do
 | 
			
		|||
	(sshcmd, sshparams) <- Ssh.toRepo NoConsumeStdin r c remotecmd
 | 
			
		||||
	liftIO $ runner sshcmd sshparams
 | 
			
		||||
  where
 | 
			
		||||
	path = Git.repoPath r
 | 
			
		||||
	path = fromRawFilePath $ Git.repoPath r
 | 
			
		||||
	base = fromMaybe path (stripPrefix "/~/" path)
 | 
			
		||||
	dir = shellEscape base
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -409,7 +409,8 @@ handleRequest' st external req mp responsehandler
 | 
			
		|||
		send $ CREDS (fst creds) (snd creds)
 | 
			
		||||
	handleRemoteRequest GETUUID = send $
 | 
			
		||||
		VALUE $ fromUUID $ externalUUID external
 | 
			
		||||
	handleRemoteRequest GETGITDIR = send . VALUE =<< fromRepo Git.localGitDir
 | 
			
		||||
	handleRemoteRequest GETGITDIR = 
 | 
			
		||||
		send . VALUE . fromRawFilePath =<< fromRepo Git.localGitDir
 | 
			
		||||
	handleRemoteRequest (SETWANTED expr) =
 | 
			
		||||
		preferredContentSet (externalUUID external) expr
 | 
			
		||||
	handleRemoteRequest GETWANTED = do
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -680,8 +680,8 @@ fsckOnRemote r params
 | 
			
		|||
		r' <- Git.Config.read r
 | 
			
		||||
		environ <- getEnvironment
 | 
			
		||||
		let environ' = addEntries 
 | 
			
		||||
			[ ("GIT_WORK_TREE", Git.repoPath r')
 | 
			
		||||
			, ("GIT_DIR", Git.localGitDir r')
 | 
			
		||||
			[ ("GIT_WORK_TREE", fromRawFilePath $ Git.repoPath r')
 | 
			
		||||
			, ("GIT_DIR", fromRawFilePath $ Git.localGitDir r')
 | 
			
		||||
			] environ
 | 
			
		||||
		batchCommandEnv program (Param "fsck" : params) (Just environ')
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -20,7 +20,7 @@ repoCheap = not . Git.repoIsUrl
 | 
			
		|||
localpathCalc :: Git.Repo -> Maybe FilePath
 | 
			
		||||
localpathCalc r
 | 
			
		||||
	| availabilityCalc r == GloballyAvailable = Nothing
 | 
			
		||||
	| otherwise = Just $ Git.repoPath r
 | 
			
		||||
	| otherwise = Just $ fromRawFilePath $ Git.repoPath r
 | 
			
		||||
 | 
			
		||||
availabilityCalc :: Git.Repo -> Availability
 | 
			
		||||
availabilityCalc r
 | 
			
		||||
| 
						 | 
				
			
			@ -36,7 +36,7 @@ guardUsable r fallback a
 | 
			
		|||
 | 
			
		||||
gitRepoInfo :: Remote -> Annex [(String, String)]
 | 
			
		||||
gitRepoInfo r = do
 | 
			
		||||
	d <- fromRepo Git.localGitDir
 | 
			
		||||
	d <- fromRawFilePath <$> fromRepo Git.localGitDir
 | 
			
		||||
	mtimes <- liftIO $ mapM (modificationTime <$$> getFileStatus)
 | 
			
		||||
		=<< dirContentsRecursive (d </> "refs" </> "remotes" </> Remote.name r)
 | 
			
		||||
	let lastsynctime = case mtimes of
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -65,7 +65,7 @@ git_annex_shell cs r command params fields
 | 
			
		|||
		let params' = if debug
 | 
			
		||||
			then Param "--debug" : params
 | 
			
		||||
			else params
 | 
			
		||||
		return (Param command : File dir : params')
 | 
			
		||||
		return (Param command : File (fromRawFilePath dir) : params')
 | 
			
		||||
	uuidcheck NoUUID = []
 | 
			
		||||
	uuidcheck u@(UUID _) = ["--uuid", fromUUID u]
 | 
			
		||||
	fieldopts
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -12,6 +12,7 @@ import Types.Key (Key, AssociatedFile)
 | 
			
		|||
import Types.Mime
 | 
			
		||||
import Utility.Matcher (Matcher, Token)
 | 
			
		||||
import Utility.FileSize
 | 
			
		||||
import Utility.FileSystemEncoding
 | 
			
		||||
 | 
			
		||||
import Control.Monad.IO.Class
 | 
			
		||||
import qualified Data.Map as M
 | 
			
		||||
| 
						 | 
				
			
			@ -24,9 +25,9 @@ data MatchInfo
 | 
			
		|||
	| MatchingInfo ProvidedInfo
 | 
			
		||||
 | 
			
		||||
data FileInfo = FileInfo
 | 
			
		||||
	{ currFile :: FilePath
 | 
			
		||||
	{ currFile :: RawFilePath
 | 
			
		||||
	-- ^ current path to the file, for operations that examine it
 | 
			
		||||
	, matchFile :: FilePath
 | 
			
		||||
	, matchFile :: RawFilePath
 | 
			
		||||
	-- ^ filepath to match on; may be relative to top of repo or cwd
 | 
			
		||||
	}
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -48,7 +48,7 @@ needsUpgrade v
 | 
			
		|||
  where
 | 
			
		||||
	err msg = do
 | 
			
		||||
		g <- Annex.gitRepo
 | 
			
		||||
		p <- liftIO $ absPath $ Git.repoPath g
 | 
			
		||||
		p <- liftIO $ absPath $ fromRawFilePath $ Git.repoPath g
 | 
			
		||||
		return $ Just $ unwords
 | 
			
		||||
			[ "Repository", p
 | 
			
		||||
			, "is at unsupported version"
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -84,7 +84,7 @@ updateSymlinks :: Annex ()
 | 
			
		|||
updateSymlinks = do
 | 
			
		||||
	showAction "updating symlinks"
 | 
			
		||||
	top <- fromRepo Git.repoPath
 | 
			
		||||
	(files, cleanup) <- inRepo $ LsFiles.inRepo [toRawFilePath top]
 | 
			
		||||
	(files, cleanup) <- inRepo $ LsFiles.inRepo [top]
 | 
			
		||||
	forM_ files (fixlink . fromRawFilePath)
 | 
			
		||||
	void $ liftIO cleanup
 | 
			
		||||
  where
 | 
			
		||||
| 
						 | 
				
			
			@ -244,4 +244,5 @@ stateDir :: FilePath
 | 
			
		|||
stateDir = addTrailingPathSeparator ".git-annex"
 | 
			
		||||
 | 
			
		||||
gitStateDir :: Git.Repo -> FilePath
 | 
			
		||||
gitStateDir repo = addTrailingPathSeparator $ Git.repoPath repo </> stateDir
 | 
			
		||||
gitStateDir repo = addTrailingPathSeparator $
 | 
			
		||||
	fromRawFilePath (Git.repoPath repo) </> stateDir
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -139,5 +139,7 @@ gitAttributesUnWrite repo = do
 | 
			
		|||
 | 
			
		||||
stateDir :: FilePath
 | 
			
		||||
stateDir = addTrailingPathSeparator ".git-annex"
 | 
			
		||||
 | 
			
		||||
gitStateDir :: Git.Repo -> FilePath
 | 
			
		||||
gitStateDir repo = addTrailingPathSeparator $ Git.repoPath repo </> stateDir
 | 
			
		||||
gitStateDir repo = addTrailingPathSeparator $
 | 
			
		||||
	fromRawFilePath (Git.repoPath repo) </> stateDir
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -108,7 +108,7 @@ convertDirect = do
 | 
			
		|||
upgradeDirectWorkTree :: Annex ()
 | 
			
		||||
upgradeDirectWorkTree = do
 | 
			
		||||
	top <- fromRepo Git.repoPath
 | 
			
		||||
	(l, clean) <- inRepo $ Git.LsFiles.stagedDetails [toRawFilePath top]
 | 
			
		||||
	(l, clean) <- inRepo $ Git.LsFiles.stagedDetails [top]
 | 
			
		||||
	forM_ l go
 | 
			
		||||
	void $ liftIO clean
 | 
			
		||||
  where
 | 
			
		||||
| 
						 | 
				
			
			@ -125,7 +125,7 @@ upgradeDirectWorkTree = do
 | 
			
		|||
					, fromdirect (fromRawFilePath f) k
 | 
			
		||||
					)
 | 
			
		||||
				Database.Keys.addAssociatedFile k
 | 
			
		||||
					=<< inRepo (toTopFilePath (fromRawFilePath f))
 | 
			
		||||
					=<< inRepo (toTopFilePath f)
 | 
			
		||||
	go _ = noop
 | 
			
		||||
 | 
			
		||||
	fromdirect f k = ifM (Direct.goodContent k f)
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -81,7 +81,7 @@ switchHEADBack = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
 | 
			
		|||
associatedFiles :: Key -> Annex [FilePath]
 | 
			
		||||
associatedFiles key = do
 | 
			
		||||
	files <- associatedFilesRelative key
 | 
			
		||||
	top <- fromRepo Git.repoPath
 | 
			
		||||
	top <- fromRawFilePath <$> fromRepo Git.repoPath
 | 
			
		||||
	return $ map (top </>) files
 | 
			
		||||
 | 
			
		||||
{- List of files in the tree that are associated with a key, relative to
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -320,6 +320,7 @@ Executable git-annex
 | 
			
		|||
   directory (>= 1.2),
 | 
			
		||||
   disk-free-space,
 | 
			
		||||
   filepath,
 | 
			
		||||
   filepath-bytestring,
 | 
			
		||||
   IfElse,
 | 
			
		||||
   hslogger,
 | 
			
		||||
   monad-logger,
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
	Add table
		Add a link
		
	
		Reference in a new issue