{- adjusted branch
-
- - Copyright 2016-2018 Joey Hess <id@joeyh.name>
+ - Copyright 2016-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
import Annex.GitOverlay
import Utility.Tmp.Dir
import Utility.CopyFile
+import Utility.Directory.Create
import qualified Database.Keys
import Config
import qualified Data.Map as M
import qualified Data.ByteString as S
+import qualified System.FilePath.ByteString as P
-- How to perform various adjustments to a TreeItem.
class AdjustTreeItem t where
adjustToSymlink :: TreeItem -> Annex (Maybe TreeItem)
adjustToSymlink = adjustToSymlink' gitAnnexLink
-adjustToSymlink' :: (FilePath -> Key -> Git.Repo -> GitConfig -> IO FilePath) -> TreeItem -> Annex (Maybe TreeItem)
+adjustToSymlink' :: (RawFilePath -> Key -> Git.Repo -> GitConfig -> IO RawFilePath) -> TreeItem -> Annex (Maybe TreeItem)
adjustToSymlink' gitannexlink ti@(TreeItem f _m s) = catKey s >>= \case
Just k -> do
- absf <- inRepo $ \r -> absPath $
- fromRawFilePath $ fromTopFilePath f r
+ absf <- inRepo $ \r -> absPath $ fromTopFilePath f r
linktarget <- calcRepo $ gitannexlink absf k
Just . TreeItem f (fromTreeItemType TreeSymlink)
<$> hashSymlink linktarget
- index file is currently locked.)
-}
changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do
- git_dir <- fromRawFilePath <$> fromRepo Git.localGitDir
+ git_dir <- fromRepo Git.localGitDir
+ let git_dir' = fromRawFilePath git_dir
tmpwt <- fromRepo gitAnnexMergeDir
- withTmpDirIn othertmpdir "git" $ \tmpgit -> withWorkTreeRelated tmpgit $
+ withTmpDirIn (fromRawFilePath othertmpdir) "git" $ \tmpgit -> withWorkTreeRelated tmpgit $
withemptydir git_dir tmpwt $ withWorkTree tmpwt $ do
liftIO $ writeFile (tmpgit </> "HEAD") (fromRef updatedorig)
-- Copy in refs and packed-refs, to work
-- around bug in git 2.13.0, which
-- causes it not to look in GIT_DIR for refs.
refs <- liftIO $ dirContentsRecursive $
- git_dir </> "refs"
- let refs' = (git_dir </> "packed-refs") : refs
+ git_dir' </> "refs"
+ let refs' = (git_dir' </> "packed-refs") : refs
liftIO $ forM_ refs' $ \src ->
whenM (doesFileExist src) $ do
- dest <- relPathDirToFile git_dir src
- let dest' = tmpgit </> dest
- createDirectoryUnder git_dir (takeDirectory dest')
- void $ createLinkOrCopy src dest'
+ dest <- relPathDirToFile git_dir
+ (toRawFilePath src)
+ let dest' = toRawFilePath tmpgit P.</> dest
+ createDirectoryUnder git_dir
+ (P.takeDirectory dest')
+ void $ createLinkOrCopy src
+ (fromRawFilePath dest')
-- This reset makes git merge not care
-- that the work tree is empty; otherwise
-- it will think that all the files have
setup = do
whenM (doesDirectoryExist d) $
removeDirectoryRecursive d
- createDirectoryUnder git_dir d
+ createDirectoryUnder git_dir (toRawFilePath d)
cleanup _ = removeDirectoryRecursive d
{- A merge commit has been made between the basisbranch and
| otherwise = pure f
makesymlink key dest = do
- l <- calcRepo $ gitAnnexLink dest key
+ l <- calcRepo $ gitAnnexLink (toRawFilePath dest) key
unless inoverlay $ replacewithsymlink dest l
dest' <- toRawFilePath <$> stagefile dest
stageSymlink dest' =<< hashSymlink l
Nothing -> noop
Just sha -> do
link <- catSymLinkTarget sha
- replacewithsymlink item (fromRawFilePath link)
+ replacewithsymlink item link
-- And when grafting in anything else vs a symlink,
-- the work tree already contains what we want.
(_, Just TreeSymlink) -> noop
import Annex.Tmp
import Utility.UserInfo
import Utility.ThreadScheduler
+import qualified Utility.RawFilePath as R
#ifndef mingw32_HOST_OS
import Annex.Perms
import Utility.FileMode
#endif
import qualified Data.Map as M
+import qualified System.FilePath.ByteString as P
import Control.Concurrent.Async
checkCanInitialize :: Annex a -> Annex a
genDescription :: Maybe String -> Annex UUIDDesc
genDescription (Just d) = return $ UUIDDesc $ encodeBS d
genDescription Nothing = do
- reldir <- liftIO . relHome
- =<< liftIO . absPath . fromRawFilePath
+ reldir <- liftIO . relHome . fromRawFilePath
+ =<< liftIO . absPath
=<< fromRepo Git.repoPath
hostname <- fromMaybe "" <$> liftIO getHostname
let at = if null hostname then "" else "@"
mapM_ warning warnings
return r
-probeCrippledFileSystem' :: FilePath -> IO (Bool, [String])
+probeCrippledFileSystem' :: RawFilePath -> IO (Bool, [String])
#ifdef mingw32_HOST_OS
probeCrippledFileSystem' _ = return (True, [])
#else
probeCrippledFileSystem' tmp = do
- let f = tmp </> "gaprobe"
+ let f = fromRawFilePath (tmp P.</> "gaprobe")
writeFile f ""
r <- probe f
void $ tryIO $ allowWrite f
probeLockSupport = return True
#else
probeLockSupport = withEventuallyCleanedOtherTmp $ \tmp -> do
- let f = tmp </> "lockprobe"
+ let f = tmp P.</> "lockprobe"
mode <- annexFileMode
liftIO $ withAsync warnstall (const (go f mode))
where
go f mode = do
- removeWhenExistsWith removeLink f
+ removeWhenExistsWith R.removeLink f
let locktest = bracket
(Posix.lockExclusive (Just mode) f)
Posix.dropLock
(const noop)
ok <- isRight <$> tryNonAsync locktest
- removeWhenExistsWith removeLink f
+ removeWhenExistsWith R.removeLink f
return ok
warnstall = do
return False
#else
withEventuallyCleanedOtherTmp $ \tmp -> do
- let f = tmp </> "gaprobe"
- let f2 = tmp </> "gaprobe2"
+ let f = tmp P.</> "gaprobe"
+ let f2 = tmp P.</> "gaprobe2"
liftIO $ do
- removeWhenExistsWith removeLink f
- removeWhenExistsWith removeLink f2
+ removeWhenExistsWith R.removeLink f
+ removeWhenExistsWith R.removeLink f2
ms <- tryIO $ do
- createNamedPipe f ownerReadMode
- createLink f f2
- getFileStatus f
- removeWhenExistsWith removeLink f
- removeWhenExistsWith removeLink f2
+ createNamedPipe (fromRawFilePath f) ownerReadMode
+ R.createLink f f2
+ R.getFileStatus f
+ removeWhenExistsWith R.removeLink f
+ removeWhenExistsWith R.removeLink f2
return $ either (const False) isNamedPipe ms
#endif
where
err msg = do
g <- Annex.gitRepo
- p <- liftIO $ absPath $ fromRawFilePath $ Git.repoPath g
+ p <- liftIO $ absPath $ Git.repoPath g
return $ Just $ unwords
- [ "Repository", p
+ [ "Repository", fromRawFilePath p
, "is at unsupported version"
, show (fromRepoVersion v) ++ "."
, msg
fromdirect f k = ifM (Direct.goodContent k f)
( do
+ let f' = toRawFilePath f
-- If linkToAnnex fails for some reason, the work tree
-- file still has the content; the annex object file
-- is just not populated with it. Since the work tree
-- file is recorded as an associated file, things will
-- still work that way, it's just not ideal.
- ic <- withTSDelta (liftIO . genInodeCache (toRawFilePath f))
- void $ Content.linkToAnnex k f ic
+ ic <- withTSDelta (liftIO . genInodeCache f')
+ void $ Content.linkToAnnex k f' ic
, unlessM (Content.inAnnex k) $ do
-- Worktree file was deleted or modified;
-- if there are no other copies of the content
projects / git-annex.git / commitdiff