mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

wip RawFilePath 2x git-annex find speedup

Browse source 
Finally builds (oh the agoncy of making it build), but still very
unmergable, only Command.Find is included and lots of stuff is badly
hacked to make it compile.

Benchmarking vs master, this git-annex find is significantly faster!
Specifically:

	num files	old	new	speedup
	48500		4.77	3.73	28%
	12500		1.36	1.02	66%
	20		0.075	0.074	0% (so startup time is unchanged)

That's without really finishing the optimization. Things still to do:

* Eliminate all the fromRawFilePath, toRawFilePath, encodeBS,
  decodeBS conversions.
* Use versions of IO actions like getFileStatus that take a RawFilePath.
* Eliminate some Data.ByteString.Lazy.toStrict, which is a slow copy.
* Use ByteString for parsing git config to speed up startup.

It's likely several of those will speed up git-annex find further.
And other commands will certianly benefit even more.
This commit is contained in:
Joey Hess 2019-11-26 15:27:22 -04:00
parent 6a97ff6b3a
commit 067aabdd48
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
61 changed files with 380 additions and 296 deletions
Download patch file Download diff file Expand all files Collapse all files

12
Annex/AutoMerge.hs
View file

@ -43,6 +43,8 @@ import qualified Data.ByteString.Lazy as L
-}
autoMergeFrom :: Git.Ref -> Maybe Git.Ref -> [Git.Merge.MergeConfig] -> Annex Bool -> Git.Branch.CommitMode -> Annex Bool
autoMergeFrom branch currbranch mergeconfig canresolvemerge commitmode = do
error "STUBBED FIXME"
{-
showOutput
case currbranch of
Nothing -> go Nothing
@ -62,6 +64,7 @@ autoMergeFrom branch currbranch mergeconfig canresolvemerge commitmode = do
( resolveMerge old branch False
, return False
)
-}
{- Resolves a conflicted merge. It's important that any conflicts be
- resolved in a way that itself avoids later merge conflicts, since
@ -104,6 +107,8 @@ autoMergeFrom branch currbranch mergeconfig canresolvemerge commitmode = do
-}
resolveMerge :: Maybe Git.Ref -> Git.Ref -> Bool -> Annex Bool
resolveMerge us them inoverlay = do
error "STUBBED FIXME"
{-
top <- if inoverlay
then pure "."
else fromRepo Git.repoPath
@ -132,10 +137,13 @@ resolveMerge us them inoverlay = do
cleanConflictCruft mergedks' mergedfs' unstagedmap
showLongNote "Merge conflict was automatically resolved; you may want to examine the result."
return merged
-}
resolveMerge' :: InodeMap -> Maybe Git.Ref -> Git.Ref -> Bool -> LsFiles.Unmerged -> Annex ([Key], Maybe FilePath)
resolveMerge' _ Nothing _ _ _ = return ([], Nothing)
resolveMerge' unstagedmap (Just us) them inoverlay u = do
error "STUBBED FIXME"
{-
kus <- getkey LsFiles.valUs
kthem <- getkey LsFiles.valThem
case (kus, kthem) of
@ -265,6 +273,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
[Param "--quiet", Param "-f", Param "--cached", Param "--"] [file]
void a
return (ks, Just file)
-}
{- git-merge moves conflicting files away to files
- named something like f~HEAD or f~branch or just f, but the
@ -278,6 +287,8 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
-}
cleanConflictCruft :: [Key] -> [FilePath] -> InodeMap -> Annex ()
cleanConflictCruft resolvedks resolvedfs unstagedmap = do
error "STUBBED FIXME"
{-
is <- S.fromList . map (inodeCacheToKey Strongly) . concat
<$> mapM Database.Keys.getInodeCaches resolvedks
forM_ (M.toList unstagedmap) $ \(i, f) ->
@ -294,6 +305,7 @@ cleanConflictCruft resolvedks resolvedfs unstagedmap = do
, inks <$> liftIO (isPointerFile f)
]
| otherwise = return False
-}
conflictCruftBase :: FilePath -> FilePath
conflictCruftBase f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f

30
Annex/Branch.hs
View file

@ -215,7 +215,7 @@ updateTo' pairs = do
- content is returned.
-
- Returns an empty string if the file doesn't exist yet. -}
get :: FilePath -> Annex L.ByteString
get :: RawFilePath -> Annex L.ByteString
get file = do
update
getLocal file
@ -224,21 +224,21 @@ get file = do
- reflect changes in remotes.
- (Changing the value this returns, and then merging is always the
- same as using get, and then changing its value.) -}
getLocal :: FilePath -> Annex L.ByteString
getLocal :: RawFilePath -> Annex L.ByteString
getLocal file = go =<< getJournalFileStale file
where
go (Just journalcontent) = return journalcontent
go Nothing = getRef fullname file
{- Gets the content of a file as staged in the branch's index. -}
getStaged :: FilePath -> Annex L.ByteString
getStaged :: RawFilePath -> Annex L.ByteString
getStaged = getRef indexref
where
-- This makes git cat-file be run with ":file",
-- so it looks at the index.
indexref = Ref ""
getHistorical :: RefDate -> FilePath -> Annex L.ByteString
getHistorical :: RefDate -> RawFilePath -> Annex L.ByteString
getHistorical date file =
-- This check avoids some ugly error messages when the reflog
-- is empty.
@ -247,7 +247,7 @@ getHistorical date file =
, getRef (Git.Ref.dateRef fullname date) file
)
getRef :: Ref -> FilePath -> Annex L.ByteString
getRef :: Ref -> RawFilePath -> Annex L.ByteString
getRef ref file = withIndex $ catFile ref file
{- Applies a function to modify the content of a file.
@ -255,11 +255,11 @@ getRef ref file = withIndex $ catFile ref file
- Note that this does not cause the branch to be merged, it only
- modifes the current content of the file on the branch.
-}
change :: Journalable content => FilePath -> (L.ByteString -> content) -> Annex ()
change :: Journalable content => RawFilePath -> (L.ByteString -> content) -> Annex ()
change file f = lockJournal $ \jl -> f <$> getLocal file >>= set jl file
{- Applies a function which can modify the content of a file, or not. -}
maybeChange :: Journalable content => FilePath -> (L.ByteString -> Maybe content) -> Annex ()
maybeChange :: Journalable content => RawFilePath -> (L.ByteString -> Maybe content) -> Annex ()
maybeChange file f = lockJournal $ \jl -> do
v <- getLocal file
case f v of
@ -269,7 +269,7 @@ maybeChange file f = lockJournal $ \jl -> do
_ -> noop
{- Records new content of a file into the journal -}
set :: Journalable content => JournalLocked -> FilePath -> content -> Annex ()
set :: Journalable content => JournalLocked -> RawFilePath -> content -> Annex ()
set = setJournalFile
{- Commit message used when making a commit of whatever data has changed
@ -353,23 +353,23 @@ commitIndex' jl branchref message basemessage retrynum parents = do
{- Lists all files on the branch. including ones in the journal
- that have not been committed yet. There may be duplicates in the list. -}
files :: Annex [FilePath]
files :: Annex [RawFilePath]
files = do
update
-- ++ forces the content of the first list to be buffered in memory,
-- so use getJournalledFilesStale which should be much smaller most
-- of the time. branchFiles will stream as the list is consumed.
(++)
<$> getJournalledFilesStale
<$> (map toRawFilePath <$> getJournalledFilesStale)
<*> branchFiles
{- Files in the branch, not including any from journalled changes,
- and without updating the branch. -}
branchFiles :: Annex [FilePath]
branchFiles :: Annex [RawFilePath]
branchFiles = withIndex $ inRepo branchFiles'
branchFiles' :: Git.Repo -> IO [FilePath]
branchFiles' = Git.Command.pipeNullSplitZombie
branchFiles' :: Git.Repo -> IO [RawFilePath]
branchFiles' = Git.Command.pipeNullSplitZombie'
(lsTreeParams Git.LsTree.LsTreeRecursive fullname [Param "--name-only"])
{- Populates the branch's index file with the current branch contents.
@ -593,14 +593,14 @@ performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do
if L.null content'
then do
Annex.Queue.addUpdateIndex
=<< inRepo (Git.UpdateIndex.unstageFile file)
=<< inRepo (Git.UpdateIndex.unstageFile (fromRawFilePath file))
-- File is deleted; can't run any other
-- transitions on it.
return ()
else do
sha <- hashBlob content'
Annex.Queue.addUpdateIndex $ Git.UpdateIndex.pureStreamer $
Git.UpdateIndex.updateIndexLine sha TreeFile (asTopFilePath file)
Git.UpdateIndex.updateIndexLine sha TreeFile (asTopFilePath (fromRawFilePath file))
apply rest file content'
checkBranchDifferences :: Git.Ref -> Annex ()

2
Annex/Branch/Transitions.hs
View file

@ -34,7 +34,7 @@ data FileTransition
= ChangeFile Builder
| PreserveFile
type TransitionCalculator = TrustMap -> M.Map UUID RemoteConfig -> FilePath -> L.ByteString -> FileTransition
type TransitionCalculator = TrustMap -> M.Map UUID RemoteConfig -> RawFilePath -> L.ByteString -> FileTransition
getTransitionCalculator :: Transition -> Maybe TransitionCalculator
getTransitionCalculator ForgetGitHistory = Nothing

18
Annex/CatFile.hs
View file

@ -39,12 +39,12 @@ import Annex.Link
import Annex.CurrentBranch
import Types.AdjustedBranch
catFile :: Git.Branch -> FilePath -> Annex L.ByteString
catFile :: Git.Branch -> RawFilePath -> Annex L.ByteString
catFile branch file = do
h <- catFileHandle
liftIO $ Git.CatFile.catFile h branch file
catFileDetails :: Git.Branch -> FilePath -> Annex (Maybe (L.ByteString, Sha, ObjectType))
catFileDetails :: Git.Branch -> RawFilePath -> Annex (Maybe (L.ByteString, Sha, ObjectType))
catFileDetails branch file = do
h <- catFileHandle
liftIO $ Git.CatFile.catFileDetails h branch file
@ -109,8 +109,8 @@ catKey ref = go =<< catObjectMetaData ref
go _ = return Nothing
{- Gets a symlink target. -}
catSymLinkTarget :: Sha -> Annex String
catSymLinkTarget sha = fromInternalGitPath . decodeBL <$> get
catSymLinkTarget :: Sha -> Annex RawFilePath
catSymLinkTarget sha = fromInternalGitPath . L.toStrict <$> get
where
-- Avoid buffering the whole file content, which might be large.
-- 8192 is enough if it really is a symlink.
@ -137,24 +137,24 @@ catSymLinkTarget sha = fromInternalGitPath . decodeBL <$> get
-
- So, this gets info from the index, unless running as a daemon.
-}
catKeyFile :: FilePath -> Annex (Maybe Key)
catKeyFile :: RawFilePath -> Annex (Maybe Key)
catKeyFile f = ifM (Annex.getState Annex.daemon)
( catKeyFileHEAD f
, catKey $ Git.Ref.fileRef f
)
catKeyFileHEAD :: FilePath -> Annex (Maybe Key)
catKeyFileHEAD :: RawFilePath -> Annex (Maybe Key)
catKeyFileHEAD f = catKey $ Git.Ref.fileFromRef Git.Ref.headRef f
{- Look in the original branch from whence an adjusted branch is based
- to find the file. But only when the adjustment hides some files. -}
catKeyFileHidden :: FilePath -> CurrBranch -> Annex (Maybe Key)
catKeyFileHidden :: RawFilePath -> CurrBranch -> Annex (Maybe Key)
catKeyFileHidden = hiddenCat catKey
catObjectMetaDataHidden :: FilePath -> CurrBranch -> Annex (Maybe (Integer, ObjectType))
catObjectMetaDataHidden :: RawFilePath -> CurrBranch -> Annex (Maybe (Integer, ObjectType))
catObjectMetaDataHidden = hiddenCat catObjectMetaData
hiddenCat :: (Ref -> Annex (Maybe a)) -> FilePath -> CurrBranch -> Annex (Maybe a)
hiddenCat :: (Ref -> Annex (Maybe a)) -> RawFilePath -> CurrBranch -> Annex (Maybe a)
hiddenCat a f (Just origbranch, Just adj)
| adjustmentHidesFiles adj = a (Git.Ref.fileFromRef origbranch f)
hiddenCat _ _ _ = return Nothing

4
Annex/Content.hs
View file

@ -483,7 +483,7 @@ moveAnnex key src = ifM (checkSecureHashes key)
fs <- map (`fromTopFilePath` g)
<$> Database.Keys.getAssociatedFiles key
unless (null fs) $ do
ics <- mapM (populatePointerFile (Restage True) key dest) fs
ics <- mapM (populatePointerFile (Restage True) key (toRawFilePath dest) . toRawFilePath) fs
Database.Keys.storeInodeCaches' key [dest] (catMaybes ics)
)
alreadyhave = liftIO $ removeFile src
@ -650,7 +650,7 @@ removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file ->
-- Check associated pointer file for modifications, and reset if
-- it's unmodified.
resetpointer file = ifM (isUnmodified key file)
( depopulatePointerFile key file
( depopulatePointerFile key (toRawFilePath file)
-- Modified file, so leave it alone.
-- If it was a hard link to the annex object,
-- that object might have been frozen as part of the

26
Annex/Content/PointerFile.hs
View file

@ -30,16 +30,17 @@ import Utility.Touch
-
- Returns an InodeCache if it populated the pointer file.
-}
populatePointerFile :: Restage -> Key -> FilePath -> FilePath -> Annex (Maybe InodeCache)
populatePointerFile :: Restage -> Key -> RawFilePath -> RawFilePath -> Annex (Maybe InodeCache)
populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f)
where
go (Just k') | k == k' = do
destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f
liftIO $ nukeFile f
(ic, populated) <- replaceFile f $ \tmp -> do
ok <- linkOrCopy k obj tmp destmode >>= \case
let f' = fromRawFilePath f
destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f'
liftIO $ nukeFile f'
(ic, populated) <- replaceFile f' $ \tmp -> do
ok <- linkOrCopy k (fromRawFilePath obj) tmp destmode >>= \case
Just _ -> thawContent tmp >> return True
Nothing -> liftIO (writePointerFile tmp k destmode) >> return False
Nothing -> liftIO (writePointerFile (toRawFilePath tmp) k destmode) >> return False
ic <- withTSDelta (liftIO . genInodeCache tmp)
return (ic, ok)
maybe noop (restagePointerFile restage f) ic
@ -51,14 +52,15 @@ populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f)
{- Removes the content from a pointer file, replacing it with a pointer.
-
- Does not check if the pointer file is modified. -}
depopulatePointerFile :: Key -> FilePath -> Annex ()
depopulatePointerFile :: Key -> RawFilePath -> Annex ()
depopulatePointerFile key file = do
st <- liftIO $ catchMaybeIO $ getFileStatus file
let file' = fromRawFilePath file
st <- liftIO $ catchMaybeIO $ getFileStatus file'
let mode = fmap fileMode st
secureErase file
liftIO $ nukeFile file
ic <- replaceFile file $ \tmp -> do
liftIO $ writePointerFile tmp key mode
secureErase file'
liftIO $ nukeFile file'
ic <- replaceFile file' $ \tmp -> do
liftIO $ writePointerFile (toRawFilePath tmp) key mode
#if ! defined(mingw32_HOST_OS)
-- Don't advance mtime; this avoids unncessary re-smudging
-- by git in some cases.

4
Annex/FileMatcher.hs
View file

@ -54,7 +54,7 @@ checkFileMatcher' getmatcher file notconfigured = do
matcher <- getmatcher file
checkMatcher matcher Nothing afile S.empty notconfigured d
where
afile = AssociatedFile (Just file)
afile = AssociatedFile (Just (toRawFilePath file))
-- checkMatcher will never use this, because afile is provided.
d = return True
@ -62,7 +62,7 @@ checkMatcher :: FileMatcher Annex -> Maybe Key -> AssociatedFile -> AssumeNotPre
checkMatcher matcher mkey afile notpresent notconfigured d
| isEmpty matcher = notconfigured
| otherwise = case (mkey, afile) of
(_, AssociatedFile (Just file)) -> go =<< fileMatchInfo file
(_, AssociatedFile (Just file)) -> go =<< fileMatchInfo (fromRawFilePath file)
(Just key, _) -> go (MatchingKey key afile)
_ -> d
where

10
Annex/Journal.hs
View file

@ -44,18 +44,18 @@ instance Journalable Builder where
- getJournalFileStale to always return a consistent journal file
- content, although possibly not the most current one.
-}
setJournalFile :: Journalable content => JournalLocked -> FilePath -> content -> Annex ()
setJournalFile :: Journalable content => JournalLocked -> RawFilePath -> content -> Annex ()
setJournalFile _jl file content = withOtherTmp $ \tmp -> do
createAnnexDirectory =<< fromRepo gitAnnexJournalDir
-- journal file is written atomically
jfile <- fromRepo $ journalFile file
jfile <- fromRepo $ journalFile $ fromRawFilePath file
let tmpfile = tmp </> takeFileName jfile
liftIO $ do
withFile tmpfile WriteMode $ \h -> writeJournalHandle h content
moveFile tmpfile jfile
{- Gets any journalled content for a file in the branch. -}
getJournalFile :: JournalLocked -> FilePath -> Annex (Maybe L.ByteString)
getJournalFile :: JournalLocked -> RawFilePath -> Annex (Maybe L.ByteString)
getJournalFile _jl = getJournalFileStale
{- Without locking, this is not guaranteed to be the most recent
@ -69,9 +69,9 @@ getJournalFile _jl = getJournalFileStale
- concurrency or other issues with a lazy read, and the minor loss of
- laziness doesn't matter much, as the files are not very large.
-}
getJournalFileStale :: FilePath -> Annex (Maybe L.ByteString)
getJournalFileStale :: RawFilePath -> Annex (Maybe L.ByteString)
getJournalFileStale file = inRepo $ \g -> catchMaybeIO $
L.fromStrict <$> S.readFile (journalFile file g)
L.fromStrict <$> S.readFile (journalFile (fromRawFilePath file) g)
{- List of existing journal files, but without locking, may miss new ones
- just being added, or may have false positives if the journal is staged

52
Annex/Link.hs
View file

@ -43,7 +43,7 @@ import qualified Data.ByteString.Lazy as L
type LinkTarget = String
{- Checks if a file is a link to a key. -}
isAnnexLink :: FilePath -> Annex (Maybe Key)
isAnnexLink :: RawFilePath -> Annex (Maybe Key)
isAnnexLink file = maybe Nothing parseLinkTargetOrPointer <$> getAnnexLinkTarget file
{- Gets the link target of a symlink.
@ -54,13 +54,13 @@ isAnnexLink file = maybe Nothing parseLinkTargetOrPointer <$> getAnnexLinkTarget
- Returns Nothing if the file is not a symlink, or not a link to annex
- content.
-}
getAnnexLinkTarget :: FilePath -> Annex (Maybe S.ByteString)
getAnnexLinkTarget :: RawFilePath -> Annex (Maybe S.ByteString)
getAnnexLinkTarget f = getAnnexLinkTarget' f
=<< (coreSymlinks <$> Annex.getGitConfig)
{- Pass False to force looking inside file, for when git checks out
- symlinks as plain files. -}
getAnnexLinkTarget' :: FilePath -> Bool -> Annex (Maybe S.ByteString)
getAnnexLinkTarget' :: RawFilePath -> Bool -> Annex (Maybe S.ByteString)
getAnnexLinkTarget' file coresymlinks = if coresymlinks
then check probesymlink $
return Nothing
@ -75,9 +75,9 @@ getAnnexLinkTarget' file coresymlinks = if coresymlinks
| otherwise -> return Nothing
Nothing -> fallback
probesymlink = R.readSymbolicLink $ toRawFilePath file
probesymlink = R.readSymbolicLink file
probefilecontent = withFile file ReadMode $ \h -> do
probefilecontent = withFile (fromRawFilePath file) ReadMode $ \h -> do
s <- S.hGet h unpaddedMaxPointerSz
-- If we got the full amount, the file is too large
-- to be a symlink target.
@ -92,7 +92,7 @@ getAnnexLinkTarget' file coresymlinks = if coresymlinks
then mempty
else s
makeAnnexLink :: LinkTarget -> FilePath -> Annex ()
makeAnnexLink :: LinkTarget -> RawFilePath -> Annex ()
makeAnnexLink = makeGitLink
{- Creates a link on disk.
@ -102,48 +102,48 @@ makeAnnexLink = makeGitLink
- it's staged as such, so use addAnnexLink when adding a new file or
- modified link to git.
-}
makeGitLink :: LinkTarget -> FilePath -> Annex ()
makeGitLink :: LinkTarget -> RawFilePath -> Annex ()
makeGitLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
( liftIO $ do
void $ tryIO $ removeFile file
createSymbolicLink linktarget file
, liftIO $ writeFile file linktarget
void $ tryIO $ removeFile (fromRawFilePath file)
createSymbolicLink linktarget (fromRawFilePath file)
, liftIO $ writeFile (fromRawFilePath file) linktarget
)
{- Creates a link on disk, and additionally stages it in git. -}
addAnnexLink :: LinkTarget -> FilePath -> Annex ()
addAnnexLink :: LinkTarget -> RawFilePath -> Annex ()
addAnnexLink linktarget file = do
makeAnnexLink linktarget file
stageSymlink file =<< hashSymlink linktarget
{- Injects a symlink target into git, returning its Sha. -}
hashSymlink :: LinkTarget -> Annex Sha
hashSymlink linktarget = hashBlob $ toRawFilePath $ toInternalGitPath linktarget
hashSymlink = hashBlob . toInternalGitPath . toRawFilePath
{- Stages a symlink to an annexed object, using a Sha of its target. -}
stageSymlink :: FilePath -> Sha -> Annex ()
stageSymlink :: RawFilePath -> Sha -> Annex ()
stageSymlink file sha =
Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.stageSymlink file sha)
inRepo (Git.UpdateIndex.stageSymlink (fromRawFilePath file) sha)
{- Injects a pointer file content into git, returning its Sha. -}
hashPointerFile :: Key -> Annex Sha
hashPointerFile key = hashBlob $ formatPointer key
{- Stages a pointer file, using a Sha of its content -}
stagePointerFile :: FilePath -> Maybe FileMode -> Sha -> Annex ()
stagePointerFile :: RawFilePath -> Maybe FileMode -> Sha -> Annex ()
stagePointerFile file mode sha =
Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.stageFile sha treeitemtype file)
inRepo (Git.UpdateIndex.stageFile sha treeitemtype $ fromRawFilePath file)
where
treeitemtype
| maybe False isExecutable mode = TreeExecutable
| otherwise = TreeFile
writePointerFile :: FilePath -> Key -> Maybe FileMode -> IO ()
writePointerFile :: RawFilePath -> Key -> Maybe FileMode -> IO ()
writePointerFile file k mode = do
S.writeFile file (formatPointer k)
maybe noop (setFileMode file) mode
S.writeFile (fromRawFilePath file) (formatPointer k)
maybe noop (setFileMode $ fromRawFilePath file) mode
newtype Restage = Restage Bool
@ -172,17 +172,17 @@ newtype Restage = Restage Bool
- the worktree file is changed by something else before git update-index
- gets to look at it.
-}
restagePointerFile :: Restage -> FilePath -> InodeCache -> Annex ()
restagePointerFile :: Restage -> RawFilePath -> InodeCache -> Annex ()
restagePointerFile (Restage False) f _ =
toplevelWarning True $ unableToRestage (Just f)
toplevelWarning True $ unableToRestage $ Just $ fromRawFilePath f
restagePointerFile (Restage True) f orig = withTSDelta $ \tsd -> do
-- update-index is documented as picky about "./file" and it
-- fails on "../../repo/path/file" when cwd is not in the repo
-- being acted on. Avoid these problems with an absolute path.
absf <- liftIO $ absPath f
absf <- liftIO $ absPath $ fromRawFilePath f
Annex.Queue.addInternalAction runner [(absf, isunmodified tsd)]
where
isunmodified tsd = genInodeCache f tsd >>= return . \case
isunmodified tsd = genInodeCache (fromRawFilePath f) tsd >>= return . \case
Nothing -> False
Just new -> compareStrong orig new
@ -264,7 +264,7 @@ parseLinkTarget l
formatPointer :: Key -> S.ByteString
formatPointer k = prefix <> keyFile' k <> nl
where
prefix = toRawFilePath $ toInternalGitPath (pathSeparator:objectDir)
prefix = toInternalGitPath $ toRawFilePath (pathSeparator:objectDir)
nl = S8.singleton '\n'
{- Maximum size of a file that could be a pointer to a key.
@ -283,8 +283,8 @@ unpaddedMaxPointerSz = 8192
{- Checks if a worktree file is a pointer to a key.
-
- Unlocked files whose content is present are not detected by this. -}
isPointerFile :: FilePath -> IO (Maybe Key)
isPointerFile f = catchDefaultIO Nothing $ withFile f ReadMode $ \h ->
isPointerFile :: RawFilePath -> IO (Maybe Key)
isPointerFile f = catchDefaultIO Nothing $ withFile (fromRawFilePath f) ReadMode $ \h ->
parseLinkTargetOrPointer <$> S.hGet h unpaddedMaxPointerSz
{- Checks a symlink target or pointer file first line to see if it

3
Annex/Locations.hs
View file

@ -192,7 +192,8 @@ gitAnnexLink file key r config = do
let absfile = absNormPathUnix currdir file
let gitdir = getgitdir currdir
loc <- gitAnnexLocation' key r config False False (\_ -> return True) gitdir
toInternalGitPath <$> relPathDirToFile (parentDir absfile) loc
fromRawFilePath . toInternalGitPath . toRawFilePath
<$> relPathDirToFile (parentDir absfile) loc
where
getgitdir currdir
{- This special case is for git submodules on filesystems not

6
Annex/MetaData.hs
View file

@ -37,7 +37,7 @@ import Data.Time.Clock.POSIX
-
- Also, can generate new metadata, if configured to do so.
-}
genMetaData :: Key -> FilePath -> FileStatus -> Annex ()
genMetaData :: Key -> RawFilePath -> FileStatus -> Annex ()
genMetaData key file status = do
catKeyFileHEAD file >>= \case
Nothing -> noop
@ -53,8 +53,8 @@ genMetaData key file status = do
where
mtime = posixSecondsToUTCTime $ realToFrac $ modificationTime status
warncopied = warning $
"Copied metadata from old version of " ++ file ++ " to new version. " ++
"If you don't want this copied metadata, run: git annex metadata --remove-all " ++ file
"Copied metadata from old version of " ++ fromRawFilePath file ++ " to new version. " ++
"If you don't want this copied metadata, run: git annex metadata --remove-all " ++ fromRawFilePath file
-- If the only fields copied were date metadata, and they'll
-- be overwritten with the current mtime, no need to warn about
-- copying.

2
Annex/Notification.hs
View file

@ -60,7 +60,7 @@ notifyDrop (AssociatedFile (Just f)) ok = do
wanted <- Annex.getState Annex.desktopnotify
when (notifyFinish wanted) $ liftIO $ do
client <- DBus.Client.connectSession
void $ Notify.notify client (droppedNote ok f)
void $ Notify.notify client (droppedNote ok (fromRawFilePath f))
#else
notifyDrop (AssociatedFile (Just _)) _ = noop
#endif

2
Annex/NumCopies.hs
View file

@ -72,7 +72,7 @@ getFileNumCopies f = fromSources
getAssociatedFileNumCopies :: AssociatedFile -> Annex NumCopies
getAssociatedFileNumCopies (AssociatedFile afile) =
maybe getNumCopies getFileNumCopies afile
maybe getNumCopies getFileNumCopies (fromRawFilePath <$> afile)
{- This is the globally visible numcopies value for a file. So it does
- not include local configuration in the git config or command line

4
Annex/View.hs
View file

@ -343,11 +343,11 @@ narrowView = applyView' viewedFileReuse getViewedFileMetaData
applyView' :: MkViewedFile -> (FilePath -> MetaData) -> View -> Annex Git.Branch
applyView' mkviewedfile getfilemetadata view = do
top <- fromRepo Git.repoPath
(l, clean) <- inRepo $ Git.LsFiles.stagedDetails [top]
(l, clean) <- inRepo $ Git.LsFiles.stagedDetails [toRawFilePath top]
liftIO . nukeFile =<< fromRepo gitAnnexViewIndex
uh <- withViewIndex $ inRepo Git.UpdateIndex.startUpdateIndex
forM_ l $ \(f, sha, mode) -> do
topf <- inRepo (toTopFilePath f)
topf <- inRepo (toTopFilePath $ fromRawFilePath f)
go uh topf sha (toTreeItemType =<< mode) =<< lookupFile f
liftIO $ do
void $ stopUpdateIndex uh

20
Annex/WorkTree.hs
View file

@ -33,35 +33,35 @@ import Config
- When in an adjusted branch that may have hidden the file, looks for a
- pointer to a key in the original branch.
-}
lookupFile :: FilePath -> Annex (Maybe Key)
lookupFile :: RawFilePath -> Annex (Maybe Key)
lookupFile = lookupFile' catkeyfile
where
catkeyfile file =
ifM (liftIO $ doesFileExist file)
ifM (liftIO $ doesFileExist $ fromRawFilePath file)
( catKeyFile file
, catKeyFileHidden file =<< getCurrentBranch
)
lookupFileNotHidden :: FilePath -> Annex (Maybe Key)
lookupFileNotHidden :: RawFilePath -> Annex (Maybe Key)
lookupFileNotHidden = lookupFile' catkeyfile
where
catkeyfile file =
ifM (liftIO $ doesFileExist file)
ifM (liftIO $ doesFileExist $ fromRawFilePath file)
( catKeyFile file
, return Nothing
)
lookupFile' :: (FilePath -> Annex (Maybe Key)) -> FilePath -> Annex (Maybe Key)
lookupFile' :: (RawFilePath -> Annex (Maybe Key)) -> RawFilePath -> Annex (Maybe Key)
lookupFile' catkeyfile file = isAnnexLink file >>= \case
Just key -> return (Just key)
Nothing -> catkeyfile file
{- Modifies an action to only act on files that are already annexed,
- and passes the key on to it. -}
whenAnnexed :: (FilePath -> Key -> Annex (Maybe a)) -> FilePath -> Annex (Maybe a)
whenAnnexed :: (RawFilePath -> Key -> Annex (Maybe a)) -> RawFilePath -> Annex (Maybe a)
whenAnnexed a file = ifAnnexed file (a file) (return Nothing)
ifAnnexed :: FilePath -> (Key -> Annex a) -> Annex a -> Annex a
ifAnnexed :: RawFilePath -> (Key -> Annex a) -> Annex a -> Annex a
ifAnnexed file yes no = maybe no yes =<< lookupFile file
{- Find all unlocked files and update the keys database for them.
@ -96,7 +96,7 @@ scanUnlockedFiles = whenM (inRepo Git.Ref.headExists <&&> not <$> isBareRepo) $
liftIO . Database.Keys.SQL.addAssociatedFileFast (toIKey k) tf
whenM (inAnnex k) $ do
f <- fromRepo $ fromTopFilePath tf
liftIO (isPointerFile f) >>= \case
liftIO (isPointerFile (toRawFilePath f)) >>= \case
Just k' | k' == k -> do
destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f
ic <- replaceFile f $ \tmp ->
@ -105,7 +105,7 @@ scanUnlockedFiles = whenM (inRepo Git.Ref.headExists <&&> not <$> isBareRepo) $
withTSDelta (liftIO . genInodeCache tmp)
LinkAnnexNoop -> return Nothing
LinkAnnexFailed -> liftIO $ do
writePointerFile tmp k destmode
writePointerFile (toRawFilePath tmp) k destmode
return Nothing
maybe noop (restagePointerFile (Restage True) f) ic
maybe noop (restagePointerFile (Restage True) (toRawFilePath f)) ic
_ -> noop

2
Backend/Hash.hs
View file

@ -188,7 +188,7 @@ trivialMigrate' oldkey newbackend afile maxextlen
AssociatedFile Nothing -> Nothing
AssociatedFile (Just file) -> Just $ alterKey oldkey $ \d -> d
{ keyName = keyHash oldkey
<> encodeBS (selectExtension maxextlen file)
<> encodeBS' (selectExtension maxextlen (fromRawFilePath file))
, keyVariety = newvariety
}
{- Upgrade to fix bad previous migration that created a

2
CmdLine/GitAnnexShell/Fields.hs
View file

@ -30,7 +30,7 @@ remoteUUID = Field "remoteuuid" $
associatedFile :: Field
associatedFile = Field "associatedfile" $ \f ->
-- is the file a safe relative filename?
not (absoluteGitPath f) && not ("../" `isPrefixOf` f)
not (absoluteGitPath (toRawFilePath f)) && not ("../" `isPrefixOf` f)
direct :: Field
direct = Field "direct" $ \f -> f == "1"

28
CmdLine/Seek.hs
View file

@ -48,7 +48,7 @@ withFilesInGitNonRecursive needforce a l = ifM (Annex.getState Annex.force)
where
getfiles c [] = return (reverse c)
getfiles c ((WorkTreeItem p):ps) = do
(fs, cleanup) <- inRepo $ LsFiles.inRepo [p]
(fs, cleanup) <- inRepo $ LsFiles.inRepo [toRawFilePath p]
case fs of
[f] -> do
void $ liftIO $ cleanup
@ -62,7 +62,7 @@ withFilesNotInGit :: Bool -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> C
withFilesNotInGit skipdotfiles a l
| skipdotfiles = do
{- dotfiles are not acted on unless explicitly listed -}
files <- filter (not . dotfile) <$>
files <- filter (not . dotfile . fromRawFilePath) <$>
seekunless (null ps && not (null l)) ps
dotfiles <- seekunless (null dotps) dotps
go (files++dotfiles)
@ -74,11 +74,11 @@ withFilesNotInGit skipdotfiles a l
force <- Annex.getState Annex.force
g <- gitRepo
liftIO $ Git.Command.leaveZombie
<$> LsFiles.notInRepo force (map (\(WorkTreeItem f) -> f) l') g
<$> LsFiles.notInRepo force (map (\(WorkTreeItem f) -> toRawFilePath f) l') g
go fs = seekActions $ prepFiltered a $
return $ concat $ segmentPaths (map (\(WorkTreeItem f) -> f) l) fs
return $ concat $ segmentPaths (map (\(WorkTreeItem f) -> toRawFilePath f) l) fs
withPathContents :: ((RawFilePath, RawFilePath) -> CommandSeek) -> CmdParams -> CommandSeek
withPathContents :: ((FilePath, FilePath) -> CommandSeek) -> CmdParams -> CommandSeek
withPathContents a params = do
matcher <- Limit.getMatcher
forM_ params $ \p -> do
@ -130,7 +130,7 @@ withUnmodifiedUnlockedPointers a l = seekActions $
isUnmodifiedUnlocked :: RawFilePath -> Annex Bool
isUnmodifiedUnlocked f = catKeyFile f >>= \case
Nothing -> return False
Just k -> sameInodeCache f =<< Database.Keys.getInodeCaches k
Just k -> sameInodeCache (fromRawFilePath f) =<< Database.Keys.getInodeCaches k
{- Finds files that may be modified. -}
withFilesMaybeModified :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek
@ -169,7 +169,7 @@ withKeyOptions ko auto keyaction = withKeyOptions' ko auto mkkeyaction
return $ \v@(k, ai) ->
let i = case ai of
ActionItemBranchFilePath (BranchFilePath _ topf) _ ->
MatchingKey k (AssociatedFile $ Just $ getTopFilePath topf)
MatchingKey k (AssociatedFile $ Just $ toRawFilePath $ getTopFilePath topf)
_ -> MatchingKey k (AssociatedFile Nothing)
in whenM (matcher i) $
keyaction v
@ -230,7 +230,9 @@ prepFiltered a fs = do
matcher <- Limit.getMatcher
map (process matcher) <$> fs
where
process matcher f = whenM (matcher $ MatchingFile $ FileInfo f f) $ a f
process matcher f =
let f' = fromRawFilePath f
in whenM (matcher $ MatchingFile $ FileInfo f' f') $ a f
seekActions :: Annex [CommandSeek] -> Annex ()
seekActions gen = sequence_ =<< gen
@ -238,12 +240,12 @@ seekActions gen = sequence_ =<< gen
seekHelper :: ([RawFilePath] -> Git.Repo -> IO ([RawFilePath], IO Bool)) -> [WorkTreeItem] -> Annex [RawFilePath]
seekHelper a l = inRepo $ \g ->
concat . concat <$> forM (segmentXargsOrdered l')
(runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g))
(runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g) . map toRawFilePath)
where
l' = map (\(WorkTreeItem f) -> f) l
-- An item in the work tree, which may be a file or a directory.
newtype WorkTreeItem = WorkTreeItem RawFilePath
newtype WorkTreeItem = WorkTreeItem FilePath
-- When in an adjusted branch that hides some files, it may not exist
-- in the current work tree, but in the original branch. This allows
@ -264,14 +266,14 @@ workTreeItems' (AllowHidden allowhidden) ps = do
unlessM (exists p <||> hidden currbranch p) $ do
toplevelWarning False (p ++ " not found")
Annex.incError
return (map WorkTreeItem ps)
return (map (WorkTreeItem) ps)
where
exists p = isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)
hidden currbranch p
| allowhidden = do
f <- liftIO $ relPathCwdToFile p
isJust <$> catObjectMetaDataHidden f currbranch
isJust <$> catObjectMetaDataHidden (toRawFilePath f) currbranch
| otherwise = return False
notSymlink :: RawFilePath -> IO Bool
notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f
notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus (fromRawFilePath f)

13
Command/Find.hs
View file

@ -9,6 +9,7 @@ module Command.Find where
import Data.Default
import qualified Data.Map as M
import qualified Data.ByteString.Char8 as S8
import Command
import Annex.Content
@ -57,29 +58,29 @@ seek o = case batchOption o of
(commandAction . startKeys o)
(withFilesInGit (commandAction . go))
=<< workTreeItems (findThese o)
Batch fmt -> batchFilesMatching fmt go
Batch fmt -> batchFilesMatching fmt (go . toRawFilePath)
where
go = whenAnnexed $ start o
-- only files inAnnex are shown, unless the user has requested
-- others via a limit
start :: FindOptions -> FilePath -> Key -> CommandStart
start :: FindOptions -> RawFilePath -> Key -> CommandStart
start o file key =
stopUnless (limited <||> inAnnex key) $
startingCustomOutput key $ do
showFormatted (formatOption o) file $ ("file", file) : keyVars key
showFormatted (formatOption o) file $ ("file", fromRawFilePath file) : keyVars key
next $ return True
startKeys :: FindOptions -> (Key, ActionItem) -> CommandStart
startKeys o (key, ActionItemBranchFilePath (BranchFilePath _ topf) _) =
start o (getTopFilePath topf) key
start o (toRawFilePath (getTopFilePath topf)) key
startKeys _ _ = stop
showFormatted :: Maybe Utility.Format.Format -> String -> [(String, String)] -> Annex ()
showFormatted :: Maybe Utility.Format.Format -> RawFilePath -> [(String, String)] -> Annex ()
showFormatted format unformatted vars =
unlessM (showFullJSON $ JSONChunk vars) $
case format of
Nothing -> liftIO $ putStrLn unformatted
Nothing -> liftIO $ S8.putStrLn unformatted
Just formatter -> liftIO $ putStr $
Utility.Format.format formatter $
M.fromList vars

4
Command/Unannex.hs
View file

@ -25,10 +25,10 @@ cmd = withGlobalOptions [annexedMatchingOptions] $
seek :: CmdParams -> CommandSeek
seek ps = (withFilesInGit $ commandAction . whenAnnexed start) =<< workTreeItems ps
start :: FilePath -> Key -> CommandStart
start :: RawFilePath -> Key -> CommandStart
start file key = stopUnless (inAnnex key) $
starting "unannex" (mkActionItem (key, file)) $
perform file key
perform (fromRawFilePath file) key
perform :: FilePath -> Key -> CommandPerform
perform file key = do

4
Command/Uninit.hs
View file

@ -34,14 +34,14 @@ check = do
whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $
giveup "can only run uninit from the top of the git repository"
where
current_branch = Git.Ref . Prelude.head . lines <$> revhead
current_branch = Git.Ref . Prelude.head . lines . decodeBS' <$> revhead
revhead = inRepo $ Git.Command.pipeReadStrict
[Param "rev-parse", Param "--abbrev-ref", Param "HEAD"]
seek :: CmdParams -> CommandSeek
seek ps = do
l <- workTreeItems ps
withFilesNotInGit False (commandAction . whenAnnexed startCheckIncomplete) l
withFilesNotInGit False (commandAction . whenAnnexed (startCheckIncomplete . fromRawFilePath)) l
Annex.changeState $ \s -> s { Annex.fast = True }
withFilesInGit (commandAction . whenAnnexed Command.Unannex.start) l
finish

2
Database/ContentIdentifier.hs
View file

@ -145,7 +145,7 @@ updateFromLog db (oldtree, currtree) = do
recordAnnexBranchTree db currtree
flushDbQueue db
where
go ti = case extLogFileKey remoteContentIdentifierExt (getTopFilePath (DiffTree.file ti)) of
go ti = case extLogFileKey remoteContentIdentifierExt (toRawFilePath (getTopFilePath (DiffTree.file ti))) of
Nothing -> return ()
Just k -> do
l <- Log.getContentIdentifiers k

22
Database/Export.hs
View file

@ -128,28 +128,28 @@ addExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
addExportedLocation h k el = queueDb h $ do
void $ insertUnique $ Exported ik ef
let edirs = map
(\ed -> ExportedDirectory (toSFilePath (fromExportDirectory ed)) ef)
(\ed -> ExportedDirectory (toSFilePath (fromRawFilePath (fromExportDirectory ed))) ef)
(exportDirectories el)
putMany edirs
where
ik = toIKey k
ef = toSFilePath (fromExportLocation el)
ef = toSFilePath $ fromRawFilePath $ fromExportLocation el
removeExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
removeExportedLocation h k el = queueDb h $ do
deleteWhere [ExportedKey ==. ik, ExportedFile ==. ef]
let subdirs = map (toSFilePath . fromExportDirectory)
let subdirs = map (toSFilePath . fromRawFilePath . fromExportDirectory)
(exportDirectories el)
deleteWhere [ExportedDirectoryFile ==. ef, ExportedDirectorySubdir <-. subdirs]
where
ik = toIKey k
ef = toSFilePath (fromExportLocation el)
ef = toSFilePath $ fromRawFilePath $ fromExportLocation el
{- Note that this does not see recently queued changes. -}
getExportedLocation :: ExportHandle -> Key -> IO [ExportLocation]
getExportedLocation (ExportHandle h _) k = H.queryDbQueue h $ do
l <- selectList [ExportedKey ==. ik] []
return $ map (mkExportLocation . fromSFilePath . exportedFile . entityVal) l
return $ map (mkExportLocation . toRawFilePath . fromSFilePath . exportedFile . entityVal) l
where
ik = toIKey k
@ -159,13 +159,13 @@ isExportDirectoryEmpty (ExportHandle h _) d = H.queryDbQueue h $ do
l <- selectList [ExportedDirectorySubdir ==. ed] []
return $ null l
where
ed = toSFilePath $ fromExportDirectory d
ed = toSFilePath $ fromRawFilePath $ fromExportDirectory d
{- Get locations in the export that might contain a key. -}
getExportTree :: ExportHandle -> Key -> IO [ExportLocation]
getExportTree (ExportHandle h _) k = H.queryDbQueue h $ do
l <- selectList [ExportTreeKey ==. ik] []
return $ map (mkExportLocation . fromSFilePath . exportTreeFile . entityVal) l
return $ map (mkExportLocation . toRawFilePath . fromSFilePath . exportTreeFile . entityVal) l
where
ik = toIKey k
@ -181,21 +181,21 @@ getExportTreeKey (ExportHandle h _) el = H.queryDbQueue h $ do
map (fromIKey . exportTreeKey . entityVal)
<$> selectList [ExportTreeFile ==. ef] []
where
ef = toSFilePath (fromExportLocation el)
ef = toSFilePath (fromRawFilePath $ fromExportLocation el)
addExportTree :: ExportHandle -> Key -> ExportLocation -> IO ()
addExportTree h k loc = queueDb h $
void $ insertUnique $ ExportTree ik ef
where
ik = toIKey k
ef = toSFilePath (fromExportLocation loc)
ef = toSFilePath (fromRawFilePath $ fromExportLocation loc)
removeExportTree :: ExportHandle -> Key -> ExportLocation -> IO ()
removeExportTree h k loc = queueDb h $
deleteWhere [ExportTreeKey ==. ik, ExportTreeFile ==. ef]
where
ik = toIKey k
ef = toSFilePath (fromExportLocation loc)
ef = toSFilePath (fromRawFilePath $ fromExportLocation loc)
-- An action that is passed the old and new values that were exported,
-- and updates state.
@ -220,7 +220,7 @@ mkExportDiffUpdater removeold addnew h srcek dstek i = do
Nothing -> return ()
Just k -> liftIO $ addnew h (asKey k) loc
where
loc = mkExportLocation $ getTopFilePath $ Git.DiffTree.file i
loc = mkExportLocation $ toRawFilePath $ getTopFilePath $ Git.DiffTree.file i
runExportDiffUpdater :: ExportDiffUpdater -> ExportHandle -> Sha -> Sha -> Annex ()
runExportDiffUpdater updater h old new = do

13
Database/Keys.hs
View file

@ -235,7 +235,7 @@ reconcileStaged qh = do
where
go cur indexcache = do
(l, cleanup) <- inRepo $ pipeNullSplit diff
changed <- procdiff l False
changed <- procdiff (map decodeBL' l) False
void $ liftIO cleanup
-- Flush database changes immediately
-- so other processes can see them.
@ -262,7 +262,8 @@ reconcileStaged qh = do
-- perfect. A file could start with this and not be a
-- pointer file. And a pointer file that is replaced with
-- a non-pointer file will match this.
, Param $ "-G^" ++ toInternalGitPath (pathSeparator:objectDir)
, Param $ "-G^" ++ fromRawFilePath (toInternalGitPath $
toRawFilePath (pathSeparator:objectDir))
-- Don't include files that were deleted, because this only
-- wants to update information for files that are present
-- in the index.
@ -277,7 +278,7 @@ reconcileStaged qh = do
procdiff (info:file:rest) changed = case words info of
((':':_srcmode):dstmode:_srcsha:dstsha:_change:[])
-- Only want files, not symlinks
| dstmode /= fmtTreeItemType TreeSymlink -> do
| dstmode /= decodeBS' (fmtTreeItemType TreeSymlink) -> do
maybe noop (reconcile (asTopFilePath file))
=<< catKey (Ref dstsha)
procdiff rest True
@ -293,11 +294,11 @@ reconcileStaged qh = do
caches <- liftIO $ SQL.getInodeCaches ikey (SQL.ReadHandle qh)
keyloc <- calcRepo (gitAnnexLocation key)
keypopulated <- sameInodeCache keyloc caches
p <- fromRepo $ fromTopFilePath file
filepopulated <- sameInodeCache p caches
p <- fromRepo $ toRawFilePath . fromTopFilePath file
filepopulated <- sameInodeCache (fromRawFilePath p) caches
case (keypopulated, filepopulated) of
(True, False) ->
populatePointerFile (Restage True) key keyloc p >>= \case
populatePointerFile (Restage True) key (toRawFilePath keyloc) p >>= \case
Nothing -> return ()
Just ic -> liftIO $
SQL.addInodeCaches ikey [ic] (SQL.WriteHandle qh)

8
Git/Command.hs
View file

@ -102,7 +102,10 @@ pipeNullSplit params repo = do
return (filter (not . L.null) $ L.split 0 s, cleanup)
{- Reads lazily, but converts each part to a strict ByteString for
- convenience. -}
- convenience.
-
- FIXME the L.toStrict makes a copy, more expensive than ideal.
-}
pipeNullSplit' :: [CommandParam] -> Repo -> IO ([S.ByteString], IO Bool)
pipeNullSplit' params repo = do
(s, cleanup) <- pipeNullSplit params repo
@ -116,6 +119,9 @@ pipeNullSplitStrict params repo = do
pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [L.ByteString]
pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo
pipeNullSplitZombie' :: [CommandParam] -> Repo -> IO [S.ByteString]
pipeNullSplitZombie' params repo = leaveZombie <$> pipeNullSplit' params repo
{- Doesn't run the cleanup action. A zombie results. -}
leaveZombie :: (a, IO Bool) -> a
leaveZombie = fst

7
Git/FilePath.hs
View file

@ -12,6 +12,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Git.FilePath (
TopFilePath,
@ -33,6 +34,7 @@ import Git
import qualified System.FilePath.Posix
import GHC.Generics
import Control.DeepSeq
import qualified Data.ByteString as S
{- A RawFilePath, relative to the top of the git repository. -}
newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath }
@ -45,8 +47,9 @@ data BranchFilePath = BranchFilePath Ref TopFilePath
deriving (Show, Eq, Ord)
{- Git uses the branch:file form to refer to a BranchFilePath -}
descBranchFilePath :: BranchFilePath -> String
descBranchFilePath (BranchFilePath b f) = fromRef b ++ ':' : (getTopFilePath f)
descBranchFilePath :: BranchFilePath -> S.ByteString
descBranchFilePath (BranchFilePath b f) =
encodeBS' (fromRef b) <> ":" <> toRawFilePath (getTopFilePath f)
{- Path to a TopFilePath, within the provided git repo. -}
fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath

4
Git/Filename.hs
View file

@ -36,5 +36,5 @@ encode :: RawFilePath -> S.ByteString
encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\""
{- For quickcheck. -}
prop_encode_decode_roundtrip :: RawFilePath -> Bool
prop_encode_decode_roundtrip s = s == decode (encode s)
prop_encode_decode_roundtrip :: FilePath -> Bool
prop_encode_decode_roundtrip s = s == fromRawFilePath (decode (encode (toRawFilePath s)))

6
Git/Ref.hs
View file

@ -65,8 +65,8 @@ branchRef = underBase "refs/heads"
- Prefixing the file with ./ makes this work even if in a subdirectory
- of a repo.
-}
fileRef :: FilePath -> Ref
fileRef f = Ref $ ":./" ++ f
fileRef :: RawFilePath -> Ref
fileRef f = Ref $ ":./" ++ fromRawFilePath f
{- Converts a Ref to refer to the content of the Ref on a given date. -}
dateRef :: Ref -> RefDate -> Ref
@ -74,7 +74,7 @@ dateRef (Ref r) (RefDate d) = Ref $ r ++ "@" ++ d
{- A Ref that can be used to refer to a file in the repository as it
- appears in a given Ref. -}
fileFromRef :: Ref -> FilePath -> Ref
fileFromRef :: Ref -> RawFilePath -> Ref
fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr)
{- Checks if a ref exists. -}

5
Key.hs
View file

@ -78,6 +78,11 @@ instance Arbitrary KeyData where
<*> ((abs <$>) <$> arbitrary) -- chunksize cannot be negative
<*> ((succ . abs <$>) <$> arbitrary) -- chunknum cannot be 0 or negative
-- AssociatedFile cannot be empty (but can be Nothing)
instance Arbitrary AssociatedFile where
arbitrary = AssociatedFile . fmap toRawFilePath
<$> arbitrary `suchThat` (/= Just "")
instance Arbitrary Key where
arbitrary = mkKey . const <$> arbitrary

12
Limit.hs
View file

@ -97,7 +97,7 @@ matchGlobFile glob = go
go (MatchingFile fi) = pure $ matchGlob cglob (matchFile fi)
go (MatchingInfo p) = matchGlob cglob <$> getInfo (providedFilePath p)
go (MatchingKey _ (AssociatedFile Nothing)) = pure False
go (MatchingKey _ (AssociatedFile (Just af))) = pure $ matchGlob cglob af
go (MatchingKey _ (AssociatedFile (Just af))) = pure $ matchGlob cglob (fromRawFilePath af)
addMimeType :: String -> Annex ()
addMimeType = addMagicLimit "mimetype" getMagicMimeType providedMimeType
@ -110,13 +110,13 @@ addMagicLimit limitname querymagic selectprovidedinfo glob = do
magic <- liftIO initMagicMime
addLimit $ matchMagic limitname querymagic' selectprovidedinfo magic glob
where
querymagic' magic f = liftIO (isPointerFile f) >>= \case
querymagic' magic f = liftIO (isPointerFile (toRawFilePath f)) >>= \case
-- Avoid getting magic of a pointer file, which would
-- wrongly be detected as text.
Just _ -> return Nothing
-- When the file is an annex symlink, get magic of the
-- object file.
Nothing -> isAnnexLink f >>= \case
Nothing -> isAnnexLink (toRawFilePath f) >>= \case
Just k -> withObjectLoc k $ querymagic magic
Nothing -> querymagic magic f
@ -143,7 +143,7 @@ matchLockStatus :: Bool -> MatchInfo -> Annex Bool
matchLockStatus _ (MatchingKey _ _) = pure False
matchLockStatus _ (MatchingInfo _) = pure False
matchLockStatus wantlocked (MatchingFile fi) = liftIO $ do
islocked <- isPointerFile (currFile fi) >>= \case
islocked <- isPointerFile (toRawFilePath (currFile fi)) >>= \case
Just _key -> return False
Nothing -> isSymbolicLink
<$> getSymbolicLinkStatus (currFile fi)
@ -192,7 +192,7 @@ limitInDir dir = const go
where
go (MatchingFile fi) = checkf $ matchFile fi
go (MatchingKey _ (AssociatedFile Nothing)) = return False
go (MatchingKey _ (AssociatedFile (Just af))) = checkf af
go (MatchingKey _ (AssociatedFile (Just af))) = checkf (fromRawFilePath af)
go (MatchingInfo p) = checkf =<< getInfo (providedFilePath p)
checkf = return . elem dir . splitPath . takeDirectory
@ -368,7 +368,7 @@ addAccessedWithin duration = do
secs = fromIntegral (durationSeconds duration)
lookupFileKey :: FileInfo -> Annex (Maybe Key)
lookupFileKey = lookupFile . currFile
lookupFileKey = lookupFile . toRawFilePath . currFile
checkKey :: (Key -> Annex Bool) -> MatchInfo -> Annex Bool
checkKey a (MatchingFile fi) = lookupFileKey fi >>= maybe (return False) a

2
Limit/Wanted.hs
View file

@ -21,6 +21,6 @@ addWantDrop = addLimit $ Right $ const $ checkWant $
wantDrop False Nothing Nothing
checkWant :: (AssociatedFile -> Annex Bool) -> MatchInfo -> Annex Bool
checkWant a (MatchingFile fi) = a (AssociatedFile (Just $ matchFile fi))
checkWant a (MatchingFile fi) = a (AssociatedFile (Just $ toRawFilePath $ matchFile fi))
checkWant a (MatchingKey _ af) = a af
checkWant _ (MatchingInfo {}) = return False

137
Logs.hs
View file

@ -5,11 +5,15 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Logs where
import Annex.Common
import Annex.DirHashes
import qualified Data.ByteString as S
{- There are several varieties of log file formats. -}
data LogVariety
= OldUUIDBasedLog
@ -22,7 +26,7 @@ data LogVariety
{- Converts a path from the git-annex branch into one of the varieties
- of logs used by git-annex, if it's a known path. -}
getLogVariety :: FilePath -> Maybe LogVariety
getLogVariety :: RawFilePath -> Maybe LogVariety
getLogVariety f
| f `elem` topLevelOldUUIDBasedLogs = Just OldUUIDBasedLog
| f `elem` topLevelNewUUIDBasedLogs = Just NewUUIDBasedLog
@ -34,7 +38,7 @@ getLogVariety f
| otherwise = PresenceLog <$> firstJust (presenceLogs f)
{- All the old-format uuid-based logs stored in the top of the git-annex branch. -}
topLevelOldUUIDBasedLogs :: [FilePath]
topLevelOldUUIDBasedLogs :: [RawFilePath]
topLevelOldUUIDBasedLogs =
[ uuidLog
, remoteLog
@ -49,161 +53,172 @@ topLevelOldUUIDBasedLogs =
]
{- All the new-format uuid-based logs stored in the top of the git-annex branch. -}
topLevelNewUUIDBasedLogs :: [FilePath]
topLevelNewUUIDBasedLogs :: [RawFilePath]
topLevelNewUUIDBasedLogs =
[ exportLog
]
{- All the ways to get a key from a presence log file -}
presenceLogs :: FilePath -> [Maybe Key]
presenceLogs :: RawFilePath -> [Maybe Key]
presenceLogs f =
[ urlLogFileKey f
, locationLogFileKey f
]
{- Top-level logs that are neither UUID based nor presence logs. -}
otherLogs :: [FilePath]
otherLogs :: [RawFilePath]
otherLogs =
[ numcopiesLog
, groupPreferredContentLog
]
uuidLog :: FilePath
uuidLog :: RawFilePath
uuidLog = "uuid.log"
numcopiesLog :: FilePath
numcopiesLog :: RawFilePath
numcopiesLog = "numcopies.log"
configLog :: FilePath
configLog :: RawFilePath
configLog = "config.log"
remoteLog :: FilePath
remoteLog :: RawFilePath
remoteLog = "remote.log"
trustLog :: FilePath
trustLog :: RawFilePath
trustLog = "trust.log"
groupLog :: FilePath
groupLog :: RawFilePath
groupLog = "group.log"
preferredContentLog :: FilePath
preferredContentLog :: RawFilePath
preferredContentLog = "preferred-content.log"
requiredContentLog :: FilePath
requiredContentLog :: RawFilePath
requiredContentLog = "required-content.log"
groupPreferredContentLog :: FilePath
groupPreferredContentLog :: RawFilePath
groupPreferredContentLog = "group-preferred-content.log"
scheduleLog :: FilePath
scheduleLog :: RawFilePath
scheduleLog = "schedule.log"
activityLog :: FilePath
activityLog :: RawFilePath
activityLog = "activity.log"
differenceLog :: FilePath
differenceLog :: RawFilePath
differenceLog = "difference.log"
multicastLog :: FilePath
multicastLog :: RawFilePath
multicastLog = "multicast.log"
exportLog :: FilePath
exportLog :: RawFilePath
exportLog = "export.log"
{- The pathname of the location log file for a given key. -}
locationLogFile :: GitConfig -> Key -> String
locationLogFile config key = branchHashDir config key </> keyFile key ++ ".log"
locationLogFile :: GitConfig -> Key -> RawFilePath
locationLogFile config key = toRawFilePath $
branchHashDir config key </> keyFile key ++ ".log"
{- The filename of the url log for a given key. -}
urlLogFile :: GitConfig -> Key -> FilePath
urlLogFile config key = branchHashDir config key </> keyFile key ++ urlLogExt
urlLogFile :: GitConfig -> Key -> RawFilePath
urlLogFile config key = toRawFilePath $
branchHashDir config key </> keyFile key ++ decodeBS' urlLogExt
{- Old versions stored the urls elsewhere. -}
oldurlLogs :: GitConfig -> Key -> [FilePath]
oldurlLogs config key =
oldurlLogs :: GitConfig -> Key -> [RawFilePath]
oldurlLogs config key = map toRawFilePath
[ "remote/web" </> hdir </> serializeKey key ++ ".log"
, "remote/web" </> hdir </> keyFile key ++ ".log"
]
where
hdir = branchHashDir config key
urlLogExt :: String
urlLogExt :: S.ByteString
urlLogExt = ".log.web"
{- Does not work on oldurllogs. -}
isUrlLog :: FilePath -> Bool
isUrlLog file = urlLogExt `isSuffixOf` file
isUrlLog :: RawFilePath -> Bool
isUrlLog file = urlLogExt `S.isSuffixOf` file
{- The filename of the remote state log for a given key. -}
remoteStateLogFile :: GitConfig -> Key -> FilePath
remoteStateLogFile config key = branchHashDir config key
</> keyFile key ++ remoteStateLogExt
remoteStateLogFile :: GitConfig -> Key -> RawFilePath
remoteStateLogFile config key =
toRawFilePath (branchHashDir config key </> keyFile key)
<> remoteStateLogExt
remoteStateLogExt :: String
remoteStateLogExt :: S.ByteString
remoteStateLogExt = ".log.rmt"
isRemoteStateLog :: FilePath -> Bool
isRemoteStateLog path = remoteStateLogExt `isSuffixOf` path
isRemoteStateLog :: RawFilePath -> Bool
isRemoteStateLog path = remoteStateLogExt `S.isSuffixOf` path
{- The filename of the chunk log for a given key. -}
chunkLogFile :: GitConfig -> Key -> FilePath
chunkLogFile config key = branchHashDir config key </> keyFile key ++ chunkLogExt
chunkLogFile :: GitConfig -> Key -> RawFilePath
chunkLogFile config key =
toRawFilePath (branchHashDir config key </> keyFile key)
<> chunkLogExt
chunkLogExt :: String
chunkLogExt :: S.ByteString
chunkLogExt = ".log.cnk"
isChunkLog :: FilePath -> Bool
isChunkLog path = chunkLogExt `isSuffixOf` path
isChunkLog :: RawFilePath -> Bool
isChunkLog path = chunkLogExt `S.isSuffixOf` path
{- The filename of the metadata log for a given key. -}
metaDataLogFile :: GitConfig -> Key -> FilePath
metaDataLogFile config key = branchHashDir config key </> keyFile key ++ metaDataLogExt
metaDataLogFile :: GitConfig -> Key -> RawFilePath
metaDataLogFile config key =
toRawFilePath (branchHashDir config key </> keyFile key)
<> metaDataLogExt
metaDataLogExt :: String
metaDataLogExt :: S.ByteString
metaDataLogExt = ".log.met"
isMetaDataLog :: FilePath -> Bool
isMetaDataLog path = metaDataLogExt `isSuffixOf` path
isMetaDataLog :: RawFilePath -> Bool
isMetaDataLog path = metaDataLogExt `S.isSuffixOf` path
{- The filename of the remote metadata log for a given key. -}
remoteMetaDataLogFile :: GitConfig -> Key -> FilePath
remoteMetaDataLogFile config key = branchHashDir config key </> keyFile key ++ remoteMetaDataLogExt
remoteMetaDataLogFile :: GitConfig -> Key -> RawFilePath
remoteMetaDataLogFile config key =
toRawFilePath (branchHashDir config key </> keyFile key)
<> remoteMetaDataLogExt
remoteMetaDataLogExt :: String
remoteMetaDataLogExt :: S.ByteString
remoteMetaDataLogExt = ".log.rmet"
isRemoteMetaDataLog :: FilePath -> Bool
isRemoteMetaDataLog path = remoteMetaDataLogExt `isSuffixOf` path
isRemoteMetaDataLog :: RawFilePath -> Bool
isRemoteMetaDataLog path = remoteMetaDataLogExt `S.isSuffixOf` path
{- The filename of the remote content identifier log for a given key. -}
remoteContentIdentifierLogFile :: GitConfig -> Key -> FilePath
remoteContentIdentifierLogFile config key = branchHashDir config key </> keyFile key ++ remoteContentIdentifierExt
remoteContentIdentifierLogFile :: GitConfig -> Key -> RawFilePath
remoteContentIdentifierLogFile config key =
toRawFilePath (branchHashDir config key </> keyFile key)
<> remoteContentIdentifierExt
remoteContentIdentifierExt :: String
remoteContentIdentifierExt :: S.ByteString
remoteContentIdentifierExt = ".log.cid"
isRemoteContentIdentifierLog :: FilePath -> Bool
isRemoteContentIdentifierLog path = remoteContentIdentifierExt `isSuffixOf` path
isRemoteContentIdentifierLog :: RawFilePath -> Bool
isRemoteContentIdentifierLog path = remoteContentIdentifierExt `S.isSuffixOf` path
{- From an extension and a log filename, get the key that it's a log for. -}
extLogFileKey :: String -> FilePath -> Maybe Key
extLogFileKey :: S.ByteString -> RawFilePath -> Maybe Key
extLogFileKey expectedext path
| ext == expectedext = fileKey base
| encodeBS' ext == expectedext = fileKey base
| otherwise = Nothing
where
file = takeFileName path
file = takeFileName (fromRawFilePath path)
(base, ext) = splitAt (length file - extlen) file
extlen = length expectedext
extlen = S.length expectedext
{- Converts a url log file into a key.
- (Does not work on oldurlLogs.) -}
urlLogFileKey :: FilePath -> Maybe Key
urlLogFileKey :: RawFilePath -> Maybe Key
urlLogFileKey = extLogFileKey urlLogExt
{- Converts a pathname into a key if it's a location log. -}
locationLogFileKey :: FilePath -> Maybe Key
locationLogFileKey :: RawFilePath -> Maybe Key
locationLogFileKey path
-- Want only xx/yy/foo.log, not .log files in other places.
| length (splitDirectories path) /= 3 = Nothing
| length (splitDirectories (fromRawFilePath path)) /= 3 = Nothing
| otherwise = extLogFileKey ".log" path

11
Logs/Export.hs
View file

@ -37,6 +37,8 @@ import qualified Data.ByteString.Lazy as L
import qualified Data.Attoparsec.ByteString.Lazy as A
import qualified Data.Attoparsec.ByteString.Char8 as A8
import Data.ByteString.Builder
import Data.Either
import Data.Char
-- This constuctor is not itself exported to other modules, to enforce
-- consistent use of exportedTreeishes.
@ -176,8 +178,9 @@ logExportExcluded u a = do
getExportExcluded :: UUID -> Annex [Git.Tree.TreeItem]
getExportExcluded u = do
logf <- fromRepo $ gitAnnexExportExcludeLog u
liftIO $ catchDefaultIO [] $
(map parser . lines)
<$> readFile logf
liftIO $ catchDefaultIO [] $ parser <$> L.readFile logf
where
parser = Git.Tree.lsTreeItemToTreeItem . Git.LsTree.parseLsTree
parser = map Git.Tree.lsTreeItemToTreeItem
. rights
. map Git.LsTree.parseLsTree
. L.split (fromIntegral $ ord '\n')

2
Logs/Location.hs
View file

@ -71,7 +71,7 @@ loggedLocationsHistorical = getLoggedLocations . historicalLogInfo
loggedLocationsRef :: Ref -> Annex [UUID]
loggedLocationsRef ref = map (toUUID . fromLogInfo) . getLog <$> catObject ref
getLoggedLocations :: (FilePath -> Annex [LogInfo]) -> Key -> Annex [UUID]
getLoggedLocations :: (RawFilePath -> Annex [LogInfo]) -> Key -> Annex [UUID]
getLoggedLocations getter key = do
config <- Annex.getGitConfig
map (toUUID . fromLogInfo) <$> getter (locationLogFile config key)

8
Logs/MetaData.hs
View file

@ -57,7 +57,7 @@ import qualified Data.Map as M
getCurrentMetaData :: Key -> Annex MetaData
getCurrentMetaData = getCurrentMetaData' metaDataLogFile
getCurrentMetaData' :: (GitConfig -> Key -> FilePath) -> Key -> Annex MetaData
getCurrentMetaData' :: (GitConfig -> Key -> RawFilePath) -> Key -> Annex MetaData
getCurrentMetaData' getlogfile k = do
config <- Annex.getGitConfig
ls <- S.toAscList <$> readLog (getlogfile config k)
@ -95,7 +95,7 @@ getCurrentRemoteMetaData (RemoteStateHandle u) k = extractRemoteMetaData u <$>
addMetaData :: Key -> MetaData -> Annex ()
addMetaData = addMetaData' metaDataLogFile
addMetaData' :: (GitConfig -> Key -> FilePath) -> Key -> MetaData -> Annex ()
addMetaData' :: (GitConfig -> Key -> RawFilePath) -> Key -> MetaData -> Annex ()
addMetaData' getlogfile k metadata =
addMetaDataClocked' getlogfile k metadata =<< liftIO currentVectorClock
@ -106,7 +106,7 @@ addMetaData' getlogfile k metadata =
addMetaDataClocked :: Key -> MetaData -> VectorClock -> Annex ()
addMetaDataClocked = addMetaDataClocked' metaDataLogFile
addMetaDataClocked' :: (GitConfig -> Key -> FilePath) -> Key -> MetaData -> VectorClock -> Annex ()
addMetaDataClocked' :: (GitConfig -> Key -> RawFilePath) -> Key -> MetaData -> VectorClock -> Annex ()
addMetaDataClocked' getlogfile k d@(MetaData m) c
| d == emptyMetaData = noop
| otherwise = do
@ -151,5 +151,5 @@ copyMetaData oldkey newkey
const $ buildLog l
return True
readLog :: FilePath -> Annex (Log MetaData)
readLog :: RawFilePath -> Annex (Log MetaData)
readLog = parseLog <$$> Annex.Branch.get

2
Logs/PreferredContent/Raw.hs
View file

@ -28,7 +28,7 @@ preferredContentSet = setLog preferredContentLog
requiredContentSet :: UUID -> PreferredContentExpression -> Annex ()
requiredContentSet = setLog requiredContentLog
setLog :: FilePath -> UUID -> PreferredContentExpression -> Annex ()
setLog :: RawFilePath -> UUID -> PreferredContentExpression -> Annex ()
setLog logfile uuid@(UUID _) val = do
c <- liftIO currentVectorClock
Annex.Branch.change logfile $

12
Logs/Presence.hs
View file

@ -30,7 +30,7 @@ import Git.Types (RefDate)
{- Adds a LogLine to the log, removing any LogLines that are obsoleted by
- adding it. -}
addLog :: FilePath -> LogLine -> Annex ()
addLog :: RawFilePath -> LogLine -> Annex ()
addLog file line = Annex.Branch.change file $ \b ->
buildLog $ compactLog (line : parseLog b)
@ -38,14 +38,14 @@ addLog file line = Annex.Branch.change file $ \b ->
- older timestamp, that LogLine is preserved, rather than updating the log
- with a newer timestamp.
-}
maybeAddLog :: FilePath -> LogLine -> Annex ()
maybeAddLog :: RawFilePath -> LogLine -> Annex ()
maybeAddLog file line = Annex.Branch.maybeChange file $ \s -> do
m <- insertNewStatus line $ logMap $ parseLog s
return $ buildLog $ mapLog m
{- Reads a log file.
- Note that the LogLines returned may be in any order. -}
readLog :: FilePath -> Annex [LogLine]
readLog :: RawFilePath -> Annex [LogLine]
readLog = parseLog <$$> Annex.Branch.get
{- Generates a new LogLine with the current time. -}
@ -55,10 +55,10 @@ logNow s i = do
return $ LogLine c s i
{- Reads a log and returns only the info that is still in effect. -}
currentLogInfo :: FilePath -> Annex [LogInfo]
currentLogInfo :: RawFilePath -> Annex [LogInfo]
currentLogInfo file = map info <$> currentLog file
currentLog :: FilePath -> Annex [LogLine]
currentLog :: RawFilePath -> Annex [LogLine]
currentLog file = filterPresent <$> readLog file
{- Reads a historical version of a log and returns the info that was in
@ -66,6 +66,6 @@ currentLog file = filterPresent <$> readLog file
-
- The date is formatted as shown in gitrevisions man page.
-}
historicalLogInfo :: RefDate -> FilePath -> Annex [LogInfo]
historicalLogInfo :: RefDate -> RawFilePath -> Annex [LogInfo]
historicalLogInfo refdate file = map info . filterPresent . parseLog
<$> Annex.Branch.getHistorical refdate file

6
Logs/SingleValue.hs
View file

@ -25,13 +25,13 @@ import Annex.VectorClock
import qualified Data.Set as S
readLog :: (Ord v, SingleValueSerializable v) => FilePath -> Annex (Log v)
readLog :: (Ord v, SingleValueSerializable v) => RawFilePath -> Annex (Log v)
readLog = parseLog <$$> Annex.Branch.get
getLog :: (Ord v, SingleValueSerializable v) => FilePath -> Annex (Maybe v)
getLog :: (Ord v, SingleValueSerializable v) => RawFilePath -> Annex (Maybe v)
getLog = newestValue <$$> readLog
setLog :: (SingleValueSerializable v) => FilePath -> v -> Annex ()
setLog :: (SingleValueSerializable v) => RawFilePath -> v -> Annex ()
setLog f v = do
c <- liftIO currentVectorClock
let ent = LogEntry c v

6
Logs/Transfer.hs
View file

@ -31,7 +31,7 @@ describeTransfer :: Transfer -> TransferInfo -> String
describeTransfer t info = unwords
[ show $ transferDirection t
, show $ transferUUID t
, actionItemDesc $ ActionItemAssociatedFile
, decodeBS' $ actionItemDesc $ ActionItemAssociatedFile
(associatedFile info)
(transferKey t)
, show $ bytesComplete info
@ -245,7 +245,7 @@ writeTransferInfo info = unlines
#endif
-- comes last; arbitrary content
, let AssociatedFile afile = associatedFile info
in fromMaybe "" afile
in maybe "" fromRawFilePath afile
]
readTransferInfoFile :: Maybe PID -> FilePath -> IO (Maybe TransferInfo)
@ -263,7 +263,7 @@ readTransferInfo mpid s = TransferInfo
<*> pure Nothing
<*> pure Nothing
<*> bytes
<*> pure (AssociatedFile (if null filename then Nothing else Just filename))
<*> pure (AssociatedFile (if null filename then Nothing else Just (toRawFilePath filename)))
<*> pure False
where
#ifdef mingw32_HOST_OS

6
Logs/Transitions.hs
View file

@ -12,6 +12,8 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Logs.Transitions where
import Annex.Common
@ -26,7 +28,7 @@ import qualified Data.ByteString.Lazy as L
import qualified Data.Attoparsec.ByteString.Lazy as A
import qualified Data.Attoparsec.ByteString.Char8 as A8
transitionsLog :: FilePath
transitionsLog :: RawFilePath
transitionsLog = "transitions.log"
data Transition
@ -94,6 +96,6 @@ knownTransitionList = nub . rights . map transition . S.elems
{- Typically ran with Annex.Branch.change, but we can't import Annex.Branch
- here since it depends on this module. -}
recordTransitions :: (FilePath -> (L.ByteString -> Builder) -> Annex ()) -> Transitions -> Annex ()
recordTransitions :: (RawFilePath -> (L.ByteString -> Builder) -> Annex ()) -> Transitions -> Annex ()
recordTransitions changer t = changer transitionsLog $
buildTransitions . S.union t . parseTransitionsStrictly "local"

2
Logs/Web.hs
View file

@ -93,7 +93,7 @@ knownUrls = do
Annex.Branch.update
Annex.Branch.commit =<< Annex.Branch.commitMessage
Annex.Branch.withIndex $ do
top <- fromRepo Git.repoPath
top <- toRawFilePath <$> fromRepo Git.repoPath
(l, cleanup) <- inRepo $ Git.LsFiles.stagedDetails [top]
r <- mapM getkeyurls l
void $ liftIO cleanup

32
Messages.hs
View file

@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Messages (
showStart,
showStart',
@ -53,6 +55,7 @@ import System.Log.Formatter
import System.Log.Handler (setFormatter)
import System.Log.Handler.Simple
import Control.Concurrent
import qualified Data.ByteString as S
import Common
import Types
@ -66,21 +69,21 @@ import Messages.Concurrent
import qualified Messages.JSON as JSON
import qualified Annex
showStart :: String -> FilePath -> Annex ()
showStart :: String -> RawFilePath -> Annex ()
showStart command file = outputMessage json $
command ++ " " ++ file ++ " "
encodeBS' command <> " " <> file <> " "
where
json = JSON.start command (Just file) Nothing
showStart' :: String -> Maybe String -> Annex ()
showStart' command mdesc = outputMessage json $
showStart' command mdesc = outputMessage json $ encodeBS' $
command ++ (maybe "" (" " ++) mdesc) ++ " "
where
json = JSON.start command Nothing Nothing
showStartKey :: String -> Key -> ActionItem -> Annex ()
showStartKey command key i = outputMessage json $
command ++ " " ++ actionItemDesc i ++ " "
encodeBS' command <> " " <> actionItemDesc i <> " "
where
json = JSON.start command (actionItemWorkTreeFile i) (Just key)
@ -112,7 +115,7 @@ showEndMessage (StartNoMessage _) = const noop
showEndMessage (CustomOutput _) = const noop
showNote :: String -> Annex ()
showNote s = outputMessage (JSON.note s) $ "(" ++ s ++ ") "
showNote s = outputMessage (JSON.note s) $ encodeBS' $ "(" ++ s ++ ") "
showAction :: String -> Annex ()
showAction s = showNote $ s ++ "..."
@ -127,7 +130,7 @@ showSideAction m = Annex.getState Annex.output >>= go
Annex.changeState $ \s -> s { Annex.output = st' }
| sideActionBlock st == InBlock = return ()
| otherwise = p
p = outputMessage JSON.none $ "(" ++ m ++ "...)\n"
p = outputMessage JSON.none $ encodeBS' $ "(" ++ m ++ "...)\n"
showStoringStateAction :: Annex ()
showStoringStateAction = showSideAction "recording state in git"
@ -171,7 +174,7 @@ showOutput = unlessM commandProgressDisabled $
outputMessage JSON.none "\n"
showLongNote :: String -> Annex ()
showLongNote s = outputMessage (JSON.note s) (formatLongNote s)
showLongNote s = outputMessage (JSON.note s) (encodeBS' (formatLongNote s))
formatLongNote :: String -> String
formatLongNote s = '\n' : indent s ++ "\n"
@ -179,7 +182,8 @@ formatLongNote s = '\n' : indent s ++ "\n"
-- Used by external special remote, displayed same as showLongNote
-- to console, but json object containing the info is emitted immediately.
showInfo :: String -> Annex ()
showInfo s = outputMessage' outputJSON (JSON.info s) (formatLongNote s)
showInfo s = outputMessage' outputJSON (JSON.info s) $
encodeBS' (formatLongNote s)
showEndOk :: Annex ()
showEndOk = showEndResult True
@ -188,9 +192,9 @@ showEndFail :: Annex ()
showEndFail = showEndResult False
showEndResult :: Bool -> Annex ()
showEndResult ok = outputMessage (JSON.end ok) $ endResult ok ++ "\n"
showEndResult ok = outputMessage (JSON.end ok) $ endResult ok <> "\n"
endResult :: Bool -> String
endResult :: Bool -> S.ByteString
endResult True = "ok"
endResult False = "failed"
@ -238,11 +242,11 @@ showCustom command a = do
r <- a
outputMessage (JSON.end r) ""
showHeader :: String -> Annex ()
showHeader h = outputMessage JSON.none $ (h ++ ": ")
showHeader :: S.ByteString -> Annex ()
showHeader h = outputMessage JSON.none (h <> ": ")
showRaw :: String -> Annex ()
showRaw s = outputMessage JSON.none (s ++ "\n")
showRaw :: S.ByteString -> Annex ()
showRaw s = outputMessage JSON.none (s <> "\n")
setupConsole :: IO ()
setupConsole = do

10
Messages/Internal.hs
View file

@ -14,17 +14,19 @@ import Messages.Concurrent
import qualified Messages.JSON as JSON
import Messages.JSON (JSONBuilder)
import qualified Data.ByteString as S
withMessageState :: (MessageState -> Annex a) -> Annex a
withMessageState a = Annex.getState Annex.output >>= a
outputMessage :: JSONBuilder -> String -> Annex ()
outputMessage :: JSONBuilder -> S.ByteString -> Annex ()
outputMessage = outputMessage' bufferJSON
outputMessage' :: (JSONBuilder -> MessageState -> Annex Bool) -> JSONBuilder -> String -> Annex ()
outputMessage' :: (JSONBuilder -> MessageState -> Annex Bool) -> JSONBuilder -> S.ByteString -> Annex ()
outputMessage' jsonoutputter jsonbuilder msg = withMessageState $ \s -> case outputType s of
NormalOutput
| concurrentOutputEnabled s -> concurrentMessage s False msg q
| otherwise -> liftIO $ flushed $ putStr msg
| concurrentOutputEnabled s -> concurrentMessage s False (decodeBS msg) q
| otherwise -> liftIO $ flushed $ S.putStr msg
JSONOutput _ -> void $ jsonoutputter jsonbuilder s
QuietOutput -> q

5
Messages/JSON.hs
View file

@ -43,6 +43,7 @@ import Key
import Utility.Metered
import Utility.Percentage
import Utility.Aeson
import Utility.FileSystemEncoding
-- A global lock to avoid concurrent threads emitting json at the same time.
{-# NOINLINE emitLock #-}
@ -63,13 +64,13 @@ type JSONBuilder = Maybe (Object, Bool) -> Maybe (Object, Bool)
none :: JSONBuilder
none = id
start :: String -> Maybe FilePath -> Maybe Key -> JSONBuilder
start :: String -> Maybe RawFilePath -> Maybe Key -> JSONBuilder
start command file key _ = Just (o, False)
where
Object o = toJSON' $ JSONActionItem
{ itemCommand = Just command
, itemKey = key
, itemFile = file
, itemFile = fromRawFilePath <$> file
, itemAdded = Nothing
}

1
Messages/Progress.hs
View file

@ -6,6 +6,7 @@
-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Messages.Progress where

7
P2P/Protocol.hs
View file

@ -22,6 +22,7 @@ import Utility.AuthToken
import Utility.Applicative
import Utility.PartialPrelude
import Utility.Metered
import Utility.FileSystemEncoding
import Git.FilePath
import Annex.ChangedRefs (ChangedRefs)
@ -166,17 +167,17 @@ instance Proto.Serializable Service where
instance Proto.Serializable AssociatedFile where
serialize (AssociatedFile Nothing) = ""
serialize (AssociatedFile (Just af)) =
toInternalGitPath $ concatMap esc af
decodeBS' $ toInternalGitPath $ encodeBS' $ concatMap esc $ fromRawFilePath af
where
esc '%' = "%%"
esc c
| isSpace c = "%"
| otherwise = [c]
deserialize s = case fromInternalGitPath $ deesc [] s of
deserialize s = case fromRawFilePath $ fromInternalGitPath $ toRawFilePath $ deesc [] s of
[] -> Just (AssociatedFile Nothing)
f
| isRelative f -> Just (AssociatedFile (Just f))
| isRelative f -> Just $ AssociatedFile $ Just $ toRawFilePath f
| otherwise -> Nothing
where
deesc b [] = reverse b

8
Remote/Directory.hs
View file

@ -295,18 +295,18 @@ renameExportM d _k oldloc newloc = liftIO $ Just <$> go
dest = exportPath d newloc
exportPath :: FilePath -> ExportLocation -> FilePath
exportPath d loc = d </> fromExportLocation loc
exportPath d loc = d </> fromRawFilePath (fromExportLocation loc)
{- Removes the ExportLocation's parent directory and its parents, so long as
- they're empty, up to but not including the topdir. -}
removeExportLocation :: FilePath -> ExportLocation -> IO ()
removeExportLocation topdir loc =
go (Just $ takeDirectory $ fromExportLocation loc) (Right ())
go (Just $ takeDirectory $ fromRawFilePath $ fromExportLocation loc) (Right ())
where
go _ (Left _e) = return ()
go Nothing _ = return ()
go (Just loc') _ = go (upFrom loc')
=<< tryIO (removeDirectory $ exportPath topdir (mkExportLocation loc'))
=<< tryIO (removeDirectory $ exportPath topdir (mkExportLocation (toRawFilePath loc')))
listImportableContentsM :: FilePath -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize)))
listImportableContentsM dir = catchMaybeIO $ liftIO $ do
@ -319,7 +319,7 @@ listImportableContentsM dir = catchMaybeIO $ liftIO $ do
mkContentIdentifier f st >>= \case
Nothing -> return Nothing
Just cid -> do
relf <- relPathDirToFile dir f
relf <- toRawFilePath <$> relPathDirToFile dir f
sz <- getFileSize' f st
return $ Just (mkImportLocation relf, (cid, sz))

2
Remote/Git.hs
View file

@ -549,7 +549,7 @@ copyFromRemote'' repo forcersync r st@(State connpool _ _ _) key file dest meter
u <- getUUID
let AssociatedFile afile = file
let fields = (Fields.remoteUUID, fromUUID u)
: maybe [] (\f -> [(Fields.associatedFile, f)]) afile
: maybe [] (\f -> [(Fields.associatedFile, fromRawFilePath f)]) afile
Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin
repo "transferinfo"
[Param $ serializeKey key] fields

2
Remote/Helper/Ssh.hs
View file

@ -137,7 +137,7 @@ rsyncParamsRemote unlocked r direction key file (AssociatedFile afile) = do
-- Send direct field for unlocked content, for backwards
-- compatability.
: (Fields.direct, if unlocked then "1" else "")
: maybe [] (\f -> [(Fields.associatedFile, f)]) afile
: maybe [] (\f -> [(Fields.associatedFile, fromRawFilePath f)]) afile
repo <- getRepo r
Just (shellcmd, shellparams) <- git_annex_shell ConsumeStdin repo
(if direction == Download then "sendkey" else "recvkey")

6
Remote/List.hs
View file

@ -24,6 +24,7 @@ import qualified Git
import qualified Git.Config
import qualified Remote.Git
{-
import qualified Remote.GCrypt
import qualified Remote.P2P
#ifdef WITH_S3
@ -44,10 +45,12 @@ import qualified Remote.Ddar
import qualified Remote.GitLFS
import qualified Remote.Hook
import qualified Remote.External
-}
remoteTypes :: [RemoteType]
remoteTypes = map adjustExportImportRemoteType
[ Remote.Git.remote
{-
, Remote.GCrypt.remote
, Remote.P2P.remote
#ifdef WITH_S3
@ -68,6 +71,7 @@ remoteTypes = map adjustExportImportRemoteType
, Remote.GitLFS.remote
, Remote.Hook.remote
, Remote.External.remote
-}
]
{- Builds a list of all available Remotes.
@ -129,7 +133,9 @@ updateRemote remote = do
gitSyncableRemote :: Remote -> Bool
gitSyncableRemote r = remotetype r `elem`
[ Remote.Git.remote
{-
, Remote.GCrypt.remote
, Remote.P2P.remote
, Remote.GitLFS.remote
-}
]

10
Remote/Rsync.hs
View file

@ -268,22 +268,22 @@ storeExportM :: RsyncOpts -> FilePath -> Key -> ExportLocation -> MeterUpdate ->
storeExportM o src _k loc meterupdate =
storeGeneric o meterupdate basedest populatedest
where
basedest = fromExportLocation loc
basedest = fromRawFilePath (fromExportLocation loc)
populatedest = liftIO . createLinkOrCopy src
retrieveExportM :: RsyncOpts -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
retrieveExportM o _k loc dest p = rsyncRetrieve o [rsyncurl] dest (Just p)
where
rsyncurl = mkRsyncUrl o (fromExportLocation loc)
rsyncurl = mkRsyncUrl o (fromRawFilePath (fromExportLocation loc))
checkPresentExportM :: RsyncOpts -> Key -> ExportLocation -> Annex Bool
checkPresentExportM o _k loc = checkPresentGeneric o [rsyncurl]
where
rsyncurl = mkRsyncUrl o (fromExportLocation loc)
rsyncurl = mkRsyncUrl o (fromRawFilePath (fromExportLocation loc))
removeExportM :: RsyncOpts -> Key -> ExportLocation -> Annex Bool
removeExportM o _k loc =
removeGeneric o (includes (fromExportLocation loc))
removeGeneric o $ includes $ fromRawFilePath $ fromExportLocation loc
where
includes f = f : case upFrom f of
Nothing -> []
@ -292,7 +292,7 @@ removeExportM o _k loc =
removeExportDirectoryM :: RsyncOpts -> ExportDirectory -> Annex Bool
removeExportDirectoryM o ed = removeGeneric o (allbelow d : includes d)
where
d = fromExportDirectory ed
d = fromRawFilePath $ fromExportDirectory ed
allbelow f = f </> "***"
includes f = f : case upFrom f of
Nothing -> []

7
Test.hs
View file

@ -204,12 +204,17 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck"
- of git-annex. They are always run before the unitTests. -}
initTests :: TestTree
initTests = testGroup "Init Tests"
[]
{-
[ testCase "init" test_init
, testCase "add" test_add
]
-}
unitTests :: String -> TestTree
unitTests note = testGroup ("Unit Tests " ++ note)
[]
{-
[ testCase "add dup" test_add_dup
, testCase "add extras" test_add_extras
, testCase "export_import" test_export_import
@ -1776,3 +1781,5 @@ test_export_import_subdir = intmpclonerepo $ do
-- Make sure that import did not import the file to the top
-- of the repo.
checkdoesnotexist annexedfile
-}

8
Test/Framework.hs
View file

@ -254,7 +254,7 @@ finalCleanup = whenM (doesDirectoryExist tmpdir) $ do
checklink :: FilePath -> Assertion
checklink f = ifM (annexeval Config.crippledFileSystem)
( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget f))
( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget (toRawFilePath f)))
@? f ++ " is not a (crippled) symlink"
, do
s <- getSymbolicLinkStatus f
@ -312,7 +312,7 @@ checkdangling f = ifM (annexeval Config.crippledFileSystem)
checklocationlog :: FilePath -> Bool -> Assertion
checklocationlog f expected = do
thisuuid <- annexeval Annex.UUID.getUUID
r <- annexeval $ Annex.WorkTree.lookupFile f
r <- annexeval $ Annex.WorkTree.lookupFile (toRawFilePath f)
case r of
Just k -> do
uuids <- annexeval $ Remote.keyLocations k
@ -323,11 +323,11 @@ checklocationlog f expected = do
checkbackend :: FilePath -> Types.Backend -> Assertion
checkbackend file expected = do
b <- annexeval $ maybe (return Nothing) (Backend.getBackend file)
=<< Annex.WorkTree.lookupFile file
=<< Annex.WorkTree.lookupFile (toRawFilePath file)
assertEqual ("backend for " ++ file) (Just expected) b
checkispointerfile :: FilePath -> Assertion
checkispointerfile f = unlessM (isJust <$> Annex.Link.isPointerFile f) $
checkispointerfile f = unlessM (isJust <$> Annex.Link.isPointerFile (toRawFilePath f)) $
assertFailure $ f ++ " is not a pointer file"
inlocationlog :: FilePath -> Assertion

18
Types/ActionItem.hs
View file

@ -12,15 +12,17 @@ module Types.ActionItem where
import Key
import Types.Transfer
import Git.FilePath
import Utility.FileSystemEncoding
import Data.Maybe
import qualified Data.ByteString as S
data ActionItem
= ActionItemAssociatedFile AssociatedFile Key
| ActionItemKey Key
| ActionItemBranchFilePath BranchFilePath Key
| ActionItemFailedTransfer Transfer TransferInfo
| ActionItemWorkTreeFile FilePath
| ActionItemWorkTreeFile RawFilePath
| ActionItemOther (Maybe String)
-- Use to avoid more than one thread concurrently processing the
-- same Key.
@ -39,10 +41,10 @@ instance MkActionItem (AssociatedFile, Key) where
instance MkActionItem (Key, AssociatedFile) where
mkActionItem = uncurry $ flip ActionItemAssociatedFile
instance MkActionItem (Key, FilePath) where
instance MkActionItem (Key, RawFilePath) where
mkActionItem (key, file) = ActionItemAssociatedFile (AssociatedFile (Just file)) key
instance MkActionItem (FilePath, Key) where
instance MkActionItem (RawFilePath, Key) where
mkActionItem (file, key) = mkActionItem (key, file)
instance MkActionItem Key where
@ -54,16 +56,16 @@ instance MkActionItem (BranchFilePath, Key) where
instance MkActionItem (Transfer, TransferInfo) where
mkActionItem = uncurry ActionItemFailedTransfer
actionItemDesc :: ActionItem -> String
actionItemDesc :: ActionItem -> S.ByteString
actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f)) _) = f
actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing) k) =
serializeKey k
actionItemDesc (ActionItemKey k) = serializeKey k
serializeKey' k
actionItemDesc (ActionItemKey k) = serializeKey' k
actionItemDesc (ActionItemBranchFilePath bfp _) = descBranchFilePath bfp
actionItemDesc (ActionItemFailedTransfer t i) = actionItemDesc $
ActionItemAssociatedFile (associatedFile i) (transferKey t)
actionItemDesc (ActionItemWorkTreeFile f) = f
actionItemDesc (ActionItemOther s) = fromMaybe "" s
actionItemDesc (ActionItemOther s) = encodeBS' (fromMaybe "" s)
actionItemDesc (OnlyActionOn _ ai) = actionItemDesc ai
actionItemKey :: ActionItem -> Maybe Key
@ -75,7 +77,7 @@ actionItemKey (ActionItemWorkTreeFile _) = Nothing
actionItemKey (ActionItemOther _) = Nothing
actionItemKey (OnlyActionOn _ ai) = actionItemKey ai
actionItemWorkTreeFile :: ActionItem -> Maybe FilePath
actionItemWorkTreeFile :: ActionItem -> Maybe RawFilePath
actionItemWorkTreeFile (ActionItemAssociatedFile (AssociatedFile af) _) = af
actionItemWorkTreeFile (ActionItemWorkTreeFile f) = Just f
actionItemWorkTreeFile (OnlyActionOn _ ai) = actionItemWorkTreeFile ai

3
Types/Key.hs
View file

@ -36,6 +36,7 @@ import Data.ByteString.Builder
import Data.ByteString.Builder.Extra
import qualified Data.Attoparsec.ByteString as A
import qualified Data.Attoparsec.ByteString.Char8 as A8
import Utility.FileSystemEncoding
import Data.List
import System.Posix.Types
import Foreign.C.Types
@ -200,7 +201,7 @@ splitKeyNameExtension' :: S.ByteString -> (S.ByteString, S.ByteString)
splitKeyNameExtension' keyname = S8.span (/= '.') keyname
{- A filename may be associated with a Key. -}
newtype AssociatedFile = AssociatedFile (Maybe FilePath)
newtype AssociatedFile = AssociatedFile (Maybe RawFilePath)
deriving (Show, Eq, Ord)
{- There are several different varieties of keys. -}

6
Types/Transfer.hs
View file

@ -15,6 +15,7 @@ import Types.Key
import Utility.PID
import Utility.QuickCheck
import Utility.Url
import Utility.FileSystemEncoding
import Data.Time.Clock.POSIX
import Control.Concurrent
@ -71,8 +72,7 @@ instance Arbitrary TransferInfo where
<*> pure Nothing -- cannot generate a ThreadID
<*> pure Nothing -- remote not needed
<*> arbitrary
-- associated file cannot be empty (but can be Nothing)
<*> (AssociatedFile <$> arbitrary `suchThat` (/= Just ""))
<*> arbitrary
<*> arbitrary
class Observable a where
@ -101,7 +101,7 @@ class Transferrable t where
descTransfrerrable :: t -> Maybe String
instance Transferrable AssociatedFile where
descTransfrerrable (AssociatedFile af) = af
descTransfrerrable (AssociatedFile af) = fromRawFilePath <$> af
instance Transferrable URLString where
descTransfrerrable = Just

4
Upgrade.hs
View file

@ -15,6 +15,7 @@ import qualified Git
import Annex.Version
import Types.RepoVersion
#ifndef mingw32_HOST_OS
{-
import qualified Upgrade.V0
import qualified Upgrade.V1
#endif
@ -23,6 +24,7 @@ import qualified Upgrade.V3
import qualified Upgrade.V4
import qualified Upgrade.V5
import qualified Upgrade.V6
-}
import qualified Data.Map as M
@ -72,6 +74,7 @@ upgrade automatic destversion = do
)
go _ = return True
{-
#ifndef mingw32_HOST_OS
up (RepoVersion 0) = Upgrade.V0.upgrade
up (RepoVersion 1) = Upgrade.V1.upgrade
@ -84,5 +87,6 @@ upgrade automatic destversion = do
up (RepoVersion 4) = Upgrade.V4.upgrade automatic
up (RepoVersion 5) = Upgrade.V5.upgrade automatic
up (RepoVersion 6) = Upgrade.V6.upgrade automatic
-}
up _ = return True

10
Utility/Path.hs
View file

@ -43,6 +43,7 @@ import Utility.Monad
import Utility.UserInfo
import Utility.Directory
import Utility.Split
import Utility.FileSystemEncoding
{- Simplifies a path, removing any "." component, collapsing "dir/..",
- and removing the trailing path separator.
@ -200,20 +201,21 @@ prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
- we stop preserving ordering at that point. Presumably a user passing
- that many paths in doesn't care too much about order of the later ones.
-}
segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]]
segmentPaths :: [RawFilePath] -> [RawFilePath] -> [[RawFilePath]]
segmentPaths [] new = [new]
segmentPaths [_] new = [new] -- optimisation
segmentPaths (l:ls) new = found : segmentPaths ls rest
where
(found, rest) = if length ls < 100
then partition (l `dirContains`) new
else break (\p -> not (l `dirContains` p)) new
then partition inl new
else break (not . inl) new
inl f = fromRawFilePath l `dirContains` fromRawFilePath f
{- This assumes that it's cheaper to call segmentPaths on the result,
- than it would be to run the action separately with each path. In
- the case of git file list commands, that assumption tends to hold.
-}
runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
runSegmentPaths :: ([RawFilePath] -> IO [RawFilePath]) -> [RawFilePath] -> IO [[RawFilePath]]
runSegmentPaths a paths = segmentPaths paths <$> a paths
{- Converts paths in the home directory to use ~/ -}

6
git-annex.cabal
View file

@ -407,16 +407,16 @@ Executable git-annex
if flag(S3)
Build-Depends: aws (>= 0.20)
CPP-Options: -DWITH_S3
Other-Modules: Remote.S3
Other-Modules-temp-disabled: Remote.S3
if flag(WebDAV)
Build-Depends: DAV (>= 1.0)
CPP-Options: -DWITH_WEBDAV
Other-Modules:
Other-Modules-temp-disabled:
Remote.WebDAV
Remote.WebDAV.DavLocation
if flag(S3) || flag(WebDAV)
Other-Modules:
Other-Modules-temp-disabled:
Remote.Helper.Http
if flag(Assistant) && ! os(solaris) && ! os(gnu)

4
git-annex.hs
View file

@ -12,7 +12,7 @@ import System.FilePath
import Network.Socket (withSocketsDo)
import qualified CmdLine.GitAnnex
import qualified CmdLine.GitAnnexShell
--import qualified CmdLine.GitAnnexShell
import qualified CmdLine.GitRemoteTorAnnex
import qualified Test
import qualified Benchmark
@ -33,7 +33,7 @@ main = withSocketsDo $ do
run ps =<< getProgName
where
run ps n = case takeFileName n of
"git-annex-shell" -> CmdLine.GitAnnexShell.run ps
"git-annex-shell" -> error "STUBBED OUT FIXME" -- CmdLine.GitAnnexShell.run ps
"git-remote-tor-annex" -> CmdLine.GitRemoteTorAnnex.run ps
_ -> CmdLine.GitAnnex.run Test.optParser Test.runner Benchmark.mkGenerator ps

6
stack.yaml
View file

@ -1,12 +1,12 @@
flags:
git-annex:
production: true
assistant: true
assistant: false
pairing: true
s3: true
webdav: true
webdav: false
torrentparser: true
webapp: true
webapp: false
magicmime: false
dbus: false
debuglocks: false