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