fa62c98910
This eliminates the distinction between decodeBS and decodeBS', encodeBS and encodeBS', etc. The old implementation truncated at NUL, and the primed versions had to do extra work to avoid that problem. The new implementation does not truncate at NUL, and is also a lot faster. (Benchmarked at 2x faster for decodeBS and 3x for encodeBS; more for the primed versions.) Note that filepath-bytestring 1.4.2.1.8 contains the same optimisation, and upgrading to it will speed up to/fromRawFilePath. AFAIK, nothing relied on the old behavior of truncating at NUL. Some code used the faster versions in places where I was sure there would not be a NUL. So this change is unlikely to break anything. Also, moved s2w8 and w82s out of the module, as they do not involve filesystem encoding really. Sponsored-by: Shae Erisson on Patreon
144 lines
4.5 KiB
Haskell
144 lines
4.5 KiB
Haskell
{- git-annex direct mode
|
|
-
|
|
- This only contains some remnants needed to convert away from direct mode.
|
|
-
|
|
- Copyright 2012-2014 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Upgrade.V5.Direct (
|
|
switchHEADBack,
|
|
setIndirect,
|
|
goodContent,
|
|
associatedFiles,
|
|
removeAssociatedFiles,
|
|
removeInodeCache,
|
|
) where
|
|
|
|
import Annex.Common
|
|
import qualified Git
|
|
import qualified Git.Config
|
|
import qualified Git.Ref
|
|
import qualified Git.Branch
|
|
import Git.Types
|
|
import Config
|
|
import Annex.Perms
|
|
import Utility.InodeCache
|
|
import Annex.InodeSentinal
|
|
import qualified Utility.RawFilePath as R
|
|
|
|
setIndirect :: Annex ()
|
|
setIndirect = do
|
|
setbare
|
|
switchHEADBack
|
|
setConfig (annexConfig "direct") val
|
|
where
|
|
val = Git.Config.boolConfig False
|
|
coreworktree = ConfigKey "core.worktree"
|
|
indirectworktree = ConfigKey "core.indirect-worktree"
|
|
setbare = do
|
|
-- core.worktree is not compatable with
|
|
-- core.bare; git does not allow both to be set, so
|
|
-- unset it when enabling direct mode, caching in
|
|
-- core.indirect-worktree
|
|
moveconfig indirectworktree coreworktree
|
|
setConfig Git.Config.coreBare val
|
|
moveconfig src dest = getConfigMaybe src >>= \case
|
|
Nothing -> noop
|
|
Just wt -> do
|
|
unsetConfig src
|
|
setConfig dest (fromConfigValue wt)
|
|
reloadConfig
|
|
|
|
{- Converts a directBranch back to the original branch.
|
|
-
|
|
- Any other ref is left unchanged.
|
|
-}
|
|
fromDirectBranch :: Ref -> Ref
|
|
fromDirectBranch directhead = case splitc '/' $ fromRef directhead of
|
|
("refs":"heads":"annex":"direct":rest) ->
|
|
Ref $ encodeBS $ "refs/heads/" ++ intercalate "/" rest
|
|
_ -> directhead
|
|
|
|
switchHEADBack :: Annex ()
|
|
switchHEADBack = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
|
|
where
|
|
switch currhead = do
|
|
let orighead = fromDirectBranch currhead
|
|
inRepo (Git.Ref.sha currhead) >>= \case
|
|
Just headsha
|
|
| orighead == currhead -> noop
|
|
| otherwise -> do
|
|
inRepo $ Git.Branch.update "leaving direct mode" orighead headsha
|
|
inRepo $ Git.Branch.checkout orighead
|
|
inRepo $ Git.Branch.delete currhead
|
|
Nothing -> inRepo $ Git.Branch.checkout orighead
|
|
|
|
{- Absolute FilePaths of Files in the tree that are associated with a key. -}
|
|
associatedFiles :: Key -> Annex [FilePath]
|
|
associatedFiles key = do
|
|
files <- associatedFilesRelative key
|
|
top <- fromRawFilePath <$> fromRepo Git.repoPath
|
|
return $ map (top </>) files
|
|
|
|
{- List of files in the tree that are associated with a key, relative to
|
|
- the top of the repo. -}
|
|
associatedFilesRelative :: Key -> Annex [FilePath]
|
|
associatedFilesRelative key = do
|
|
mapping <- fromRawFilePath <$> calcRepo (gitAnnexMapping key)
|
|
liftIO $ catchDefaultIO [] $ withFile mapping ReadMode $ \h ->
|
|
-- Read strictly to ensure the file is closed promptly
|
|
lines <$> hGetContentsStrict h
|
|
|
|
{- Removes the list of associated files. -}
|
|
removeAssociatedFiles :: Key -> Annex ()
|
|
removeAssociatedFiles key = do
|
|
mapping <- calcRepo $ gitAnnexMapping key
|
|
modifyContent mapping $
|
|
liftIO $ removeWhenExistsWith R.removeLink mapping
|
|
|
|
{- Checks if a file in the tree, associated with a key, has not been modified.
|
|
-
|
|
- To avoid needing to fsck the file's content, which can involve an
|
|
- expensive checksum, this relies on a cache that contains the file's
|
|
- expected mtime and inode.
|
|
-}
|
|
goodContent :: Key -> FilePath -> Annex Bool
|
|
goodContent key file =
|
|
sameInodeCache (toRawFilePath file)
|
|
=<< recordedInodeCache key
|
|
|
|
{- Gets the recorded inode cache for a key.
|
|
-
|
|
- A key can be associated with multiple files, so may return more than
|
|
- one. -}
|
|
recordedInodeCache :: Key -> Annex [InodeCache]
|
|
recordedInodeCache key = withInodeCacheFile key $ \f ->
|
|
liftIO $ catchDefaultIO [] $
|
|
mapMaybe readInodeCache . lines
|
|
<$> readFileStrict (fromRawFilePath f)
|
|
|
|
{- Removes an inode cache. -}
|
|
removeInodeCache :: Key -> Annex ()
|
|
removeInodeCache key = withInodeCacheFile key $ \f ->
|
|
modifyContent f $
|
|
liftIO $ removeWhenExistsWith R.removeLink f
|
|
|
|
withInodeCacheFile :: Key -> (RawFilePath -> Annex a) -> Annex a
|
|
withInodeCacheFile key a = a =<< calcRepo (gitAnnexInodeCache key)
|
|
|
|
{- File that maps from a key to the file(s) in the git repository. -}
|
|
gitAnnexMapping :: Key -> Git.Repo -> GitConfig -> IO RawFilePath
|
|
gitAnnexMapping key r c = do
|
|
loc <- gitAnnexLocation key r c
|
|
return $ loc <> ".map"
|
|
|
|
{- File that caches information about a key's content, used to determine
|
|
- if a file has changed. -}
|
|
gitAnnexInodeCache :: Key -> Git.Repo -> GitConfig -> IO RawFilePath
|
|
gitAnnexInodeCache key r c = do
|
|
loc <- gitAnnexLocation key r c
|
|
return $ loc <> ".cache"
|