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

30
Annex/Branch.hs
View file

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

2
Annex/Branch/Transitions.hs
View file

@ -34,7 +34,7 @@ data FileTransition
= ChangeFile Builder = ChangeFile Builder
| PreserveFile | 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 :: Transition -> Maybe TransitionCalculator
getTransitionCalculator ForgetGitHistory = Nothing getTransitionCalculator ForgetGitHistory = Nothing

18
Annex/CatFile.hs
View file

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

4
Annex/Content.hs
View file

@ -483,7 +483,7 @@ moveAnnex key src = ifM (checkSecureHashes key)
fs <- map (`fromTopFilePath` g) fs <- map (`fromTopFilePath` g)
<$> Database.Keys.getAssociatedFiles key <$> Database.Keys.getAssociatedFiles key
unless (null fs) $ do unless (null fs) $ do
ics <- mapM (populatePointerFile (Restage True) key dest) fs ics <- mapM (populatePointerFile (Restage True) key (toRawFilePath dest) . toRawFilePath) fs
Database.Keys.storeInodeCaches' key [dest] (catMaybes ics) Database.Keys.storeInodeCaches' key [dest] (catMaybes ics)
) )
alreadyhave = liftIO $ removeFile src alreadyhave = liftIO $ removeFile src
@ -650,7 +650,7 @@ removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file ->
-- Check associated pointer file for modifications, and reset if -- Check associated pointer file for modifications, and reset if
-- it's unmodified. -- it's unmodified.
resetpointer file = ifM (isUnmodified key file) resetpointer file = ifM (isUnmodified key file)
( depopulatePointerFile key file ( depopulatePointerFile key (toRawFilePath file)
-- Modified file, so leave it alone. -- Modified file, so leave it alone.
-- If it was a hard link to the annex object, -- If it was a hard link to the annex object,
-- that object might have been frozen as part of the -- 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. - 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) populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f)
where where
go (Just k') | k == k' = do go (Just k') | k == k' = do
destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f let f' = fromRawFilePath f
liftIO $ nukeFile f destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f'
(ic, populated) <- replaceFile f $ \tmp -> do liftIO $ nukeFile f'
ok <- linkOrCopy k obj tmp destmode >>= \case (ic, populated) <- replaceFile f' $ \tmp -> do
ok <- linkOrCopy k (fromRawFilePath obj) tmp destmode >>= \case
Just _ -> thawContent tmp >> return True 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) ic <- withTSDelta (liftIO . genInodeCache tmp)
return (ic, ok) return (ic, ok)
maybe noop (restagePointerFile restage f) ic 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. {- Removes the content from a pointer file, replacing it with a pointer.
- -
- Does not check if the pointer file is modified. -} - Does not check if the pointer file is modified. -}
depopulatePointerFile :: Key -> FilePath -> Annex () depopulatePointerFile :: Key -> RawFilePath -> Annex ()
depopulatePointerFile key file = do depopulatePointerFile key file = do
st <- liftIO $ catchMaybeIO $ getFileStatus file let file' = fromRawFilePath file
st <- liftIO $ catchMaybeIO $ getFileStatus file'
let mode = fmap fileMode st let mode = fmap fileMode st
secureErase file secureErase file'
liftIO $ nukeFile file liftIO $ nukeFile file'
ic <- replaceFile file $ \tmp -> do ic <- replaceFile file' $ \tmp -> do
liftIO $ writePointerFile tmp key mode liftIO $ writePointerFile (toRawFilePath tmp) key mode
#if ! defined(mingw32_HOST_OS) #if ! defined(mingw32_HOST_OS)
-- Don't advance mtime; this avoids unncessary re-smudging -- Don't advance mtime; this avoids unncessary re-smudging
-- by git in some cases. -- by git in some cases.

4
Annex/FileMatcher.hs
View file

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

10
Annex/Journal.hs
View file

@ -44,18 +44,18 @@ instance Journalable Builder where
- getJournalFileStale to always return a consistent journal file - getJournalFileStale to always return a consistent journal file
- content, although possibly not the most current one. - 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 setJournalFile _jl file content = withOtherTmp $ \tmp -> do
createAnnexDirectory =<< fromRepo gitAnnexJournalDir createAnnexDirectory =<< fromRepo gitAnnexJournalDir
-- journal file is written atomically -- journal file is written atomically
jfile <- fromRepo $ journalFile file jfile <- fromRepo $ journalFile $ fromRawFilePath file
let tmpfile = tmp </> takeFileName jfile let tmpfile = tmp </> takeFileName jfile
liftIO $ do liftIO $ do
withFile tmpfile WriteMode $ \h -> writeJournalHandle h content withFile tmpfile WriteMode $ \h -> writeJournalHandle h content
moveFile tmpfile jfile moveFile tmpfile jfile
{- Gets any journalled content for a file in the branch. -} {- 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 getJournalFile _jl = getJournalFileStale
{- Without locking, this is not guaranteed to be the most recent {- 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 - 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. - 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 $ 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 {- 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 - 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 type LinkTarget = String
{- Checks if a file is a link to a key. -} {- 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 isAnnexLink file = maybe Nothing parseLinkTargetOrPointer <$> getAnnexLinkTarget file
{- Gets the link target of a symlink. {- 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 - Returns Nothing if the file is not a symlink, or not a link to annex
- content. - content.
-} -}
getAnnexLinkTarget :: FilePath -> Annex (Maybe S.ByteString) getAnnexLinkTarget :: RawFilePath -> Annex (Maybe S.ByteString)
getAnnexLinkTarget f = getAnnexLinkTarget' f getAnnexLinkTarget f = getAnnexLinkTarget' f
=<< (coreSymlinks <$> Annex.getGitConfig) =<< (coreSymlinks <$> Annex.getGitConfig)
{- Pass False to force looking inside file, for when git checks out {- Pass False to force looking inside file, for when git checks out
- symlinks as plain files. -} - symlinks as plain files. -}
getAnnexLinkTarget' :: FilePath -> Bool -> Annex (Maybe S.ByteString) getAnnexLinkTarget' :: RawFilePath -> Bool -> Annex (Maybe S.ByteString)
getAnnexLinkTarget' file coresymlinks = if coresymlinks getAnnexLinkTarget' file coresymlinks = if coresymlinks
then check probesymlink $ then check probesymlink $
return Nothing return Nothing
@ -75,9 +75,9 @@ getAnnexLinkTarget' file coresymlinks = if coresymlinks
| otherwise -> return Nothing | otherwise -> return Nothing
Nothing -> fallback 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 s <- S.hGet h unpaddedMaxPointerSz
-- If we got the full amount, the file is too large -- If we got the full amount, the file is too large
-- to be a symlink target. -- to be a symlink target.
@ -92,7 +92,7 @@ getAnnexLinkTarget' file coresymlinks = if coresymlinks
then mempty then mempty
else s else s
makeAnnexLink :: LinkTarget -> FilePath -> Annex () makeAnnexLink :: LinkTarget -> RawFilePath -> Annex ()
makeAnnexLink = makeGitLink makeAnnexLink = makeGitLink
{- Creates a link on disk. {- 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 - it's staged as such, so use addAnnexLink when adding a new file or
- modified link to git. - modified link to git.
-} -}
makeGitLink :: LinkTarget -> FilePath -> Annex () makeGitLink :: LinkTarget -> RawFilePath -> Annex ()
makeGitLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig) makeGitLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
( liftIO $ do ( liftIO $ do
void $ tryIO $ removeFile file void $ tryIO $ removeFile (fromRawFilePath file)
createSymbolicLink linktarget file createSymbolicLink linktarget (fromRawFilePath file)
, liftIO $ writeFile file linktarget , liftIO $ writeFile (fromRawFilePath file) linktarget
) )
{- Creates a link on disk, and additionally stages it in git. -} {- Creates a link on disk, and additionally stages it in git. -}
addAnnexLink :: LinkTarget -> FilePath -> Annex () addAnnexLink :: LinkTarget -> RawFilePath -> Annex ()
addAnnexLink linktarget file = do addAnnexLink linktarget file = do
makeAnnexLink linktarget file makeAnnexLink linktarget file
stageSymlink file =<< hashSymlink linktarget stageSymlink file =<< hashSymlink linktarget
{- Injects a symlink target into git, returning its Sha. -} {- Injects a symlink target into git, returning its Sha. -}
hashSymlink :: LinkTarget -> Annex 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. -} {- Stages a symlink to an annexed object, using a Sha of its target. -}
stageSymlink :: FilePath -> Sha -> Annex () stageSymlink :: RawFilePath -> Sha -> Annex ()
stageSymlink file sha = stageSymlink file sha =
Annex.Queue.addUpdateIndex =<< 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. -} {- Injects a pointer file content into git, returning its Sha. -}
hashPointerFile :: Key -> Annex Sha hashPointerFile :: Key -> Annex Sha
hashPointerFile key = hashBlob $ formatPointer key hashPointerFile key = hashBlob $ formatPointer key
{- Stages a pointer file, using a Sha of its content -} {- 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 = stagePointerFile file mode sha =
Annex.Queue.addUpdateIndex =<< Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.stageFile sha treeitemtype file) inRepo (Git.UpdateIndex.stageFile sha treeitemtype $ fromRawFilePath file)
where where
treeitemtype treeitemtype
| maybe False isExecutable mode = TreeExecutable | maybe False isExecutable mode = TreeExecutable
| otherwise = TreeFile | otherwise = TreeFile
writePointerFile :: FilePath -> Key -> Maybe FileMode -> IO () writePointerFile :: RawFilePath -> Key -> Maybe FileMode -> IO ()
writePointerFile file k mode = do writePointerFile file k mode = do
S.writeFile file (formatPointer k) S.writeFile (fromRawFilePath file) (formatPointer k)
maybe noop (setFileMode file) mode maybe noop (setFileMode $ fromRawFilePath file) mode
newtype Restage = Restage Bool newtype Restage = Restage Bool
@ -172,17 +172,17 @@ newtype Restage = Restage Bool
- the worktree file is changed by something else before git update-index - the worktree file is changed by something else before git update-index
- gets to look at it. - gets to look at it.
-} -}
restagePointerFile :: Restage -> FilePath -> InodeCache -> Annex () restagePointerFile :: Restage -> RawFilePath -> InodeCache -> Annex ()
restagePointerFile (Restage False) f _ = restagePointerFile (Restage False) f _ =
toplevelWarning True $ unableToRestage (Just f) toplevelWarning True $ unableToRestage $ Just $ fromRawFilePath f
restagePointerFile (Restage True) f orig = withTSDelta $ \tsd -> do restagePointerFile (Restage True) f orig = withTSDelta $ \tsd -> do
-- update-index is documented as picky about "./file" and it -- update-index is documented as picky about "./file" and it
-- fails on "../../repo/path/file" when cwd is not in the repo -- fails on "../../repo/path/file" when cwd is not in the repo
-- being acted on. Avoid these problems with an absolute path. -- 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)] Annex.Queue.addInternalAction runner [(absf, isunmodified tsd)]
where where
isunmodified tsd = genInodeCache f tsd >>= return . \case isunmodified tsd = genInodeCache (fromRawFilePath f) tsd >>= return . \case
Nothing -> False Nothing -> False
Just new -> compareStrong orig new Just new -> compareStrong orig new
@ -264,7 +264,7 @@ parseLinkTarget l
formatPointer :: Key -> S.ByteString formatPointer :: Key -> S.ByteString
formatPointer k = prefix <> keyFile' k <> nl formatPointer k = prefix <> keyFile' k <> nl
where where
prefix = toRawFilePath $ toInternalGitPath (pathSeparator:objectDir) prefix = toInternalGitPath $ toRawFilePath (pathSeparator:objectDir)
nl = S8.singleton '\n' nl = S8.singleton '\n'
{- Maximum size of a file that could be a pointer to a key. {- 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. {- Checks if a worktree file is a pointer to a key.
- -
- Unlocked files whose content is present are not detected by this. -} - Unlocked files whose content is present are not detected by this. -}
isPointerFile :: FilePath -> IO (Maybe Key) isPointerFile :: RawFilePath -> IO (Maybe Key)
isPointerFile f = catchDefaultIO Nothing $ withFile f ReadMode $ \h -> isPointerFile f = catchDefaultIO Nothing $ withFile (fromRawFilePath f) ReadMode $ \h ->
parseLinkTargetOrPointer <$> S.hGet h unpaddedMaxPointerSz parseLinkTargetOrPointer <$> S.hGet h unpaddedMaxPointerSz
{- Checks a symlink target or pointer file first line to see if it {- 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 absfile = absNormPathUnix currdir file
let gitdir = getgitdir currdir let gitdir = getgitdir currdir
loc <- gitAnnexLocation' key r config False False (\_ -> return True) gitdir loc <- gitAnnexLocation' key r config False False (\_ -> return True) gitdir
toInternalGitPath <$> relPathDirToFile (parentDir absfile) loc fromRawFilePath . toInternalGitPath . toRawFilePath
<$> relPathDirToFile (parentDir absfile) loc
where where
getgitdir currdir getgitdir currdir
{- This special case is for git submodules on filesystems not {- 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. - 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 genMetaData key file status = do
catKeyFileHEAD file >>= \case catKeyFileHEAD file >>= \case
Nothing -> noop Nothing -> noop
@ -53,8 +53,8 @@ genMetaData key file status = do
where where
mtime = posixSecondsToUTCTime $ realToFrac $ modificationTime status mtime = posixSecondsToUTCTime $ realToFrac $ modificationTime status
warncopied = warning $ warncopied = warning $
"Copied metadata from old version of " ++ file ++ " to new version. " ++ "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 " ++ file "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 -- If the only fields copied were date metadata, and they'll
-- be overwritten with the current mtime, no need to warn about -- be overwritten with the current mtime, no need to warn about
-- copying. -- copying.

2
Annex/Notification.hs
View file

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

2
Annex/NumCopies.hs
View file

@ -72,7 +72,7 @@ getFileNumCopies f = fromSources
getAssociatedFileNumCopies :: AssociatedFile -> Annex NumCopies getAssociatedFileNumCopies :: AssociatedFile -> Annex NumCopies
getAssociatedFileNumCopies (AssociatedFile afile) = 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 {- This is the globally visible numcopies value for a file. So it does
- not include local configuration in the git config or command line - 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 -> (FilePath -> MetaData) -> View -> Annex Git.Branch
applyView' mkviewedfile getfilemetadata view = do applyView' mkviewedfile getfilemetadata view = do
top <- fromRepo Git.repoPath top <- fromRepo Git.repoPath
(l, clean) <- inRepo $ Git.LsFiles.stagedDetails [top] (l, clean) <- inRepo $ Git.LsFiles.stagedDetails [toRawFilePath top]
liftIO . nukeFile =<< fromRepo gitAnnexViewIndex liftIO . nukeFile =<< fromRepo gitAnnexViewIndex
uh <- withViewIndex $ inRepo Git.UpdateIndex.startUpdateIndex uh <- withViewIndex $ inRepo Git.UpdateIndex.startUpdateIndex
forM_ l $ \(f, sha, mode) -> do forM_ l $ \(f, sha, mode) -> do
topf <- inRepo (toTopFilePath f) topf <- inRepo (toTopFilePath $ fromRawFilePath f)
go uh topf sha (toTreeItemType =<< mode) =<< lookupFile f go uh topf sha (toTreeItemType =<< mode) =<< lookupFile f
liftIO $ do liftIO $ do
void $ stopUpdateIndex uh void $ stopUpdateIndex uh

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

2
Backend/Hash.hs
View file

@ -188,7 +188,7 @@ trivialMigrate' oldkey newbackend afile maxextlen
AssociatedFile Nothing -> Nothing AssociatedFile Nothing -> Nothing
AssociatedFile (Just file) -> Just $ alterKey oldkey $ \d -> d AssociatedFile (Just file) -> Just $ alterKey oldkey $ \d -> d
{ keyName = keyHash oldkey { keyName = keyHash oldkey
<> encodeBS (selectExtension maxextlen file) <> encodeBS' (selectExtension maxextlen (fromRawFilePath file))
, keyVariety = newvariety , keyVariety = newvariety
} }
{- Upgrade to fix bad previous migration that created a {- 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 = Field "associatedfile" $ \f -> associatedFile = Field "associatedfile" $ \f ->
-- is the file a safe relative filename? -- 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 = Field "direct" $ \f -> f == "1" 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 where
getfiles c [] = return (reverse c) getfiles c [] = return (reverse c)
getfiles c ((WorkTreeItem p):ps) = do getfiles c ((WorkTreeItem p):ps) = do
(fs, cleanup) <- inRepo $ LsFiles.inRepo [p] (fs, cleanup) <- inRepo $ LsFiles.inRepo [toRawFilePath p]
case fs of case fs of
[f] -> do [f] -> do
void $ liftIO $ cleanup void $ liftIO $ cleanup
@ -62,7 +62,7 @@ withFilesNotInGit :: Bool -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> C
withFilesNotInGit skipdotfiles a l withFilesNotInGit skipdotfiles a l
| skipdotfiles = do | skipdotfiles = do
{- dotfiles are not acted on unless explicitly listed -} {- dotfiles are not acted on unless explicitly listed -}
files <- filter (not . dotfile) <$> files <- filter (not . dotfile . fromRawFilePath) <$>
seekunless (null ps && not (null l)) ps seekunless (null ps && not (null l)) ps
dotfiles <- seekunless (null dotps) dotps dotfiles <- seekunless (null dotps) dotps
go (files++dotfiles) go (files++dotfiles)
@ -74,11 +74,11 @@ withFilesNotInGit skipdotfiles a l
force <- Annex.getState Annex.force force <- Annex.getState Annex.force
g <- gitRepo g <- gitRepo
liftIO $ Git.Command.leaveZombie 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 $ 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 withPathContents a params = do
matcher <- Limit.getMatcher matcher <- Limit.getMatcher
forM_ params $ \p -> do forM_ params $ \p -> do
@ -130,7 +130,7 @@ withUnmodifiedUnlockedPointers a l = seekActions $
isUnmodifiedUnlocked :: RawFilePath -> Annex Bool isUnmodifiedUnlocked :: RawFilePath -> Annex Bool
isUnmodifiedUnlocked f = catKeyFile f >>= \case isUnmodifiedUnlocked f = catKeyFile f >>= \case
Nothing -> return False 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. -} {- Finds files that may be modified. -}
withFilesMaybeModified :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek withFilesMaybeModified :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek
@ -169,7 +169,7 @@ withKeyOptions ko auto keyaction = withKeyOptions' ko auto mkkeyaction
return $ \v@(k, ai) -> return $ \v@(k, ai) ->
let i = case ai of let i = case ai of
ActionItemBranchFilePath (BranchFilePath _ topf) _ -> ActionItemBranchFilePath (BranchFilePath _ topf) _ ->
MatchingKey k (AssociatedFile $ Just $ getTopFilePath topf) MatchingKey k (AssociatedFile $ Just $ toRawFilePath $ getTopFilePath topf)
_ -> MatchingKey k (AssociatedFile Nothing) _ -> MatchingKey k (AssociatedFile Nothing)
in whenM (matcher i) $ in whenM (matcher i) $
keyaction v keyaction v
@ -230,7 +230,9 @@ prepFiltered a fs = do
matcher <- Limit.getMatcher matcher <- Limit.getMatcher
map (process matcher) <$> fs map (process matcher) <$> fs
where 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 :: Annex [CommandSeek] -> Annex ()
seekActions gen = sequence_ =<< gen seekActions gen = sequence_ =<< gen
@ -238,12 +240,12 @@ seekActions gen = sequence_ =<< gen
seekHelper :: ([RawFilePath] -> Git.Repo -> IO ([RawFilePath], IO Bool)) -> [WorkTreeItem] -> Annex [RawFilePath] seekHelper :: ([RawFilePath] -> Git.Repo -> IO ([RawFilePath], IO Bool)) -> [WorkTreeItem] -> Annex [RawFilePath]
seekHelper a l = inRepo $ \g -> seekHelper a l = inRepo $ \g ->
concat . concat <$> forM (segmentXargsOrdered l') concat . concat <$> forM (segmentXargsOrdered l')
(runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g)) (runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g) . map toRawFilePath)
where where
l' = map (\(WorkTreeItem f) -> f) l l' = map (\(WorkTreeItem f) -> f) l
-- An item in the work tree, which may be a file or a directory. -- 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 -- 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 -- 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 unlessM (exists p <||> hidden currbranch p) $ do
toplevelWarning False (p ++ " not found") toplevelWarning False (p ++ " not found")
Annex.incError Annex.incError
return (map WorkTreeItem ps) return (map (WorkTreeItem) ps)
where where
exists p = isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p) exists p = isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)
hidden currbranch p hidden currbranch p
| allowhidden = do | allowhidden = do
f <- liftIO $ relPathCwdToFile p f <- liftIO $ relPathCwdToFile p
isJust <$> catObjectMetaDataHidden f currbranch isJust <$> catObjectMetaDataHidden (toRawFilePath f) currbranch
| otherwise = return False | otherwise = return False
notSymlink :: RawFilePath -> IO Bool 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 Data.Default
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.ByteString.Char8 as S8
import Command import Command
import Annex.Content import Annex.Content
@ -57,29 +58,29 @@ seek o = case batchOption o of
(commandAction . startKeys o) (commandAction . startKeys o)
(withFilesInGit (commandAction . go)) (withFilesInGit (commandAction . go))
=<< workTreeItems (findThese o) =<< workTreeItems (findThese o)
Batch fmt -> batchFilesMatching fmt go Batch fmt -> batchFilesMatching fmt (go . toRawFilePath)
where where
go = whenAnnexed $ start o go = whenAnnexed $ start o
-- only files inAnnex are shown, unless the user has requested -- only files inAnnex are shown, unless the user has requested
-- others via a limit -- others via a limit
start :: FindOptions -> FilePath -> Key -> CommandStart start :: FindOptions -> RawFilePath -> Key -> CommandStart
start o file key = start o file key =
stopUnless (limited <||> inAnnex key) $ stopUnless (limited <||> inAnnex key) $
startingCustomOutput key $ do startingCustomOutput key $ do
showFormatted (formatOption o) file $ ("file", file) : keyVars key showFormatted (formatOption o) file $ ("file", fromRawFilePath file) : keyVars key
next $ return True next $ return True
startKeys :: FindOptions -> (Key, ActionItem) -> CommandStart startKeys :: FindOptions -> (Key, ActionItem) -> CommandStart
startKeys o (key, ActionItemBranchFilePath (BranchFilePath _ topf) _) = startKeys o (key, ActionItemBranchFilePath (BranchFilePath _ topf) _) =
start o (getTopFilePath topf) key start o (toRawFilePath (getTopFilePath topf)) key
startKeys _ _ = stop startKeys _ _ = stop
showFormatted :: Maybe Utility.Format.Format -> String -> [(String, String)] -> Annex () showFormatted :: Maybe Utility.Format.Format -> RawFilePath -> [(String, String)] -> Annex ()
showFormatted format unformatted vars = showFormatted format unformatted vars =
unlessM (showFullJSON $ JSONChunk vars) $ unlessM (showFullJSON $ JSONChunk vars) $
case format of case format of
Nothing -> liftIO $ putStrLn unformatted Nothing -> liftIO $ S8.putStrLn unformatted
Just formatter -> liftIO $ putStr $ Just formatter -> liftIO $ putStr $
Utility.Format.format formatter $ Utility.Format.format formatter $
M.fromList vars M.fromList vars

4
Command/Unannex.hs
View file

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

4
Command/Uninit.hs
View file

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

2
Database/ContentIdentifier.hs
View file

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

13
Database/Keys.hs
View file

@ -235,7 +235,7 @@ reconcileStaged qh = do
where where
go cur indexcache = do go cur indexcache = do
(l, cleanup) <- inRepo $ pipeNullSplit diff (l, cleanup) <- inRepo $ pipeNullSplit diff
changed <- procdiff l False changed <- procdiff (map decodeBL' l) False
void $ liftIO cleanup void $ liftIO cleanup
-- Flush database changes immediately -- Flush database changes immediately
-- so other processes can see them. -- so other processes can see them.
@ -262,7 +262,8 @@ reconcileStaged qh = do
-- perfect. A file could start with this and not be a -- perfect. A file could start with this and not be a
-- pointer file. And a pointer file that is replaced with -- pointer file. And a pointer file that is replaced with
-- a non-pointer file will match this. -- 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 -- Don't include files that were deleted, because this only
-- wants to update information for files that are present -- wants to update information for files that are present
-- in the index. -- in the index.
@ -277,7 +278,7 @@ reconcileStaged qh = do
procdiff (info:file:rest) changed = case words info of procdiff (info:file:rest) changed = case words info of
((':':_srcmode):dstmode:_srcsha:dstsha:_change:[]) ((':':_srcmode):dstmode:_srcsha:dstsha:_change:[])
-- Only want files, not symlinks -- Only want files, not symlinks
| dstmode /= fmtTreeItemType TreeSymlink -> do | dstmode /= decodeBS' (fmtTreeItemType TreeSymlink) -> do
maybe noop (reconcile (asTopFilePath file)) maybe noop (reconcile (asTopFilePath file))
=<< catKey (Ref dstsha) =<< catKey (Ref dstsha)
procdiff rest True procdiff rest True
@ -293,11 +294,11 @@ reconcileStaged qh = do
caches <- liftIO $ SQL.getInodeCaches ikey (SQL.ReadHandle qh) caches <- liftIO $ SQL.getInodeCaches ikey (SQL.ReadHandle qh)
keyloc <- calcRepo (gitAnnexLocation key) keyloc <- calcRepo (gitAnnexLocation key)
keypopulated <- sameInodeCache keyloc caches keypopulated <- sameInodeCache keyloc caches
p <- fromRepo $ fromTopFilePath file p <- fromRepo $ toRawFilePath . fromTopFilePath file
filepopulated <- sameInodeCache p caches filepopulated <- sameInodeCache (fromRawFilePath p) caches
case (keypopulated, filepopulated) of case (keypopulated, filepopulated) of
(True, False) -> (True, False) ->
populatePointerFile (Restage True) key keyloc p >>= \case populatePointerFile (Restage True) key (toRawFilePath keyloc) p >>= \case
Nothing -> return () Nothing -> return ()
Just ic -> liftIO $ Just ic -> liftIO $
SQL.addInodeCaches ikey [ic] (SQL.WriteHandle qh) 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) return (filter (not . L.null) $ L.split 0 s, cleanup)
{- Reads lazily, but converts each part to a strict ByteString for {- 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' :: [CommandParam] -> Repo -> IO ([S.ByteString], IO Bool)
pipeNullSplit' params repo = do pipeNullSplit' params repo = do
(s, cleanup) <- pipeNullSplit params repo (s, cleanup) <- pipeNullSplit params repo
@ -116,6 +119,9 @@ pipeNullSplitStrict params repo = do
pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [L.ByteString] pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [L.ByteString]
pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo 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. -} {- Doesn't run the cleanup action. A zombie results. -}
leaveZombie :: (a, IO Bool) -> a leaveZombie :: (a, IO Bool) -> a
leaveZombie = fst leaveZombie = fst

7
Git/FilePath.hs
View file

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

4
Git/Filename.hs
View file

@ -36,5 +36,5 @@ encode :: RawFilePath -> S.ByteString
encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\"" encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\""
{- For quickcheck. -} {- For quickcheck. -}
prop_encode_decode_roundtrip :: RawFilePath -> Bool prop_encode_decode_roundtrip :: FilePath -> Bool
prop_encode_decode_roundtrip s = s == decode (encode s) 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 - Prefixing the file with ./ makes this work even if in a subdirectory
- of a repo. - of a repo.
-} -}
fileRef :: FilePath -> Ref fileRef :: RawFilePath -> Ref
fileRef f = Ref $ ":./" ++ f fileRef f = Ref $ ":./" ++ fromRawFilePath f
{- Converts a Ref to refer to the content of the Ref on a given date. -} {- Converts a Ref to refer to the content of the Ref on a given date. -}
dateRef :: Ref -> RefDate -> Ref 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 {- A Ref that can be used to refer to a file in the repository as it
- appears in a given Ref. -} - 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) fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr)
{- Checks if a ref exists. -} {- Checks if a ref exists. -}

5
Key.hs
View file

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

2
Limit/Wanted.hs
View file

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

137
Logs.hs
View file

@ -5,11 +5,15 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
module Logs where module Logs where
import Annex.Common import Annex.Common
import Annex.DirHashes import Annex.DirHashes
import qualified Data.ByteString as S
{- There are several varieties of log file formats. -} {- There are several varieties of log file formats. -}
data LogVariety data LogVariety
= OldUUIDBasedLog = OldUUIDBasedLog
@ -22,7 +26,7 @@ data LogVariety
{- Converts a path from the git-annex branch into one of the varieties {- 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. -} - of logs used by git-annex, if it's a known path. -}
getLogVariety :: FilePath -> Maybe LogVariety getLogVariety :: RawFilePath -> Maybe LogVariety
getLogVariety f getLogVariety f
| f `elem` topLevelOldUUIDBasedLogs = Just OldUUIDBasedLog | f `elem` topLevelOldUUIDBasedLogs = Just OldUUIDBasedLog
| f `elem` topLevelNewUUIDBasedLogs = Just NewUUIDBasedLog | f `elem` topLevelNewUUIDBasedLogs = Just NewUUIDBasedLog
@ -34,7 +38,7 @@ getLogVariety f
| otherwise = PresenceLog <$> firstJust (presenceLogs f) | otherwise = PresenceLog <$> firstJust (presenceLogs f)
{- All the old-format uuid-based logs stored in the top of the git-annex branch. -} {- All the old-format uuid-based logs stored in the top of the git-annex branch. -}
topLevelOldUUIDBasedLogs :: [FilePath] topLevelOldUUIDBasedLogs :: [RawFilePath]
topLevelOldUUIDBasedLogs = topLevelOldUUIDBasedLogs =
[ uuidLog [ uuidLog
, remoteLog , remoteLog
@ -49,161 +53,172 @@ topLevelOldUUIDBasedLogs =
] ]
{- All the new-format uuid-based logs stored in the top of the git-annex branch. -} {- All the new-format uuid-based logs stored in the top of the git-annex branch. -}
topLevelNewUUIDBasedLogs :: [FilePath] topLevelNewUUIDBasedLogs :: [RawFilePath]
topLevelNewUUIDBasedLogs = topLevelNewUUIDBasedLogs =
[ exportLog [ exportLog
] ]
{- All the ways to get a key from a presence log file -} {- All the ways to get a key from a presence log file -}
presenceLogs :: FilePath -> [Maybe Key] presenceLogs :: RawFilePath -> [Maybe Key]
presenceLogs f = presenceLogs f =
[ urlLogFileKey f [ urlLogFileKey f
, locationLogFileKey f , locationLogFileKey f
] ]
{- Top-level logs that are neither UUID based nor presence logs. -} {- Top-level logs that are neither UUID based nor presence logs. -}
otherLogs :: [FilePath] otherLogs :: [RawFilePath]
otherLogs = otherLogs =
[ numcopiesLog [ numcopiesLog
, groupPreferredContentLog , groupPreferredContentLog
] ]
uuidLog :: FilePath uuidLog :: RawFilePath
uuidLog = "uuid.log" uuidLog = "uuid.log"
numcopiesLog :: FilePath numcopiesLog :: RawFilePath
numcopiesLog = "numcopies.log" numcopiesLog = "numcopies.log"
configLog :: FilePath configLog :: RawFilePath
configLog = "config.log" configLog = "config.log"
remoteLog :: FilePath remoteLog :: RawFilePath
remoteLog = "remote.log" remoteLog = "remote.log"
trustLog :: FilePath trustLog :: RawFilePath
trustLog = "trust.log" trustLog = "trust.log"
groupLog :: FilePath groupLog :: RawFilePath
groupLog = "group.log" groupLog = "group.log"
preferredContentLog :: FilePath preferredContentLog :: RawFilePath
preferredContentLog = "preferred-content.log" preferredContentLog = "preferred-content.log"
requiredContentLog :: FilePath requiredContentLog :: RawFilePath
requiredContentLog = "required-content.log" requiredContentLog = "required-content.log"
groupPreferredContentLog :: FilePath groupPreferredContentLog :: RawFilePath
groupPreferredContentLog = "group-preferred-content.log" groupPreferredContentLog = "group-preferred-content.log"
scheduleLog :: FilePath scheduleLog :: RawFilePath
scheduleLog = "schedule.log" scheduleLog = "schedule.log"
activityLog :: FilePath activityLog :: RawFilePath
activityLog = "activity.log" activityLog = "activity.log"
differenceLog :: FilePath differenceLog :: RawFilePath
differenceLog = "difference.log" differenceLog = "difference.log"
multicastLog :: FilePath multicastLog :: RawFilePath
multicastLog = "multicast.log" multicastLog = "multicast.log"
exportLog :: FilePath exportLog :: RawFilePath
exportLog = "export.log" exportLog = "export.log"
{- The pathname of the location log file for a given key. -} {- The pathname of the location log file for a given key. -}
locationLogFile :: GitConfig -> Key -> String locationLogFile :: GitConfig -> Key -> RawFilePath
locationLogFile config key = branchHashDir config key </> keyFile key ++ ".log" locationLogFile config key = toRawFilePath $
branchHashDir config key </> keyFile key ++ ".log"
{- The filename of the url log for a given key. -} {- The filename of the url log for a given key. -}
urlLogFile :: GitConfig -> Key -> FilePath urlLogFile :: GitConfig -> Key -> RawFilePath
urlLogFile config key = branchHashDir config key </> keyFile key ++ urlLogExt urlLogFile config key = toRawFilePath $
branchHashDir config key </> keyFile key ++ decodeBS' urlLogExt
{- Old versions stored the urls elsewhere. -} {- Old versions stored the urls elsewhere. -}
oldurlLogs :: GitConfig -> Key -> [FilePath] oldurlLogs :: GitConfig -> Key -> [RawFilePath]
oldurlLogs config key = oldurlLogs config key = map toRawFilePath
[ "remote/web" </> hdir </> serializeKey key ++ ".log" [ "remote/web" </> hdir </> serializeKey key ++ ".log"
, "remote/web" </> hdir </> keyFile key ++ ".log" , "remote/web" </> hdir </> keyFile key ++ ".log"
] ]
where where
hdir = branchHashDir config key hdir = branchHashDir config key
urlLogExt :: String urlLogExt :: S.ByteString
urlLogExt = ".log.web" urlLogExt = ".log.web"
{- Does not work on oldurllogs. -} {- Does not work on oldurllogs. -}
isUrlLog :: FilePath -> Bool isUrlLog :: RawFilePath -> Bool
isUrlLog file = urlLogExt `isSuffixOf` file isUrlLog file = urlLogExt `S.isSuffixOf` file
{- The filename of the remote state log for a given key. -} {- The filename of the remote state log for a given key. -}
remoteStateLogFile :: GitConfig -> Key -> FilePath remoteStateLogFile :: GitConfig -> Key -> RawFilePath
remoteStateLogFile config key = branchHashDir config key remoteStateLogFile config key =
</> keyFile key ++ remoteStateLogExt toRawFilePath (branchHashDir config key </> keyFile key)
<> remoteStateLogExt
remoteStateLogExt :: String remoteStateLogExt :: S.ByteString
remoteStateLogExt = ".log.rmt" remoteStateLogExt = ".log.rmt"
isRemoteStateLog :: FilePath -> Bool isRemoteStateLog :: RawFilePath -> Bool
isRemoteStateLog path = remoteStateLogExt `isSuffixOf` path isRemoteStateLog path = remoteStateLogExt `S.isSuffixOf` path
{- The filename of the chunk log for a given key. -} {- The filename of the chunk log for a given key. -}
chunkLogFile :: GitConfig -> Key -> FilePath chunkLogFile :: GitConfig -> Key -> RawFilePath
chunkLogFile config key = branchHashDir config key </> keyFile key ++ chunkLogExt chunkLogFile config key =
toRawFilePath (branchHashDir config key </> keyFile key)
<> chunkLogExt
chunkLogExt :: String chunkLogExt :: S.ByteString
chunkLogExt = ".log.cnk" chunkLogExt = ".log.cnk"
isChunkLog :: FilePath -> Bool isChunkLog :: RawFilePath -> Bool
isChunkLog path = chunkLogExt `isSuffixOf` path isChunkLog path = chunkLogExt `S.isSuffixOf` path
{- The filename of the metadata log for a given key. -} {- The filename of the metadata log for a given key. -}
metaDataLogFile :: GitConfig -> Key -> FilePath metaDataLogFile :: GitConfig -> Key -> RawFilePath
metaDataLogFile config key = branchHashDir config key </> keyFile key ++ metaDataLogExt metaDataLogFile config key =
toRawFilePath (branchHashDir config key </> keyFile key)
<> metaDataLogExt
metaDataLogExt :: String metaDataLogExt :: S.ByteString
metaDataLogExt = ".log.met" metaDataLogExt = ".log.met"
isMetaDataLog :: FilePath -> Bool isMetaDataLog :: RawFilePath -> Bool
isMetaDataLog path = metaDataLogExt `isSuffixOf` path isMetaDataLog path = metaDataLogExt `S.isSuffixOf` path
{- The filename of the remote metadata log for a given key. -} {- The filename of the remote metadata log for a given key. -}
remoteMetaDataLogFile :: GitConfig -> Key -> FilePath remoteMetaDataLogFile :: GitConfig -> Key -> RawFilePath
remoteMetaDataLogFile config key = branchHashDir config key </> keyFile key ++ remoteMetaDataLogExt remoteMetaDataLogFile config key =
toRawFilePath (branchHashDir config key </> keyFile key)
<> remoteMetaDataLogExt
remoteMetaDataLogExt :: String remoteMetaDataLogExt :: S.ByteString
remoteMetaDataLogExt = ".log.rmet" remoteMetaDataLogExt = ".log.rmet"
isRemoteMetaDataLog :: FilePath -> Bool isRemoteMetaDataLog :: RawFilePath -> Bool
isRemoteMetaDataLog path = remoteMetaDataLogExt `isSuffixOf` path isRemoteMetaDataLog path = remoteMetaDataLogExt `S.isSuffixOf` path
{- The filename of the remote content identifier log for a given key. -} {- The filename of the remote content identifier log for a given key. -}
remoteContentIdentifierLogFile :: GitConfig -> Key -> FilePath remoteContentIdentifierLogFile :: GitConfig -> Key -> RawFilePath
remoteContentIdentifierLogFile config key = branchHashDir config key </> keyFile key ++ remoteContentIdentifierExt remoteContentIdentifierLogFile config key =
toRawFilePath (branchHashDir config key </> keyFile key)
<> remoteContentIdentifierExt
remoteContentIdentifierExt :: String remoteContentIdentifierExt :: S.ByteString
remoteContentIdentifierExt = ".log.cid" remoteContentIdentifierExt = ".log.cid"
isRemoteContentIdentifierLog :: FilePath -> Bool isRemoteContentIdentifierLog :: RawFilePath -> Bool
isRemoteContentIdentifierLog path = remoteContentIdentifierExt `isSuffixOf` path isRemoteContentIdentifierLog path = remoteContentIdentifierExt `S.isSuffixOf` path
{- From an extension and a log filename, get the key that it's a log for. -} {- 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 extLogFileKey expectedext path
| ext == expectedext = fileKey base | encodeBS' ext == expectedext = fileKey base
| otherwise = Nothing | otherwise = Nothing
where where
file = takeFileName path file = takeFileName (fromRawFilePath path)
(base, ext) = splitAt (length file - extlen) file (base, ext) = splitAt (length file - extlen) file
extlen = length expectedext extlen = S.length expectedext
{- Converts a url log file into a key. {- Converts a url log file into a key.
- (Does not work on oldurlLogs.) -} - (Does not work on oldurlLogs.) -}
urlLogFileKey :: FilePath -> Maybe Key urlLogFileKey :: RawFilePath -> Maybe Key
urlLogFileKey = extLogFileKey urlLogExt urlLogFileKey = extLogFileKey urlLogExt
{- Converts a pathname into a key if it's a location log. -} {- Converts a pathname into a key if it's a location log. -}
locationLogFileKey :: FilePath -> Maybe Key locationLogFileKey :: RawFilePath -> Maybe Key
locationLogFileKey path locationLogFileKey path
-- Want only xx/yy/foo.log, not .log files in other places. -- 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 | 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.Lazy as A
import qualified Data.Attoparsec.ByteString.Char8 as A8 import qualified Data.Attoparsec.ByteString.Char8 as A8
import Data.ByteString.Builder import Data.ByteString.Builder
import Data.Either
import Data.Char
-- This constuctor is not itself exported to other modules, to enforce -- This constuctor is not itself exported to other modules, to enforce
-- consistent use of exportedTreeishes. -- consistent use of exportedTreeishes.
@ -176,8 +178,9 @@ logExportExcluded u a = do
getExportExcluded :: UUID -> Annex [Git.Tree.TreeItem] getExportExcluded :: UUID -> Annex [Git.Tree.TreeItem]
getExportExcluded u = do getExportExcluded u = do
logf <- fromRepo $ gitAnnexExportExcludeLog u logf <- fromRepo $ gitAnnexExportExcludeLog u
liftIO $ catchDefaultIO [] $ liftIO $ catchDefaultIO [] $ parser <$> L.readFile logf
(map parser . lines)
<$> readFile logf
where 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 -> Annex [UUID]
loggedLocationsRef ref = map (toUUID . fromLogInfo) . getLog <$> catObject ref 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 getLoggedLocations getter key = do
config <- Annex.getGitConfig config <- Annex.getGitConfig
map (toUUID . fromLogInfo) <$> getter (locationLogFile config key) 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 :: Key -> Annex MetaData
getCurrentMetaData = getCurrentMetaData' metaDataLogFile getCurrentMetaData = getCurrentMetaData' metaDataLogFile
getCurrentMetaData' :: (GitConfig -> Key -> FilePath) -> Key -> Annex MetaData getCurrentMetaData' :: (GitConfig -> Key -> RawFilePath) -> Key -> Annex MetaData
getCurrentMetaData' getlogfile k = do getCurrentMetaData' getlogfile k = do
config <- Annex.getGitConfig config <- Annex.getGitConfig
ls <- S.toAscList <$> readLog (getlogfile config k) ls <- S.toAscList <$> readLog (getlogfile config k)
@ -95,7 +95,7 @@ getCurrentRemoteMetaData (RemoteStateHandle u) k = extractRemoteMetaData u <$>
addMetaData :: Key -> MetaData -> Annex () addMetaData :: Key -> MetaData -> Annex ()
addMetaData = addMetaData' metaDataLogFile addMetaData = addMetaData' metaDataLogFile
addMetaData' :: (GitConfig -> Key -> FilePath) -> Key -> MetaData -> Annex () addMetaData' :: (GitConfig -> Key -> RawFilePath) -> Key -> MetaData -> Annex ()
addMetaData' getlogfile k metadata = addMetaData' getlogfile k metadata =
addMetaDataClocked' getlogfile k metadata =<< liftIO currentVectorClock addMetaDataClocked' getlogfile k metadata =<< liftIO currentVectorClock
@ -106,7 +106,7 @@ addMetaData' getlogfile k metadata =
addMetaDataClocked :: Key -> MetaData -> VectorClock -> Annex () addMetaDataClocked :: Key -> MetaData -> VectorClock -> Annex ()
addMetaDataClocked = addMetaDataClocked' metaDataLogFile 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 addMetaDataClocked' getlogfile k d@(MetaData m) c
| d == emptyMetaData = noop | d == emptyMetaData = noop
| otherwise = do | otherwise = do
@ -151,5 +151,5 @@ copyMetaData oldkey newkey
const $ buildLog l const $ buildLog l
return True return True
readLog :: FilePath -> Annex (Log MetaData) readLog :: RawFilePath -> Annex (Log MetaData)
readLog = parseLog <$$> Annex.Branch.get readLog = parseLog <$$> Annex.Branch.get

2
Logs/PreferredContent/Raw.hs
View file

@ -28,7 +28,7 @@ preferredContentSet = setLog preferredContentLog
requiredContentSet :: UUID -> PreferredContentExpression -> Annex () requiredContentSet :: UUID -> PreferredContentExpression -> Annex ()
requiredContentSet = setLog requiredContentLog requiredContentSet = setLog requiredContentLog
setLog :: FilePath -> UUID -> PreferredContentExpression -> Annex () setLog :: RawFilePath -> UUID -> PreferredContentExpression -> Annex ()
setLog logfile uuid@(UUID _) val = do setLog logfile uuid@(UUID _) val = do
c <- liftIO currentVectorClock c <- liftIO currentVectorClock
Annex.Branch.change logfile $ 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 {- Adds a LogLine to the log, removing any LogLines that are obsoleted by
- adding it. -} - adding it. -}
addLog :: FilePath -> LogLine -> Annex () addLog :: RawFilePath -> LogLine -> Annex ()
addLog file line = Annex.Branch.change file $ \b -> addLog file line = Annex.Branch.change file $ \b ->
buildLog $ compactLog (line : parseLog 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 - older timestamp, that LogLine is preserved, rather than updating the log
- with a newer timestamp. - with a newer timestamp.
-} -}
maybeAddLog :: FilePath -> LogLine -> Annex () maybeAddLog :: RawFilePath -> LogLine -> Annex ()
maybeAddLog file line = Annex.Branch.maybeChange file $ \s -> do maybeAddLog file line = Annex.Branch.maybeChange file $ \s -> do
m <- insertNewStatus line $ logMap $ parseLog s m <- insertNewStatus line $ logMap $ parseLog s
return $ buildLog $ mapLog m return $ buildLog $ mapLog m
{- Reads a log file. {- Reads a log file.
- Note that the LogLines returned may be in any order. -} - Note that the LogLines returned may be in any order. -}
readLog :: FilePath -> Annex [LogLine] readLog :: RawFilePath -> Annex [LogLine]
readLog = parseLog <$$> Annex.Branch.get readLog = parseLog <$$> Annex.Branch.get
{- Generates a new LogLine with the current time. -} {- Generates a new LogLine with the current time. -}
@ -55,10 +55,10 @@ logNow s i = do
return $ LogLine c s i return $ LogLine c s i
{- Reads a log and returns only the info that is still in effect. -} {- 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 currentLogInfo file = map info <$> currentLog file
currentLog :: FilePath -> Annex [LogLine] currentLog :: RawFilePath -> Annex [LogLine]
currentLog file = filterPresent <$> readLog file currentLog file = filterPresent <$> readLog file
{- Reads a historical version of a log and returns the info that was in {- 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. - 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 historicalLogInfo refdate file = map info . filterPresent . parseLog
<$> Annex.Branch.getHistorical refdate file <$> Annex.Branch.getHistorical refdate file

6
Logs/SingleValue.hs
View file

@ -25,13 +25,13 @@ import Annex.VectorClock
import qualified Data.Set as S 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 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 getLog = newestValue <$$> readLog
setLog :: (SingleValueSerializable v) => FilePath -> v -> Annex () setLog :: (SingleValueSerializable v) => RawFilePath -> v -> Annex ()
setLog f v = do setLog f v = do
c <- liftIO currentVectorClock c <- liftIO currentVectorClock
let ent = LogEntry c v let ent = LogEntry c v

6
Logs/Transfer.hs
View file

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

6
Logs/Transitions.hs
View file

@ -12,6 +12,8 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
module Logs.Transitions where module Logs.Transitions where
import Annex.Common 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.Lazy as A
import qualified Data.Attoparsec.ByteString.Char8 as A8 import qualified Data.Attoparsec.ByteString.Char8 as A8
transitionsLog :: FilePath transitionsLog :: RawFilePath
transitionsLog = "transitions.log" transitionsLog = "transitions.log"
data Transition 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 {- Typically ran with Annex.Branch.change, but we can't import Annex.Branch
- here since it depends on this module. -} - 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 $ recordTransitions changer t = changer transitionsLog $
buildTransitions . S.union t . parseTransitionsStrictly "local" buildTransitions . S.union t . parseTransitionsStrictly "local"

2
Logs/Web.hs
View file

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

32
Messages.hs
View file

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

10
Messages/Internal.hs
View file

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

5
Messages/JSON.hs
View file

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

1
Messages/Progress.hs
View file

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

7
P2P/Protocol.hs
View file

@ -22,6 +22,7 @@ import Utility.AuthToken
import Utility.Applicative import Utility.Applicative
import Utility.PartialPrelude import Utility.PartialPrelude
import Utility.Metered import Utility.Metered
import Utility.FileSystemEncoding
import Git.FilePath import Git.FilePath
import Annex.ChangedRefs (ChangedRefs) import Annex.ChangedRefs (ChangedRefs)
@ -166,17 +167,17 @@ instance Proto.Serializable Service where
instance Proto.Serializable AssociatedFile where instance Proto.Serializable AssociatedFile where
serialize (AssociatedFile Nothing) = "" serialize (AssociatedFile Nothing) = ""
serialize (AssociatedFile (Just af)) = serialize (AssociatedFile (Just af)) =
toInternalGitPath $ concatMap esc af decodeBS' $ toInternalGitPath $ encodeBS' $ concatMap esc $ fromRawFilePath af
where where
esc '%' = "%%" esc '%' = "%%"
esc c esc c
| isSpace c = "%" | isSpace c = "%"
| otherwise = [c] | otherwise = [c]
deserialize s = case fromInternalGitPath $ deesc [] s of deserialize s = case fromRawFilePath $ fromInternalGitPath $ toRawFilePath $ deesc [] s of
[] -> Just (AssociatedFile Nothing) [] -> Just (AssociatedFile Nothing)
f f
| isRelative f -> Just (AssociatedFile (Just f)) | isRelative f -> Just $ AssociatedFile $ Just $ toRawFilePath f
| otherwise -> Nothing | otherwise -> Nothing
where where
deesc b [] = reverse b 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 dest = exportPath d newloc
exportPath :: FilePath -> ExportLocation -> FilePath 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 {- Removes the ExportLocation's parent directory and its parents, so long as
- they're empty, up to but not including the topdir. -} - they're empty, up to but not including the topdir. -}
removeExportLocation :: FilePath -> ExportLocation -> IO () removeExportLocation :: FilePath -> ExportLocation -> IO ()
removeExportLocation topdir loc = removeExportLocation topdir loc =
go (Just $ takeDirectory $ fromExportLocation loc) (Right ()) go (Just $ takeDirectory $ fromRawFilePath $ fromExportLocation loc) (Right ())
where where
go _ (Left _e) = return () go _ (Left _e) = return ()
go Nothing _ = return () go Nothing _ = return ()
go (Just loc') _ = go (upFrom loc') 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 :: FilePath -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize)))
listImportableContentsM dir = catchMaybeIO $ liftIO $ do listImportableContentsM dir = catchMaybeIO $ liftIO $ do
@ -319,7 +319,7 @@ listImportableContentsM dir = catchMaybeIO $ liftIO $ do
mkContentIdentifier f st >>= \case mkContentIdentifier f st >>= \case
Nothing -> return Nothing Nothing -> return Nothing
Just cid -> do Just cid -> do
relf <- relPathDirToFile dir f relf <- toRawFilePath <$> relPathDirToFile dir f
sz <- getFileSize' f st sz <- getFileSize' f st
return $ Just (mkImportLocation relf, (cid, sz)) 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 u <- getUUID
let AssociatedFile afile = file let AssociatedFile afile = file
let fields = (Fields.remoteUUID, fromUUID u) 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 Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin
repo "transferinfo" repo "transferinfo"
[Param $ serializeKey key] fields [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 -- Send direct field for unlocked content, for backwards
-- compatability. -- compatability.
: (Fields.direct, if unlocked then "1" else "") : (Fields.direct, if unlocked then "1" else "")
: maybe [] (\f -> [(Fields.associatedFile, f)]) afile : maybe [] (\f -> [(Fields.associatedFile, fromRawFilePath f)]) afile
repo <- getRepo r repo <- getRepo r
Just (shellcmd, shellparams) <- git_annex_shell ConsumeStdin repo Just (shellcmd, shellparams) <- git_annex_shell ConsumeStdin repo
(if direction == Download then "sendkey" else "recvkey") (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 Git.Config
import qualified Remote.Git import qualified Remote.Git
{-
import qualified Remote.GCrypt import qualified Remote.GCrypt
import qualified Remote.P2P import qualified Remote.P2P
#ifdef WITH_S3 #ifdef WITH_S3
@ -44,10 +45,12 @@ import qualified Remote.Ddar
import qualified Remote.GitLFS import qualified Remote.GitLFS
import qualified Remote.Hook import qualified Remote.Hook
import qualified Remote.External import qualified Remote.External
-}
remoteTypes :: [RemoteType] remoteTypes :: [RemoteType]
remoteTypes = map adjustExportImportRemoteType remoteTypes = map adjustExportImportRemoteType
[ Remote.Git.remote [ Remote.Git.remote
{-
, Remote.GCrypt.remote , Remote.GCrypt.remote
, Remote.P2P.remote , Remote.P2P.remote
#ifdef WITH_S3 #ifdef WITH_S3
@ -68,6 +71,7 @@ remoteTypes = map adjustExportImportRemoteType
, Remote.GitLFS.remote , Remote.GitLFS.remote
, Remote.Hook.remote , Remote.Hook.remote
, Remote.External.remote , Remote.External.remote
-}
] ]
{- Builds a list of all available Remotes. {- Builds a list of all available Remotes.
@ -129,7 +133,9 @@ updateRemote remote = do
gitSyncableRemote :: Remote -> Bool gitSyncableRemote :: Remote -> Bool
gitSyncableRemote r = remotetype r `elem` gitSyncableRemote r = remotetype r `elem`
[ Remote.Git.remote [ Remote.Git.remote
{-
, Remote.GCrypt.remote , Remote.GCrypt.remote
, Remote.P2P.remote , Remote.P2P.remote
, Remote.GitLFS.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 = storeExportM o src _k loc meterupdate =
storeGeneric o meterupdate basedest populatedest storeGeneric o meterupdate basedest populatedest
where where
basedest = fromExportLocation loc basedest = fromRawFilePath (fromExportLocation loc)
populatedest = liftIO . createLinkOrCopy src populatedest = liftIO . createLinkOrCopy src
retrieveExportM :: RsyncOpts -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool retrieveExportM :: RsyncOpts -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
retrieveExportM o _k loc dest p = rsyncRetrieve o [rsyncurl] dest (Just p) retrieveExportM o _k loc dest p = rsyncRetrieve o [rsyncurl] dest (Just p)
where where
rsyncurl = mkRsyncUrl o (fromExportLocation loc) rsyncurl = mkRsyncUrl o (fromRawFilePath (fromExportLocation loc))
checkPresentExportM :: RsyncOpts -> Key -> ExportLocation -> Annex Bool checkPresentExportM :: RsyncOpts -> Key -> ExportLocation -> Annex Bool
checkPresentExportM o _k loc = checkPresentGeneric o [rsyncurl] checkPresentExportM o _k loc = checkPresentGeneric o [rsyncurl]
where where
rsyncurl = mkRsyncUrl o (fromExportLocation loc) rsyncurl = mkRsyncUrl o (fromRawFilePath (fromExportLocation loc))
removeExportM :: RsyncOpts -> Key -> ExportLocation -> Annex Bool removeExportM :: RsyncOpts -> Key -> ExportLocation -> Annex Bool
removeExportM o _k loc = removeExportM o _k loc =
removeGeneric o (includes (fromExportLocation loc)) removeGeneric o $ includes $ fromRawFilePath $ fromExportLocation loc
where where
includes f = f : case upFrom f of includes f = f : case upFrom f of
Nothing -> [] Nothing -> []
@ -292,7 +292,7 @@ removeExportM o _k loc =
removeExportDirectoryM :: RsyncOpts -> ExportDirectory -> Annex Bool removeExportDirectoryM :: RsyncOpts -> ExportDirectory -> Annex Bool
removeExportDirectoryM o ed = removeGeneric o (allbelow d : includes d) removeExportDirectoryM o ed = removeGeneric o (allbelow d : includes d)
where where
d = fromExportDirectory ed d = fromRawFilePath $ fromExportDirectory ed
allbelow f = f </> "***" allbelow f = f </> "***"
includes f = f : case upFrom f of includes f = f : case upFrom f of
Nothing -> [] 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. -} - of git-annex. They are always run before the unitTests. -}
initTests :: TestTree initTests :: TestTree
initTests = testGroup "Init Tests" initTests = testGroup "Init Tests"
[]
{-
[ testCase "init" test_init [ testCase "init" test_init
, testCase "add" test_add , testCase "add" test_add
] ]
-}
unitTests :: String -> TestTree unitTests :: String -> TestTree
unitTests note = testGroup ("Unit Tests " ++ note) unitTests note = testGroup ("Unit Tests " ++ note)
[]
{-
[ testCase "add dup" test_add_dup [ testCase "add dup" test_add_dup
, testCase "add extras" test_add_extras , testCase "add extras" test_add_extras
, testCase "export_import" test_export_import , 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 -- Make sure that import did not import the file to the top
-- of the repo. -- of the repo.
checkdoesnotexist annexedfile checkdoesnotexist annexedfile
-}

8
Test/Framework.hs
View file

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

18
Types/ActionItem.hs
View file

@ -12,15 +12,17 @@ module Types.ActionItem where
import Key import Key
import Types.Transfer import Types.Transfer
import Git.FilePath import Git.FilePath
import Utility.FileSystemEncoding
import Data.Maybe import Data.Maybe
import qualified Data.ByteString as S
data ActionItem data ActionItem
= ActionItemAssociatedFile AssociatedFile Key = ActionItemAssociatedFile AssociatedFile Key
| ActionItemKey Key | ActionItemKey Key
| ActionItemBranchFilePath BranchFilePath Key | ActionItemBranchFilePath BranchFilePath Key
| ActionItemFailedTransfer Transfer TransferInfo | ActionItemFailedTransfer Transfer TransferInfo
| ActionItemWorkTreeFile FilePath | ActionItemWorkTreeFile RawFilePath
| ActionItemOther (Maybe String) | ActionItemOther (Maybe String)
-- Use to avoid more than one thread concurrently processing the -- Use to avoid more than one thread concurrently processing the
-- same Key. -- same Key.
@ -39,10 +41,10 @@ instance MkActionItem (AssociatedFile, Key) where
instance MkActionItem (Key, AssociatedFile) where instance MkActionItem (Key, AssociatedFile) where
mkActionItem = uncurry $ flip ActionItemAssociatedFile mkActionItem = uncurry $ flip ActionItemAssociatedFile
instance MkActionItem (Key, FilePath) where instance MkActionItem (Key, RawFilePath) where
mkActionItem (key, file) = ActionItemAssociatedFile (AssociatedFile (Just file)) key mkActionItem (key, file) = ActionItemAssociatedFile (AssociatedFile (Just file)) key
instance MkActionItem (FilePath, Key) where instance MkActionItem (RawFilePath, Key) where
mkActionItem (file, key) = mkActionItem (key, file) mkActionItem (file, key) = mkActionItem (key, file)
instance MkActionItem Key where instance MkActionItem Key where
@ -54,16 +56,16 @@ instance MkActionItem (BranchFilePath, Key) where
instance MkActionItem (Transfer, TransferInfo) where instance MkActionItem (Transfer, TransferInfo) where
mkActionItem = uncurry ActionItemFailedTransfer mkActionItem = uncurry ActionItemFailedTransfer
actionItemDesc :: ActionItem -> String actionItemDesc :: ActionItem -> S.ByteString
actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f)) _) = f actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f)) _) = f
actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing) k) = actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing) k) =
serializeKey k serializeKey' k
actionItemDesc (ActionItemKey k) = serializeKey k actionItemDesc (ActionItemKey k) = serializeKey' k
actionItemDesc (ActionItemBranchFilePath bfp _) = descBranchFilePath bfp actionItemDesc (ActionItemBranchFilePath bfp _) = descBranchFilePath bfp
actionItemDesc (ActionItemFailedTransfer t i) = actionItemDesc $ actionItemDesc (ActionItemFailedTransfer t i) = actionItemDesc $
ActionItemAssociatedFile (associatedFile i) (transferKey t) ActionItemAssociatedFile (associatedFile i) (transferKey t)
actionItemDesc (ActionItemWorkTreeFile f) = f actionItemDesc (ActionItemWorkTreeFile f) = f
actionItemDesc (ActionItemOther s) = fromMaybe "" s actionItemDesc (ActionItemOther s) = encodeBS' (fromMaybe "" s)
actionItemDesc (OnlyActionOn _ ai) = actionItemDesc ai actionItemDesc (OnlyActionOn _ ai) = actionItemDesc ai
actionItemKey :: ActionItem -> Maybe Key actionItemKey :: ActionItem -> Maybe Key
@ -75,7 +77,7 @@ actionItemKey (ActionItemWorkTreeFile _) = Nothing
actionItemKey (ActionItemOther _) = Nothing actionItemKey (ActionItemOther _) = Nothing
actionItemKey (OnlyActionOn _ ai) = actionItemKey ai actionItemKey (OnlyActionOn _ ai) = actionItemKey ai
actionItemWorkTreeFile :: ActionItem -> Maybe FilePath actionItemWorkTreeFile :: ActionItem -> Maybe RawFilePath
actionItemWorkTreeFile (ActionItemAssociatedFile (AssociatedFile af) _) = af actionItemWorkTreeFile (ActionItemAssociatedFile (AssociatedFile af) _) = af
actionItemWorkTreeFile (ActionItemWorkTreeFile f) = Just f actionItemWorkTreeFile (ActionItemWorkTreeFile f) = Just f
actionItemWorkTreeFile (OnlyActionOn _ ai) = actionItemWorkTreeFile ai 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 Data.ByteString.Builder.Extra
import qualified Data.Attoparsec.ByteString as A import qualified Data.Attoparsec.ByteString as A
import qualified Data.Attoparsec.ByteString.Char8 as A8 import qualified Data.Attoparsec.ByteString.Char8 as A8
import Utility.FileSystemEncoding
import Data.List import Data.List
import System.Posix.Types import System.Posix.Types
import Foreign.C.Types import Foreign.C.Types
@ -200,7 +201,7 @@ splitKeyNameExtension' :: S.ByteString -> (S.ByteString, S.ByteString)
splitKeyNameExtension' keyname = S8.span (/= '.') keyname splitKeyNameExtension' keyname = S8.span (/= '.') keyname
{- A filename may be associated with a Key. -} {- A filename may be associated with a Key. -}
newtype AssociatedFile = AssociatedFile (Maybe FilePath) newtype AssociatedFile = AssociatedFile (Maybe RawFilePath)
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
{- There are several different varieties of keys. -} {- 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.PID
import Utility.QuickCheck import Utility.QuickCheck
import Utility.Url import Utility.Url
import Utility.FileSystemEncoding
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
import Control.Concurrent import Control.Concurrent
@ -71,8 +72,7 @@ instance Arbitrary TransferInfo where
<*> pure Nothing -- cannot generate a ThreadID <*> pure Nothing -- cannot generate a ThreadID
<*> pure Nothing -- remote not needed <*> pure Nothing -- remote not needed
<*> arbitrary <*> arbitrary
-- associated file cannot be empty (but can be Nothing) <*> arbitrary
<*> (AssociatedFile <$> arbitrary `suchThat` (/= Just ""))
<*> arbitrary <*> arbitrary
class Observable a where class Observable a where
@ -101,7 +101,7 @@ class Transferrable t where
descTransfrerrable :: t -> Maybe String descTransfrerrable :: t -> Maybe String
instance Transferrable AssociatedFile where instance Transferrable AssociatedFile where
descTransfrerrable (AssociatedFile af) = af descTransfrerrable (AssociatedFile af) = fromRawFilePath <$> af
instance Transferrable URLString where instance Transferrable URLString where
descTransfrerrable = Just descTransfrerrable = Just

4
Upgrade.hs
View file

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

10
Utility/Path.hs
View file

@ -43,6 +43,7 @@ import Utility.Monad
import Utility.UserInfo import Utility.UserInfo
import Utility.Directory import Utility.Directory
import Utility.Split import Utility.Split
import Utility.FileSystemEncoding
{- Simplifies a path, removing any "." component, collapsing "dir/..", {- Simplifies a path, removing any "." component, collapsing "dir/..",
- and removing the trailing path separator. - 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 - 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. - 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]
segmentPaths [_] new = [new] -- optimisation segmentPaths [_] new = [new] -- optimisation
segmentPaths (l:ls) new = found : segmentPaths ls rest segmentPaths (l:ls) new = found : segmentPaths ls rest
where where
(found, rest) = if length ls < 100 (found, rest) = if length ls < 100
then partition (l `dirContains`) new then partition inl new
else break (\p -> not (l `dirContains` p)) 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, {- 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 - 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. - 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 runSegmentPaths a paths = segmentPaths paths <$> a paths
{- Converts paths in the home directory to use ~/ -} {- Converts paths in the home directory to use ~/ -}

6
git-annex.cabal
View file

@ -407,16 +407,16 @@ Executable git-annex
if flag(S3) if flag(S3)
Build-Depends: aws (>= 0.20) Build-Depends: aws (>= 0.20)
CPP-Options: -DWITH_S3 CPP-Options: -DWITH_S3
Other-Modules: Remote.S3 Other-Modules-temp-disabled: Remote.S3
if flag(WebDAV) if flag(WebDAV)
Build-Depends: DAV (>= 1.0) Build-Depends: DAV (>= 1.0)
CPP-Options: -DWITH_WEBDAV CPP-Options: -DWITH_WEBDAV
Other-Modules: Other-Modules-temp-disabled:
Remote.WebDAV Remote.WebDAV
Remote.WebDAV.DavLocation Remote.WebDAV.DavLocation
if flag(S3) || flag(WebDAV) if flag(S3) || flag(WebDAV)
Other-Modules: Other-Modules-temp-disabled:
Remote.Helper.Http Remote.Helper.Http
if flag(Assistant) && ! os(solaris) && ! os(gnu) 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 Network.Socket (withSocketsDo)
import qualified CmdLine.GitAnnex import qualified CmdLine.GitAnnex
import qualified CmdLine.GitAnnexShell --import qualified CmdLine.GitAnnexShell
import qualified CmdLine.GitRemoteTorAnnex import qualified CmdLine.GitRemoteTorAnnex
import qualified Test import qualified Test
import qualified Benchmark import qualified Benchmark
@ -33,7 +33,7 @@ main = withSocketsDo $ do
run ps =<< getProgName run ps =<< getProgName
where where
run ps n = case takeFileName n of 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 "git-remote-tor-annex" -> CmdLine.GitRemoteTorAnnex.run ps
_ -> CmdLine.GitAnnex.run Test.optParser Test.runner Benchmark.mkGenerator ps _ -> CmdLine.GitAnnex.run Test.optParser Test.runner Benchmark.mkGenerator ps

6
stack.yaml
View file

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