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

use filepath-bytestring for annex object manipulations

Browse source 
git-annex find is now RawFilePath end to end, no string conversions.
So is git-annex get when it does not need to get anything.
So this is a major milestone on optimisation.

Benchmarks indicate around 30% speedup in both commands.

Probably many other performance improvements. All or nearly all places
where a file is statted use RawFilePath now.
This commit is contained in:
Joey Hess 2019-12-11 14:12:22 -04:00
parent bdec7fed9c
commit c19211774f
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
53 changed files with 324 additions and 234 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
Annex/AutoMerge.hs
View file

@ -334,10 +334,9 @@ inodeMap :: Annex ([RawFilePath], IO Bool) -> Annex InodeMap
inodeMap getfiles = do inodeMap getfiles = do
(fs, cleanup) <- getfiles (fs, cleanup) <- getfiles
fsis <- forM fs $ \f -> do fsis <- forM fs $ \f -> do
let f' = fromRawFilePath f mi <- withTSDelta (liftIO . genInodeCache f)
mi <- withTSDelta (liftIO . genInodeCache f')
return $ case mi of return $ case mi of
Nothing -> Nothing Nothing -> Nothing
Just i -> Just (inodeCacheToKey Strongly i, f') Just i -> Just (inodeCacheToKey Strongly i, fromRawFilePath f)
void $ liftIO cleanup void $ liftIO cleanup
return $ M.fromList $ catMaybes fsis return $ M.fromList $ catMaybes fsis

2
Annex/Branch.hs
View file

@ -482,7 +482,7 @@ stageJournal jl commitindex = withIndex $ withOtherTmp $ \tmpdir -> do
sha <- Git.HashObject.hashFile h path sha <- Git.HashObject.hashFile h path
hPutStrLn jlogh file hPutStrLn jlogh file
streamer $ Git.UpdateIndex.updateIndexLine streamer $ Git.UpdateIndex.updateIndexLine
sha TreeFile (asTopFilePath $ toRawFilePath $ fileJournal file) sha TreeFile (asTopFilePath $ fileJournal $ toRawFilePath file)
genstream dir h jh jlogh streamer genstream dir h jh jlogh streamer
-- Clean up the staged files, as listed in the temp log file. -- Clean up the staged files, as listed in the temp log file.
-- The temp file is used to avoid needing to buffer all the -- The temp file is used to avoid needing to buffer all the

66
Annex/Content.hs
View file

@ -89,17 +89,18 @@ import Annex.Content.LowLevel
import Annex.Content.PointerFile import Annex.Content.PointerFile
import Annex.Concurrent import Annex.Concurrent
import Types.WorkerPool import Types.WorkerPool
import qualified Utility.RawFilePath as R
{- Checks if a given key's content is currently present. -} {- Checks if a given key's content is currently present. -}
inAnnex :: Key -> Annex Bool inAnnex :: Key -> Annex Bool
inAnnex key = inAnnexCheck key $ liftIO . doesFileExist inAnnex key = inAnnexCheck key $ liftIO . R.doesPathExist
{- Runs an arbitrary check on a key's content. -} {- Runs an arbitrary check on a key's content. -}
inAnnexCheck :: Key -> (FilePath -> Annex Bool) -> Annex Bool inAnnexCheck :: Key -> (RawFilePath -> Annex Bool) -> Annex Bool
inAnnexCheck key check = inAnnex' id False check key inAnnexCheck key check = inAnnex' id False check key
{- inAnnex that performs an arbitrary check of the key's content. -} {- inAnnex that performs an arbitrary check of the key's content. -}
inAnnex' :: (a -> Bool) -> a -> (FilePath -> Annex a) -> Key -> Annex a inAnnex' :: (a -> Bool) -> a -> (RawFilePath -> Annex a) -> Key -> Annex a
inAnnex' isgood bad check key = withObjectLoc key $ \loc -> do inAnnex' isgood bad check key = withObjectLoc key $ \loc -> do
r <- check loc r <- check loc
if isgood r if isgood r
@ -120,12 +121,15 @@ inAnnex' isgood bad check key = withObjectLoc key $ \loc -> do
{- Like inAnnex, checks if the object file for a key exists, {- Like inAnnex, checks if the object file for a key exists,
- but there are no guarantees it has the right content. -} - but there are no guarantees it has the right content. -}
objectFileExists :: Key -> Annex Bool objectFileExists :: Key -> Annex Bool
objectFileExists key = calcRepo (gitAnnexLocation key) >>= liftIO . doesFileExist objectFileExists key =
calcRepo (gitAnnexLocation key)
>>= liftIO . R.doesPathExist
{- A safer check; the key's content must not only be present, but {- A safer check; the key's content must not only be present, but
- is not in the process of being removed. -} - is not in the process of being removed. -}
inAnnexSafe :: Key -> Annex (Maybe Bool) inAnnexSafe :: Key -> Annex (Maybe Bool)
inAnnexSafe key = inAnnex' (fromMaybe True) (Just False) go key inAnnexSafe key =
inAnnex' (fromMaybe True) (Just False) (go . fromRawFilePath) key
where where
is_locked = Nothing is_locked = Nothing
is_unlocked = Just True is_unlocked = Just True
@ -246,7 +250,7 @@ winLocker _ _ Nothing = return Nothing
lockContentUsing :: ContentLocker -> Key -> Annex a -> Annex a lockContentUsing :: ContentLocker -> Key -> Annex a -> Annex a
lockContentUsing locker key a = do lockContentUsing locker key a = do
contentfile <- calcRepo $ gitAnnexLocation key contentfile <- fromRawFilePath <$> calcRepo (gitAnnexLocation key)
lockfile <- contentLockFile key lockfile <- contentLockFile key
bracket bracket
(lock contentfile lockfile) (lock contentfile lockfile)
@ -474,18 +478,20 @@ moveAnnex key src = ifM (checkSecureHashes key)
, return False , return False
) )
where where
storeobject dest = ifM (liftIO $ doesFileExist dest) storeobject dest = ifM (liftIO $ R.doesPathExist dest)
( alreadyhave ( alreadyhave
, modifyContent dest $ do , modifyContent dest' $ do
freezeContent src freezeContent src
liftIO $ moveFile src dest liftIO $ moveFile src dest'
g <- Annex.gitRepo g <- Annex.gitRepo
fs <- map (`fromTopFilePath` g) fs <- map (`fromTopFilePath` g)
<$> Database.Keys.getAssociatedFiles key <$> Database.Keys.getAssociatedFiles key
unless (null fs) $ do unless (null fs) $ do
ics <- mapM (populatePointerFile (Restage True) key (toRawFilePath dest)) fs ics <- mapM (populatePointerFile (Restage True) key dest) fs
Database.Keys.storeInodeCaches' key [dest] (catMaybes ics) Database.Keys.storeInodeCaches' key [dest] (catMaybes ics)
) )
where
dest' = fromRawFilePath dest
alreadyhave = liftIO $ removeFile src alreadyhave = liftIO $ removeFile src
checkSecureHashes :: Key -> Annex Bool checkSecureHashes :: Key -> Annex Bool
@ -505,7 +511,7 @@ data LinkAnnexResult = LinkAnnexOk | LinkAnnexFailed | LinkAnnexNoop
linkToAnnex :: Key -> FilePath -> Maybe InodeCache -> Annex LinkAnnexResult linkToAnnex :: Key -> FilePath -> Maybe InodeCache -> Annex LinkAnnexResult
linkToAnnex key src srcic = ifM (checkSecureHashes key) linkToAnnex key src srcic = ifM (checkSecureHashes key)
( do ( do
dest <- calcRepo (gitAnnexLocation key) dest <- fromRawFilePath <$> calcRepo (gitAnnexLocation key)
modifyContent dest $ linkAnnex To key src srcic dest Nothing modifyContent dest $ linkAnnex To key src srcic dest Nothing
, return LinkAnnexFailed , return LinkAnnexFailed
) )
@ -515,7 +521,7 @@ linkFromAnnex :: Key -> FilePath -> Maybe FileMode -> Annex LinkAnnexResult
linkFromAnnex key dest destmode = do linkFromAnnex key dest destmode = do
src <- calcRepo (gitAnnexLocation key) src <- calcRepo (gitAnnexLocation key)
srcic <- withTSDelta (liftIO . genInodeCache src) srcic <- withTSDelta (liftIO . genInodeCache src)
linkAnnex From key src srcic dest destmode linkAnnex From key (fromRawFilePath src) srcic dest destmode
data FromTo = From | To data FromTo = From | To
@ -534,7 +540,7 @@ data FromTo = From | To
linkAnnex :: FromTo -> Key -> FilePath -> Maybe InodeCache -> FilePath -> Maybe FileMode -> Annex LinkAnnexResult linkAnnex :: FromTo -> Key -> FilePath -> Maybe InodeCache -> FilePath -> Maybe FileMode -> Annex LinkAnnexResult
linkAnnex _ _ _ Nothing _ _ = return LinkAnnexFailed linkAnnex _ _ _ Nothing _ _ = return LinkAnnexFailed
linkAnnex fromto key src (Just srcic) dest destmode = linkAnnex fromto key src (Just srcic) dest destmode =
withTSDelta (liftIO . genInodeCache dest) >>= \case withTSDelta (liftIO . genInodeCache dest') >>= \case
Just destic -> do Just destic -> do
cs <- Database.Keys.getInodeCaches key cs <- Database.Keys.getInodeCaches key
if null cs if null cs
@ -551,12 +557,13 @@ linkAnnex fromto key src (Just srcic) dest destmode =
Linked -> noop Linked -> noop
checksrcunchanged checksrcunchanged
where where
dest' = toRawFilePath dest
failed = do failed = do
Database.Keys.addInodeCaches key [srcic] Database.Keys.addInodeCaches key [srcic]
return LinkAnnexFailed return LinkAnnexFailed
checksrcunchanged = withTSDelta (liftIO . genInodeCache src) >>= \case checksrcunchanged = withTSDelta (liftIO . genInodeCache (toRawFilePath src)) >>= \case
Just srcic' | compareStrong srcic srcic' -> do Just srcic' | compareStrong srcic srcic' -> do
destic <- withTSDelta (liftIO . genInodeCache dest) destic <- withTSDelta (liftIO . genInodeCache dest')
Database.Keys.addInodeCaches key $ Database.Keys.addInodeCaches key $
catMaybes [destic, Just srcic] catMaybes [destic, Just srcic]
return LinkAnnexOk return LinkAnnexOk
@ -567,7 +574,7 @@ linkAnnex fromto key src (Just srcic) dest destmode =
{- Removes the annex object file for a key. Lowlevel. -} {- Removes the annex object file for a key. Lowlevel. -}
unlinkAnnex :: Key -> Annex () unlinkAnnex :: Key -> Annex ()
unlinkAnnex key = do unlinkAnnex key = do
obj <- calcRepo $ gitAnnexLocation key obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key)
modifyContent obj $ do modifyContent obj $ do
secureErase obj secureErase obj
liftIO $ nukeFile obj liftIO $ nukeFile obj
@ -616,15 +623,15 @@ prepSendAnnex key = withObjectLoc key $ \f -> do
else pure cache else pure cache
return $ if null cache' return $ if null cache'
then Nothing then Nothing
else Just (f, sameInodeCache f cache') else Just (fromRawFilePath f, sameInodeCache f cache')
{- Performs an action, passing it the location to use for a key's content. -} {- Performs an action, passing it the location to use for a key's content. -}
withObjectLoc :: Key -> (FilePath -> Annex a) -> Annex a withObjectLoc :: Key -> (RawFilePath -> Annex a) -> Annex a
withObjectLoc key a = a =<< calcRepo (gitAnnexLocation key) withObjectLoc key a = a =<< calcRepo (gitAnnexLocation key)
cleanObjectLoc :: Key -> Annex () -> Annex () cleanObjectLoc :: Key -> Annex () -> Annex ()
cleanObjectLoc key cleaner = do cleanObjectLoc key cleaner = do
file <- calcRepo $ gitAnnexLocation key file <- fromRawFilePath <$> calcRepo (gitAnnexLocation key)
void $ tryIO $ thawContentDir file void $ tryIO $ thawContentDir file
cleaner cleaner
liftIO $ removeparents file (3 :: Int) liftIO $ removeparents file (3 :: Int)
@ -640,22 +647,23 @@ cleanObjectLoc key cleaner = do
removeAnnex :: ContentRemovalLock -> Annex () removeAnnex :: ContentRemovalLock -> Annex ()
removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file -> removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file ->
cleanObjectLoc key $ do cleanObjectLoc key $ do
secureErase file let file' = fromRawFilePath file
liftIO $ nukeFile file secureErase file'
liftIO $ nukeFile file'
g <- Annex.gitRepo g <- Annex.gitRepo
mapM_ (\f -> void $ tryIO $ resetpointer $ fromRawFilePath $ fromTopFilePath f g) mapM_ (\f -> void $ tryIO $ resetpointer $ fromTopFilePath f g)
=<< Database.Keys.getAssociatedFiles key =<< Database.Keys.getAssociatedFiles key
Database.Keys.removeInodeCaches key Database.Keys.removeInodeCaches key
where where
-- 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 (toRawFilePath file) ( depopulatePointerFile key 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
-- removal process, so thaw it. -- removal process, so thaw it.
, void $ tryIO $ thawContent file , void $ tryIO $ thawContent $ fromRawFilePath file
) )
{- Check if a file contains the unmodified content of the key. {- Check if a file contains the unmodified content of the key.
@ -663,12 +671,12 @@ removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file ->
- The expensive way to tell is to do a verification of its content. - The expensive way to tell is to do a verification of its content.
- The cheaper way is to see if the InodeCache for the key matches the - The cheaper way is to see if the InodeCache for the key matches the
- file. -} - file. -}
isUnmodified :: Key -> FilePath -> Annex Bool isUnmodified :: Key -> RawFilePath -> Annex Bool
isUnmodified key f = go =<< geti isUnmodified key f = go =<< geti
where where
go Nothing = return False go Nothing = return False
go (Just fc) = isUnmodifiedCheap' key fc <||> expensivecheck fc go (Just fc) = isUnmodifiedCheap' key fc <||> expensivecheck fc
expensivecheck fc = ifM (verifyKeyContent RetrievalAllKeysSecure AlwaysVerify UnVerified key f) expensivecheck fc = ifM (verifyKeyContent RetrievalAllKeysSecure AlwaysVerify UnVerified key (fromRawFilePath f))
( do ( do
-- The file could have been modified while it was -- The file could have been modified while it was
-- being verified. Detect that. -- being verified. Detect that.
@ -691,7 +699,7 @@ isUnmodified key f = go =<< geti
- this may report a false positive when repeated edits are made to a file - this may report a false positive when repeated edits are made to a file
- within a small time window (eg 1 second). - within a small time window (eg 1 second).
-} -}
isUnmodifiedCheap :: Key -> FilePath -> Annex Bool isUnmodifiedCheap :: Key -> RawFilePath -> Annex Bool
isUnmodifiedCheap key f = maybe (return False) (isUnmodifiedCheap' key) isUnmodifiedCheap key f = maybe (return False) (isUnmodifiedCheap' key)
=<< withTSDelta (liftIO . genInodeCache f) =<< withTSDelta (liftIO . genInodeCache f)
@ -703,7 +711,7 @@ isUnmodifiedCheap' key fc =
- returns the file it was moved to. -} - returns the file it was moved to. -}
moveBad :: Key -> Annex FilePath moveBad :: Key -> Annex FilePath
moveBad key = do moveBad key = do
src <- calcRepo $ gitAnnexLocation key src <- fromRawFilePath <$> calcRepo (gitAnnexLocation key)
bad <- fromRepo gitAnnexBadDir bad <- fromRepo gitAnnexBadDir
let dest = bad </> takeFileName src let dest = bad </> takeFileName src
createAnnexDirectory (parentDir dest) createAnnexDirectory (parentDir dest)
@ -791,7 +799,7 @@ preseedTmp key file = go =<< inAnnex key
copy = ifM (liftIO $ doesFileExist file) copy = ifM (liftIO $ doesFileExist file)
( return True ( return True
, do , do
s <- calcRepo $ gitAnnexLocation key s <- fromRawFilePath <$> (calcRepo $ gitAnnexLocation key)
liftIO $ ifM (doesFileExist s) liftIO $ ifM (doesFileExist s)
( copyFileExternal CopyTimeStamps s file ( copyFileExternal CopyTimeStamps s file
, return False , return False

7
Annex/Content/PointerFile.hs
View file

@ -38,10 +38,11 @@ populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f)
destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f' destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f'
liftIO $ nukeFile f' liftIO $ nukeFile f'
(ic, populated) <- replaceFile f' $ \tmp -> do (ic, populated) <- replaceFile f' $ \tmp -> do
let tmp' = toRawFilePath tmp
ok <- linkOrCopy k (fromRawFilePath obj) tmp destmode >>= \case ok <- linkOrCopy k (fromRawFilePath obj) tmp destmode >>= \case
Just _ -> thawContent tmp >> return True Just _ -> thawContent tmp >> return True
Nothing -> liftIO (writePointerFile (toRawFilePath tmp) k destmode) >> return False Nothing -> liftIO (writePointerFile 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
if populated if populated
@ -68,5 +69,5 @@ depopulatePointerFile key file = do
(\t -> touch tmp t False) (\t -> touch tmp t False)
(fmap modificationTimeHiRes st) (fmap modificationTimeHiRes st)
#endif #endif
withTSDelta (liftIO . genInodeCache tmp) withTSDelta (liftIO . genInodeCache (toRawFilePath tmp))
maybe noop (restagePointerFile (Restage True) file) ic maybe noop (restagePointerFile (Restage True) file) ic

32
Annex/DirHashes.hs
View file

@ -1,6 +1,6 @@
{- git-annex file locations {- git-annex file locations
- -
- Copyright 2010-2017 Joey Hess <id@joeyh.name> - Copyright 2010-2019 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -19,7 +19,10 @@ module Annex.DirHashes (
import Data.Default import Data.Default
import Data.Bits import Data.Bits
import qualified Data.ByteArray import qualified Data.ByteArray as BA
import qualified Data.ByteArray.Encoding as BA
import qualified Data.ByteString as S
import qualified System.FilePath.ByteString as P
import Common import Common
import Key import Key
@ -28,7 +31,7 @@ import Types.Difference
import Utility.Hash import Utility.Hash
import Utility.MD5 import Utility.MD5
type Hasher = Key -> FilePath type Hasher = Key -> RawFilePath
-- Number of hash levels to use. 2 is the default. -- Number of hash levels to use. 2 is the default.
newtype HashLevels = HashLevels Int newtype HashLevels = HashLevels Int
@ -47,7 +50,7 @@ configHashLevels d config
| hasDifference d (annexDifferences config) = HashLevels 1 | hasDifference d (annexDifferences config) = HashLevels 1
| otherwise = def | otherwise = def
branchHashDir :: GitConfig -> Key -> String branchHashDir :: GitConfig -> Key -> S.ByteString
branchHashDir = hashDirLower . branchHashLevels branchHashDir = hashDirLower . branchHashLevels
{- Two different directory hashes may be used. The mixed case hash {- Two different directory hashes may be used. The mixed case hash
@ -60,19 +63,26 @@ branchHashDir = hashDirLower . branchHashLevels
dirHashes :: [HashLevels -> Hasher] dirHashes :: [HashLevels -> Hasher]
dirHashes = [hashDirLower, hashDirMixed] dirHashes = [hashDirLower, hashDirMixed]
hashDirs :: HashLevels -> Int -> String -> FilePath hashDirs :: HashLevels -> Int -> S.ByteString -> RawFilePath
hashDirs (HashLevels 1) sz s = addTrailingPathSeparator $ take sz s hashDirs (HashLevels 1) sz s = P.addTrailingPathSeparator $ S.take sz s
hashDirs _ sz s = addTrailingPathSeparator $ take sz s </> drop sz s hashDirs _ sz s = P.addTrailingPathSeparator $ h P.</> t
where
(h, t) = S.splitAt sz s
hashDirLower :: HashLevels -> Hasher hashDirLower :: HashLevels -> Hasher
hashDirLower n k = hashDirs n 3 $ take 6 $ show $ md5s $ serializeKey' $ nonChunkKey k hashDirLower n k = hashDirs n 3 $ S.pack $ take 6 $ conv $
md5s $ serializeKey' $ nonChunkKey k
where
conv v = BA.unpack $
(BA.convertToBase BA.Base16 v :: BA.Bytes)
{- This was originally using Data.Hash.MD5 from MissingH. This new version {- This was originally using Data.Hash.MD5 from MissingH. This new version
- is faster, but ugly as it has to replicate the 4 Word32's that produced. -} - is faster, but ugly as it has to replicate the 4 Word32's that produced. -}
hashDirMixed :: HashLevels -> Hasher hashDirMixed :: HashLevels -> Hasher
hashDirMixed n k = hashDirs n 2 $ take 4 $ concatMap display_32bits_as_dir $ hashDirMixed n k = hashDirs n 2 $ S.pack $ take 4 $
encodeWord32 $ map fromIntegral $ Data.ByteArray.unpack $ concatMap display_32bits_as_dir $
Utility.Hash.md5s $ serializeKey' $ nonChunkKey k encodeWord32 $ map fromIntegral $ BA.unpack $
Utility.Hash.md5s $ serializeKey' $ nonChunkKey k
where where
encodeWord32 (b1:b2:b3:b4:rest) = encodeWord32 (b1:b2:b3:b4:rest) =
(shiftL b4 24 .|. shiftL b3 16 .|. shiftL b2 8 .|. b1) (shiftL b4 24 .|. shiftL b3 16 .|. shiftL b2 8 .|. b1)

13
Annex/Ingest.hs
View file

@ -92,7 +92,7 @@ lockDown' cfg file = tryIO $ ifM crippledFileSystem
nohardlink = withTSDelta $ liftIO . nohardlink' nohardlink = withTSDelta $ liftIO . nohardlink'
nohardlink' delta = do nohardlink' delta = do
cache <- genInodeCache file delta cache <- genInodeCache (toRawFilePath file) delta
return $ LockedDown cfg $ KeySource return $ LockedDown cfg $ KeySource
{ keyFilename = file { keyFilename = file
, contentLocation = file , contentLocation = file
@ -112,7 +112,7 @@ lockDown' cfg file = tryIO $ ifM crippledFileSystem
withhardlink' delta tmpfile = do withhardlink' delta tmpfile = do
createLink file tmpfile createLink file tmpfile
cache <- genInodeCache tmpfile delta cache <- genInodeCache (toRawFilePath tmpfile) delta
return $ LockedDown cfg $ KeySource return $ LockedDown cfg $ KeySource
{ keyFilename = file { keyFilename = file
, contentLocation = tmpfile , contentLocation = tmpfile
@ -209,7 +209,7 @@ finishIngestUnlocked' key source restage = do
{- Copy to any other locations using the same key. -} {- Copy to any other locations using the same key. -}
populateAssociatedFiles :: Key -> KeySource -> Restage -> Annex () populateAssociatedFiles :: Key -> KeySource -> Restage -> Annex ()
populateAssociatedFiles key source restage = do populateAssociatedFiles key source restage = do
obj <- toRawFilePath <$> calcRepo (gitAnnexLocation key) obj <- calcRepo (gitAnnexLocation key)
g <- Annex.gitRepo g <- Annex.gitRepo
ingestedf <- flip fromTopFilePath g ingestedf <- flip fromTopFilePath g
<$> inRepo (toTopFilePath (toRawFilePath (keyFilename source))) <$> inRepo (toTopFilePath (toRawFilePath (keyFilename source)))
@ -235,8 +235,7 @@ cleanOldKeys file newkey = do
unlessM (isUnmodified key =<< calcRepo (gitAnnexLocation key)) $ do unlessM (isUnmodified key =<< calcRepo (gitAnnexLocation key)) $ do
caches <- Database.Keys.getInodeCaches key caches <- Database.Keys.getInodeCaches key
unlinkAnnex key unlinkAnnex key
fs <- map fromRawFilePath fs <- filter (/= ingestedf)
. filter (/= ingestedf)
. map (`fromTopFilePath` g) . map (`fromTopFilePath` g)
<$> Database.Keys.getAssociatedFiles key <$> Database.Keys.getAssociatedFiles key
filterM (`sameInodeCache` caches) fs >>= \case filterM (`sameInodeCache` caches) fs >>= \case
@ -245,7 +244,7 @@ cleanOldKeys file newkey = do
-- so no need for any recovery. -- so no need for any recovery.
(f:_) -> do (f:_) -> do
ic <- withTSDelta (liftIO . genInodeCache f) ic <- withTSDelta (liftIO . genInodeCache f)
void $ linkToAnnex key f ic void $ linkToAnnex key (fromRawFilePath f) ic
_ -> logStatus key InfoMissing _ -> logStatus key InfoMissing
{- On error, put the file back so it doesn't seem to have vanished. {- On error, put the file back so it doesn't seem to have vanished.
@ -256,7 +255,7 @@ restoreFile file key e = do
liftIO $ nukeFile file liftIO $ nukeFile file
-- The key could be used by other files too, so leave the -- The key could be used by other files too, so leave the
-- content in the annex, and make a copy back to the file. -- content in the annex, and make a copy back to the file.
obj <- calcRepo $ gitAnnexLocation key obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key)
unlessM (liftIO $ copyFileExternal CopyTimeStamps obj file) $ unlessM (liftIO $ copyFileExternal CopyTimeStamps obj file) $
warning $ "Unable to restore content of " ++ file ++ "; it should be located in " ++ obj warning $ "Unable to restore content of " ++ file ++ "; it should be located in " ++ obj
thawContent file thawContent file

4
Annex/InodeSentinal.hs
View file

@ -29,7 +29,7 @@ compareInodeCachesWith = ifM inodesChanged ( return Weakly, return Strongly )
{- Checks if one of the provided old InodeCache matches the current {- Checks if one of the provided old InodeCache matches the current
- version of a file. -} - version of a file. -}
sameInodeCache :: FilePath -> [InodeCache] -> Annex Bool sameInodeCache :: RawFilePath -> [InodeCache] -> Annex Bool
sameInodeCache _ [] = return False sameInodeCache _ [] = return False
sameInodeCache file old = go =<< withTSDelta (liftIO . genInodeCache file) sameInodeCache file old = go =<< withTSDelta (liftIO . genInodeCache file)
where where
@ -78,7 +78,7 @@ createInodeSentinalFile :: Bool -> Annex ()
createInodeSentinalFile evenwithobjects = createInodeSentinalFile evenwithobjects =
unlessM (alreadyexists <||> hasobjects) $ do unlessM (alreadyexists <||> hasobjects) $ do
s <- annexSentinalFile s <- annexSentinalFile
createAnnexDirectory (parentDir (sentinalFile s)) createAnnexDirectory (parentDir (fromRawFilePath (sentinalFile s)))
liftIO $ writeSentinalFile s liftIO $ writeSentinalFile s
where where
alreadyexists = liftIO. sentinalFileExists =<< annexSentinalFile alreadyexists = liftIO. sentinalFileExists =<< annexSentinalFile

30
Annex/Journal.hs
View file

@ -20,7 +20,9 @@ import Utility.Directory.Stream
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified System.FilePath.ByteString as P
import Data.ByteString.Builder import Data.ByteString.Builder
import Data.Char
class Journalable t where class Journalable t where
writeJournalHandle :: Handle -> t -> IO () writeJournalHandle :: Handle -> t -> IO ()
@ -48,7 +50,7 @@ setJournalFile :: Journalable content => JournalLocked -> RawFilePath -> content
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 $ fromRawFilePath file jfile <- fromRawFilePath <$> fromRepo (journalFile 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
@ -71,7 +73,7 @@ getJournalFile _jl = getJournalFileStale
-} -}
getJournalFileStale :: RawFilePath -> 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 (fromRawFilePath file) g) L.fromStrict <$> S.readFile (fromRawFilePath $ journalFile 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
@ -81,7 +83,8 @@ getJournalledFilesStale = do
g <- gitRepo g <- gitRepo
fs <- liftIO $ catchDefaultIO [] $ fs <- liftIO $ catchDefaultIO [] $
getDirectoryContents $ gitAnnexJournalDir g getDirectoryContents $ gitAnnexJournalDir g
return $ filter (`notElem` [".", ".."]) $ map fileJournal fs return $ filter (`notElem` [".", ".."]) $
map (fromRawFilePath . fileJournal . toRawFilePath) fs
withJournalHandle :: (DirectoryHandle -> IO a) -> Annex a withJournalHandle :: (DirectoryHandle -> IO a) -> Annex a
withJournalHandle a = do withJournalHandle a = do
@ -97,24 +100,29 @@ journalDirty = do
`catchIO` (const $ doesDirectoryExist d) `catchIO` (const $ doesDirectoryExist d)
{- Produces a filename to use in the journal for a file on the branch. {- Produces a filename to use in the journal for a file on the branch.
-
- The input filename is assumed to not contain any '_' character,
- since path separators are replaced with that.
- -
- The journal typically won't have a lot of files in it, so the hashing - The journal typically won't have a lot of files in it, so the hashing
- used in the branch is not necessary, and all the files are put directly - used in the branch is not necessary, and all the files are put directly
- in the journal directory. - in the journal directory.
-} -}
journalFile :: FilePath -> Git.Repo -> FilePath journalFile :: RawFilePath -> Git.Repo -> RawFilePath
journalFile file repo = gitAnnexJournalDir repo </> concatMap mangle file journalFile file repo = gitAnnexJournalDir' repo P.</> S.map mangle file
where where
mangle c mangle c
| c == pathSeparator = "_" | c == P.pathSeparator = fromIntegral (ord '_')
| c == '_' = "__" | otherwise = c
| otherwise = [c]
{- Converts a journal file (relative to the journal dir) back to the {- Converts a journal file (relative to the journal dir) back to the
- filename on the branch. -} - filename on the branch. -}
fileJournal :: FilePath -> FilePath fileJournal :: RawFilePath -> RawFilePath
fileJournal = replace [pathSeparator, pathSeparator] "_" . fileJournal = S.map unmangle
replace "_" [pathSeparator] where
unmangle c
| c == fromIntegral (ord '_') = P.pathSeparator
| otherwise = c
{- Sentinal value, only produced by lockJournal; required {- Sentinal value, only produced by lockJournal; required
- as a parameter by things that need to ensure the journal is - as a parameter by things that need to ensure the journal is

8
Annex/Link.hs
View file

@ -39,6 +39,7 @@ import qualified Utility.RawFilePath as R
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified System.FilePath.ByteString as P
type LinkTarget = String type LinkTarget = String
@ -182,7 +183,7 @@ restagePointerFile (Restage True) f orig = withTSDelta $ \tsd -> do
absf <- liftIO $ absPath $ fromRawFilePath 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 f tsd >>= return . \case
Nothing -> False Nothing -> False
Just new -> compareStrong orig new Just new -> compareStrong orig new
@ -301,8 +302,7 @@ isLinkToAnnex s = p `S.isInfixOf` s
|| p' `S.isInfixOf` s || p' `S.isInfixOf` s
#endif #endif
where where
sp = (pathSeparator:objectDir) p = P.pathSeparator `S.cons` objectDir'
p = toRawFilePath sp
#ifdef mingw32_HOST_OS #ifdef mingw32_HOST_OS
p' = toRawFilePath (toInternalGitPath sp) p' = toInternalGitPath p
#endif #endif

64
Annex/Locations.hs
View file

@ -16,6 +16,7 @@ module Annex.Locations (
keyPath, keyPath,
annexDir, annexDir,
objectDir, objectDir,
objectDir',
gitAnnexLocation, gitAnnexLocation,
gitAnnexLocationDepth, gitAnnexLocationDepth,
gitAnnexLink, gitAnnexLink,
@ -62,6 +63,7 @@ module Annex.Locations (
gitAnnexFeedState, gitAnnexFeedState,
gitAnnexMergeDir, gitAnnexMergeDir,
gitAnnexJournalDir, gitAnnexJournalDir,
gitAnnexJournalDir',
gitAnnexJournalLock, gitAnnexJournalLock,
gitAnnexGitQueueLock, gitAnnexGitQueueLock,
gitAnnexPreCommitLock, gitAnnexPreCommitLock,
@ -105,6 +107,7 @@ import qualified Git.Types as Git
import Git.FilePath import Git.FilePath
import Annex.DirHashes import Annex.DirHashes
import Annex.Fixup import Annex.Fixup
import qualified Utility.RawFilePath as R
{- Conventions: {- Conventions:
- -
@ -124,21 +127,27 @@ import Annex.Fixup
annexDir :: FilePath annexDir :: FilePath
annexDir = addTrailingPathSeparator "annex" annexDir = addTrailingPathSeparator "annex"
annexDir' :: RawFilePath
annexDir' = P.addTrailingPathSeparator "annex"
{- The directory git annex uses for locally available object content, {- The directory git annex uses for locally available object content,
- relative to the .git directory -} - relative to the .git directory -}
objectDir :: FilePath objectDir :: FilePath
objectDir = addTrailingPathSeparator $ annexDir </> "objects" objectDir = addTrailingPathSeparator $ annexDir </> "objects"
objectDir' :: RawFilePath
objectDir' = P.addTrailingPathSeparator $ annexDir' P.</> "objects"
{- Annexed file's possible locations relative to the .git directory. {- Annexed file's possible locations relative to the .git directory.
- There are two different possibilities, using different hashes. - There are two different possibilities, using different hashes.
- -
- Also, some repositories have a Difference in hash directory depth. - Also, some repositories have a Difference in hash directory depth.
-} -}
annexLocations :: GitConfig -> Key -> [FilePath] annexLocations :: GitConfig -> Key -> [RawFilePath]
annexLocations config key = map (annexLocation config key) dirHashes annexLocations config key = map (annexLocation config key) dirHashes
annexLocation :: GitConfig -> Key -> (HashLevels -> Hasher) -> FilePath annexLocation :: GitConfig -> Key -> (HashLevels -> Hasher) -> RawFilePath
annexLocation config key hasher = objectDir </> keyPath key (hasher $ objectHashLevels config) annexLocation config key hasher = objectDir' P.</> keyPath key (hasher $ objectHashLevels config)
{- Number of subdirectories from the gitAnnexObjectDir {- Number of subdirectories from the gitAnnexObjectDir
- to the gitAnnexLocation. -} - to the gitAnnexLocation. -}
@ -158,14 +167,14 @@ gitAnnexLocationDepth config = hashlevels + 1
- This does not take direct mode into account, so in direct mode it is not - This does not take direct mode into account, so in direct mode it is not
- the actual location of the file's content. - the actual location of the file's content.
-} -}
gitAnnexLocation :: Key -> Git.Repo -> GitConfig -> IO FilePath gitAnnexLocation :: Key -> Git.Repo -> GitConfig -> IO RawFilePath
gitAnnexLocation key r config = gitAnnexLocation' key r config gitAnnexLocation key r config = gitAnnexLocation' key r config
(annexCrippledFileSystem config) (annexCrippledFileSystem config)
(coreSymlinks config) (coreSymlinks config)
doesFileExist R.doesPathExist
(fromRawFilePath (Git.localGitDir r)) (Git.localGitDir r)
gitAnnexLocation' :: Key -> Git.Repo -> GitConfig -> Bool -> Bool -> (FilePath -> IO Bool) -> FilePath -> IO FilePath gitAnnexLocation' :: Key -> Git.Repo -> GitConfig -> Bool -> Bool -> (RawFilePath -> IO Bool) -> RawFilePath -> IO RawFilePath
gitAnnexLocation' key r config crippled symlinkssupported checker gitdir gitAnnexLocation' key r config crippled symlinkssupported checker gitdir
{- Bare repositories default to hashDirLower for new {- Bare repositories default to hashDirLower for new
- content, as it's more portable. But check all locations. -} - content, as it's more portable. But check all locations. -}
@ -187,7 +196,7 @@ gitAnnexLocation' key r config crippled symlinkssupported checker gitdir
only = return . inrepo . annexLocation config key only = return . inrepo . annexLocation config key
checkall = check $ map inrepo $ annexLocations config key checkall = check $ map inrepo $ annexLocations config key
inrepo d = gitdir </> d inrepo d = gitdir P.</> d
check locs@(l:_) = fromMaybe l <$> firstM checker locs check locs@(l:_) = fromMaybe l <$> firstM checker locs
check [] = error "internal" check [] = error "internal"
@ -199,16 +208,17 @@ gitAnnexLink file key r config = do
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
fromRawFilePath . toInternalGitPath . toRawFilePath fromRawFilePath . toInternalGitPath . toRawFilePath
<$> relPathDirToFile (parentDir absfile) loc <$> relPathDirToFile (parentDir absfile) (fromRawFilePath 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
- supporting symlinks; generate link target that will - supporting symlinks; generate link target that will
- work portably. -} - work portably. -}
| not (coreSymlinks config) && needsSubmoduleFixup r = | not (coreSymlinks config) && needsSubmoduleFixup r =
absNormPathUnix currdir $ fromRawFilePath $ toRawFilePath $
Git.repoPath r P.</> ".git" absNormPathUnix currdir $ fromRawFilePath $
| otherwise = fromRawFilePath $ Git.localGitDir r Git.repoPath r P.</> ".git"
| otherwise = Git.localGitDir r
absNormPathUnix d p = fromRawFilePath $ toInternalGitPath $ toRawFilePath $ absNormPathUnix d p = fromRawFilePath $ toInternalGitPath $ toRawFilePath $
absPathFrom absPathFrom
(fromRawFilePath $ toInternalGitPath $ toRawFilePath d) (fromRawFilePath $ toInternalGitPath $ toRawFilePath d)
@ -232,33 +242,36 @@ gitAnnexLinkCanonical file key r config = gitAnnexLink file key r' config'
gitAnnexContentLock :: Key -> Git.Repo -> GitConfig -> IO FilePath gitAnnexContentLock :: Key -> Git.Repo -> GitConfig -> IO FilePath
gitAnnexContentLock key r config = do gitAnnexContentLock key r config = do
loc <- gitAnnexLocation key r config loc <- gitAnnexLocation key r config
return $ loc ++ ".lck" return $ fromRawFilePath loc ++ ".lck"
{- File that maps from a key to the file(s) in the git repository. {- File that maps from a key to the file(s) in the git repository.
- Used in direct mode. -} - Used in direct mode. -}
gitAnnexMapping :: Key -> Git.Repo -> GitConfig -> IO FilePath gitAnnexMapping :: Key -> Git.Repo -> GitConfig -> IO FilePath
gitAnnexMapping key r config = do gitAnnexMapping key r config = do
loc <- gitAnnexLocation key r config loc <- gitAnnexLocation key r config
return $ loc ++ ".map" return $ fromRawFilePath loc ++ ".map"
{- File that caches information about a key's content, used to determine {- File that caches information about a key's content, used to determine
- if a file has changed. - if a file has changed.
- Used in direct mode. -} - Used in direct mode. -}
gitAnnexInodeCache :: Key -> Git.Repo -> GitConfig -> IO FilePath gitAnnexInodeCache :: Key -> Git.Repo -> GitConfig -> IO FilePath
gitAnnexInodeCache key r config = do gitAnnexInodeCache key r config = do
loc <- gitAnnexLocation key r config loc <- gitAnnexLocation key r config
return $ loc ++ ".cache" return $ fromRawFilePath loc ++ ".cache"
gitAnnexInodeSentinal :: Git.Repo -> FilePath gitAnnexInodeSentinal :: Git.Repo -> RawFilePath
gitAnnexInodeSentinal r = gitAnnexDir r </> "sentinal" gitAnnexInodeSentinal r = gitAnnexDir' r P.</> "sentinal"
gitAnnexInodeSentinalCache :: Git.Repo -> FilePath gitAnnexInodeSentinalCache :: Git.Repo -> RawFilePath
gitAnnexInodeSentinalCache r = gitAnnexInodeSentinal r ++ ".cache" gitAnnexInodeSentinalCache r = gitAnnexInodeSentinal r <> ".cache"
{- The annex directory of a repository. -} {- The annex directory of a repository. -}
gitAnnexDir :: Git.Repo -> FilePath gitAnnexDir :: Git.Repo -> FilePath
gitAnnexDir r = addTrailingPathSeparator $ fromRawFilePath (Git.localGitDir r) </> annexDir gitAnnexDir r = addTrailingPathSeparator $ fromRawFilePath (Git.localGitDir r) </> annexDir
gitAnnexDir' :: Git.Repo -> RawFilePath
gitAnnexDir' r = P.addTrailingPathSeparator $ Git.localGitDir r P.</> annexDir'
{- The part of the annex directory where file contents are stored. -} {- The part of the annex directory where file contents are stored. -}
gitAnnexObjectDir :: Git.Repo -> FilePath gitAnnexObjectDir :: Git.Repo -> FilePath
gitAnnexObjectDir r = addTrailingPathSeparator $ fromRawFilePath (Git.localGitDir r) </> objectDir gitAnnexObjectDir r = addTrailingPathSeparator $ fromRawFilePath (Git.localGitDir r) </> objectDir
@ -428,6 +441,9 @@ gitAnnexTransferDir r = addTrailingPathSeparator $ gitAnnexDir r </> "transfer"
gitAnnexJournalDir :: Git.Repo -> FilePath gitAnnexJournalDir :: Git.Repo -> FilePath
gitAnnexJournalDir r = addTrailingPathSeparator $ gitAnnexDir r </> "journal" gitAnnexJournalDir r = addTrailingPathSeparator $ gitAnnexDir r </> "journal"
gitAnnexJournalDir' :: Git.Repo -> RawFilePath
gitAnnexJournalDir' r = P.addTrailingPathSeparator $ gitAnnexDir' r P.</> "journal"
{- Lock file for the journal. -} {- Lock file for the journal. -}
gitAnnexJournalLock :: Git.Repo -> FilePath gitAnnexJournalLock :: Git.Repo -> FilePath
gitAnnexJournalLock r = gitAnnexDir r </> "journal.lck" gitAnnexJournalLock r = gitAnnexDir r </> "journal.lck"
@ -609,10 +625,10 @@ fileKey' = deserializeKey' . S8.intercalate "/" . map go . S8.split '%'
- The file is put in a directory with the same name, this allows - The file is put in a directory with the same name, this allows
- write-protecting the directory to avoid accidental deletion of the file. - write-protecting the directory to avoid accidental deletion of the file.
-} -}
keyPath :: Key -> Hasher -> FilePath keyPath :: Key -> Hasher -> RawFilePath
keyPath key hasher = hasher key </> f </> f keyPath key hasher = hasher key P.</> f P.</> f
where where
f = keyFile key f = keyFile' key
{- All possibile locations to store a key in a special remote {- All possibile locations to store a key in a special remote
- using different directory hashes. - using different directory hashes.
@ -620,5 +636,5 @@ keyPath key hasher = hasher key </> f </> f
- This is compatible with the annexLocations, for interoperability between - This is compatible with the annexLocations, for interoperability between
- special remotes and git-annex repos. - special remotes and git-annex repos.
-} -}
keyPaths :: Key -> [FilePath] keyPaths :: Key -> [RawFilePath]
keyPaths key = map (\h -> keyPath key (h def)) dirHashes keyPaths key = map (\h -> keyPath key (h def)) dirHashes

7
Annex/WorkTree.hs
View file

@ -101,13 +101,14 @@ scanUnlockedFiles = whenM (inRepo Git.Ref.headExists <&&> not <$> isBareRepo) $
Just k' | k' == k -> do Just k' | k' == k -> do
destmode <- liftIO $ catchMaybeIO $ destmode <- liftIO $ catchMaybeIO $
fileMode <$> R.getFileStatus f fileMode <$> R.getFileStatus f
ic <- replaceFile (fromRawFilePath f) $ \tmp -> ic <- replaceFile (fromRawFilePath f) $ \tmp -> do
let tmp' = toRawFilePath tmp
linkFromAnnex k tmp destmode >>= \case linkFromAnnex k tmp destmode >>= \case
LinkAnnexOk -> LinkAnnexOk ->
withTSDelta (liftIO . genInodeCache tmp) withTSDelta (liftIO . genInodeCache tmp')
LinkAnnexNoop -> return Nothing LinkAnnexNoop -> return Nothing
LinkAnnexFailed -> liftIO $ do LinkAnnexFailed -> liftIO $ do
writePointerFile (toRawFilePath tmp) k destmode writePointerFile tmp' k destmode
return Nothing return Nothing
maybe noop (restagePointerFile (Restage True) f) ic maybe noop (restagePointerFile (Restage True) f) ic
_ -> noop _ -> noop

2
Assistant/Threads/Committer.hs
View file

@ -308,7 +308,7 @@ handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do
if M.null m if M.null m
then forM toadd (add cfg) then forM toadd (add cfg)
else forM toadd $ \c -> do else forM toadd $ \c -> do
mcache <- liftIO $ genInodeCache (changeFile c) delta mcache <- liftIO $ genInodeCache (toRawFilePath (changeFile c)) delta
case mcache of case mcache of
Nothing -> add cfg c Nothing -> add cfg c
Just cache -> Just cache ->

2
Assistant/Upgrade.hs
View file

@ -113,7 +113,7 @@ distributionDownloadComplete d dest cleanup t
| transferDirection t == Download = do | transferDirection t == Download = do
debug ["finished downloading git-annex distribution"] debug ["finished downloading git-annex distribution"]
maybe (failedupgrade "bad download") go maybe (failedupgrade "bad download") go
=<< liftAnnex (withObjectLoc k fsckit) =<< liftAnnex (withObjectLoc k (fsckit . fromRawFilePath))
| otherwise = cleanup | otherwise = cleanup
where where
k = mkKey $ const $ distributionKey d k = mkKey $ const $ distributionKey d

12
CHANGELOG
View file

@ -1,13 +1,9 @@
git-annex (7.20191115) UNRELEASED; urgency=medium git-annex (7.20191115) UNRELEASED; urgency=medium
* Sped up many git-annex commands that operate on many files, by * Optimised processing of many files, especially by commands like find
using ByteStrings. Some commands like find got up to 60% faster. and whereis that only report on the state of the repository. Commands
* Sped up many git-annex commands that operate on many files, by like get also sped up in cases where they have to check a lot of
avoiding reserialization of keys. files but only transfer a few files. Speedups range from 30-100%.
find got 7% faster; whereis 3% faster; and git-annex get when
all files are already present got 5% faster
* Sped up many git-annex commands that query the git-annex branch.
In particular whereis got 1.5% faster.
* Stop displaying rsync progress, and use git-annex's own progress display * Stop displaying rsync progress, and use git-annex's own progress display
for local-to-local repo transfers. for local-to-local repo transfers.
* git-lfs: The url provided to initremote/enableremote will now be * git-lfs: The url provided to initremote/enableremote will now be

2
CmdLine/Seek.hs
View file

@ -131,7 +131,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 (fromRawFilePath f) =<< Database.Keys.getInodeCaches k Just k -> sameInodeCache 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

7
Command/ContentLocation.hs
View file

@ -9,6 +9,9 @@ module Command.ContentLocation where
import Command import Command
import Annex.Content import Annex.Content
import qualified Utility.RawFilePath as R
import qualified Data.ByteString.Char8 as B8
cmd :: Command cmd :: Command
cmd = noCommit $ noMessages $ cmd = noCommit $ noMessages $
@ -20,10 +23,10 @@ cmd = noCommit $ noMessages $
run :: () -> String -> Annex Bool run :: () -> String -> Annex Bool
run _ p = do run _ p = do
let k = fromMaybe (giveup "bad key") $ deserializeKey p let k = fromMaybe (giveup "bad key") $ deserializeKey p
maybe (return False) (\f -> liftIO (putStrLn f) >> return True) maybe (return False) (\f -> liftIO (B8.putStrLn f) >> return True)
=<< inAnnex' (pure True) Nothing check k =<< inAnnex' (pure True) Nothing check k
where where
check f = ifM (liftIO (doesFileExist f)) check f = ifM (liftIO (R.doesPathExist f))
( return (Just f) ( return (Just f)
, return Nothing , return Nothing
) )

3
Command/DiffDriver.hs
View file

@ -90,7 +90,8 @@ fixupReq req@(Req {}) =
v <- getAnnexLinkTarget' (toRawFilePath (getfile r)) False v <- getAnnexLinkTarget' (toRawFilePath (getfile r)) False
case parseLinkTargetOrPointer =<< v of case parseLinkTargetOrPointer =<< v of
Nothing -> return r Nothing -> return r
Just k -> withObjectLoc k (pure . setfile r) Just k -> withObjectLoc k $
pure . setfile r . fromRawFilePath
_ -> return r _ -> return r
externalDiffer :: String -> [String] -> Differ externalDiffer :: String -> [String] -> Differ

4
Command/Find.hs
View file

@ -93,8 +93,8 @@ keyVars key =
, ("bytesize", size show) , ("bytesize", size show)
, ("humansize", size $ roughSize storageUnits True) , ("humansize", size $ roughSize storageUnits True)
, ("keyname", decodeBS $ fromKey keyName key) , ("keyname", decodeBS $ fromKey keyName key)
, ("hashdirlower", hashDirLower def key) , ("hashdirlower", fromRawFilePath $ hashDirLower def key)
, ("hashdirmixed", hashDirMixed def key) , ("hashdirmixed", fromRawFilePath $ hashDirMixed def key)
, ("mtime", whenavail show $ fromKey keyMtime key) , ("mtime", whenavail show $ fromKey keyMtime key)
] ]
where where

15
Command/Fix.hs
View file

@ -53,11 +53,11 @@ start fixwhat file key = do
where where
fixby = starting "fix" (mkActionItem (key, file)) fixby = starting "fix" (mkActionItem (key, file))
fixthin = do fixthin = do
obj <- calcRepo $ gitAnnexLocation key obj <- calcRepo (gitAnnexLocation key)
stopUnless (isUnmodified key (fromRawFilePath file) <&&> isUnmodified key obj) $ do stopUnless (isUnmodified key file <&&> isUnmodified key obj) $ do
thin <- annexThin <$> Annex.getGitConfig thin <- annexThin <$> Annex.getGitConfig
fs <- liftIO $ catchMaybeIO $ R.getFileStatus file fs <- liftIO $ catchMaybeIO $ R.getFileStatus file
os <- liftIO $ catchMaybeIO $ getFileStatus obj os <- liftIO $ catchMaybeIO $ R.getFileStatus obj
case (linkCount <$> fs, linkCount <$> os, thin) of case (linkCount <$> fs, linkCount <$> os, thin) of
(Just 1, Just 1, True) -> (Just 1, Just 1, True) ->
fixby $ makeHardLink file key fixby $ makeHardLink file key
@ -65,15 +65,16 @@ start fixwhat file key = do
fixby $ breakHardLink file key obj fixby $ breakHardLink file key obj
_ -> stop _ -> stop
breakHardLink :: RawFilePath -> Key -> FilePath -> CommandPerform breakHardLink :: RawFilePath -> Key -> RawFilePath -> CommandPerform
breakHardLink file key obj = do breakHardLink file key obj = do
replaceFile (fromRawFilePath file) $ \tmp -> do replaceFile (fromRawFilePath file) $ \tmp -> do
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
unlessM (checkedCopyFile key obj tmp mode) $ let obj' = fromRawFilePath obj
unlessM (checkedCopyFile key obj' tmp mode) $
error "unable to break hard link" error "unable to break hard link"
thawContent tmp thawContent tmp
modifyContent obj $ freezeContent obj modifyContent obj' $ freezeContent obj'
Database.Keys.storeInodeCaches key [fromRawFilePath file] Database.Keys.storeInodeCaches key [file]
next $ return True next $ return True
makeHardLink :: RawFilePath -> Key -> CommandPerform makeHardLink :: RawFilePath -> Key -> CommandPerform

18
Command/Fsck.hs
View file

@ -223,7 +223,7 @@ fixLink key file = do
- in this repository only. -} - in this repository only. -}
verifyLocationLog :: Key -> KeyStatus -> ActionItem -> Annex Bool verifyLocationLog :: Key -> KeyStatus -> ActionItem -> Annex Bool
verifyLocationLog key keystatus ai = do verifyLocationLog key keystatus ai = do
obj <- calcRepo $ gitAnnexLocation key obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key)
present <- if isKeyUnlockedThin keystatus present <- if isKeyUnlockedThin keystatus
then liftIO (doesFileExist obj) then liftIO (doesFileExist obj)
else inAnnex key else inAnnex key
@ -332,11 +332,11 @@ verifyWorkTree key file = do
ifM (annexThin <$> Annex.getGitConfig) ifM (annexThin <$> Annex.getGitConfig)
( void $ linkFromAnnex key tmp mode ( void $ linkFromAnnex key tmp mode
, do , do
obj <- calcRepo $ gitAnnexLocation key obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key)
void $ checkedCopyFile key obj tmp mode void $ checkedCopyFile key obj tmp mode
thawContent tmp thawContent tmp
) )
Database.Keys.storeInodeCaches key [fromRawFilePath file] Database.Keys.storeInodeCaches key [file]
_ -> return () _ -> return ()
return True return True
@ -349,8 +349,8 @@ checkKeySize :: Key -> KeyStatus -> ActionItem -> Annex Bool
checkKeySize _ KeyUnlockedThin _ = return True checkKeySize _ KeyUnlockedThin _ = return True
checkKeySize key _ ai = do checkKeySize key _ ai = do
file <- calcRepo $ gitAnnexLocation key file <- calcRepo $ gitAnnexLocation key
ifM (liftIO $ doesFileExist file) ifM (liftIO $ R.doesPathExist file)
( checkKeySizeOr badContent key file ai ( checkKeySizeOr badContent key (fromRawFilePath file) ai
, return True , return True
) )
@ -417,10 +417,10 @@ checkKeyUpgrade _ _ _ (AssociatedFile Nothing) =
-} -}
checkBackend :: Backend -> Key -> KeyStatus -> AssociatedFile -> Annex Bool checkBackend :: Backend -> Key -> KeyStatus -> AssociatedFile -> Annex Bool
checkBackend backend key keystatus afile = do checkBackend backend key keystatus afile = do
content <- calcRepo $ gitAnnexLocation key content <- calcRepo (gitAnnexLocation key)
ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content)) ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content))
( nocheck ( nocheck
, checkBackendOr badContent backend key content ai , checkBackendOr badContent backend key (fromRawFilePath content) ai
) )
where where
nocheck = return True nocheck = return True
@ -670,8 +670,8 @@ isKeyUnlockedThin KeyMissing = False
getKeyStatus :: Key -> Annex KeyStatus getKeyStatus :: Key -> Annex KeyStatus
getKeyStatus key = catchDefaultIO KeyMissing $ do getKeyStatus key = catchDefaultIO KeyMissing $ do
afs <- not . null <$> Database.Keys.getAssociatedFiles key afs <- not . null <$> Database.Keys.getAssociatedFiles key
obj <- calcRepo $ gitAnnexLocation key obj <- calcRepo (gitAnnexLocation key)
multilink <- ((> 1) . linkCount <$> liftIO (getFileStatus obj)) multilink <- ((> 1) . linkCount <$> liftIO (R.getFileStatus obj))
return $ if multilink && afs return $ if multilink && afs
then KeyUnlockedThin then KeyUnlockedThin
else KeyPresent else KeyPresent

2
Command/Import.hs
View file

@ -181,7 +181,7 @@ startLocal largematcher mode (srcfile, destfile) =
-- weakly the same as the origianlly locked down file's -- weakly the same as the origianlly locked down file's
-- inode cache. (Since the file may have been copied, -- inode cache. (Since the file may have been copied,
-- its inodes may not be the same.) -- its inodes may not be the same.)
newcache <- withTSDelta $ liftIO . genInodeCache destfile newcache <- withTSDelta $ liftIO . genInodeCache (toRawFilePath destfile)
let unchanged = case (newcache, inodeCache (keySource ld)) of let unchanged = case (newcache, inodeCache (keySource ld)) of
(_, Nothing) -> True (_, Nothing) -> True
(Just newc, Just c) | compareWeak c newc -> True (Just newc, Just c) | compareWeak c newc -> True

24
Command/Lock.hs
View file

@ -20,6 +20,7 @@ import qualified Database.Keys
import Annex.Ingest import Annex.Ingest
import Logs.Location import Logs.Location
import Git.FilePath import Git.FilePath
import qualified Utility.RawFilePath as R
cmd :: Command cmd :: Command
cmd = withGlobalOptions [jsonOptions, annexedMatchingOptions] $ cmd = withGlobalOptions [jsonOptions, annexedMatchingOptions] $
@ -43,7 +44,7 @@ startNew file key = ifM (isJust <$> isAnnexLink file)
| key' == key = cont | key' == key = cont
| otherwise = errorModified | otherwise = errorModified
go Nothing = go Nothing =
ifM (isUnmodified key (fromRawFilePath file)) ifM (isUnmodified key file)
( cont ( cont
, ifM (Annex.getState Annex.force) , ifM (Annex.getState Annex.force)
( cont ( cont
@ -56,37 +57,38 @@ performNew :: RawFilePath -> Key -> CommandPerform
performNew file key = do performNew file key = do
lockdown =<< calcRepo (gitAnnexLocation key) lockdown =<< calcRepo (gitAnnexLocation key)
addLink (fromRawFilePath file) key addLink (fromRawFilePath file) key
=<< withTSDelta (liftIO . genInodeCache' file) =<< withTSDelta (liftIO . genInodeCache file)
next $ cleanupNew file key next $ cleanupNew file key
where where
lockdown obj = do lockdown obj = do
ifM (isUnmodified key obj) ifM (isUnmodified key obj)
( breakhardlink obj ( breakhardlink obj
, repopulate obj , repopulate (fromRawFilePath obj)
) )
whenM (liftIO $ doesFileExist obj) $ whenM (liftIO $ R.doesPathExist obj) $
freezeContent obj freezeContent $ fromRawFilePath obj
-- It's ok if the file is hard linked to obj, but if some other -- It's ok if the file is hard linked to obj, but if some other
-- associated file is, we need to break that link to lock down obj. -- associated file is, we need to break that link to lock down obj.
breakhardlink obj = whenM (catchBoolIO $ (> 1) . linkCount <$> liftIO (getFileStatus obj)) $ do breakhardlink obj = whenM (catchBoolIO $ (> 1) . linkCount <$> liftIO (R.getFileStatus obj)) $ do
mfc <- withTSDelta (liftIO . genInodeCache' file) mfc <- withTSDelta (liftIO . genInodeCache file)
unlessM (sameInodeCache obj (maybeToList mfc)) $ do unlessM (sameInodeCache obj (maybeToList mfc)) $ do
modifyContent obj $ replaceFile obj $ \tmp -> do let obj' = fromRawFilePath obj
unlessM (checkedCopyFile key obj tmp Nothing) $ modifyContent obj' $ replaceFile obj' $ \tmp -> do
unlessM (checkedCopyFile key obj' tmp Nothing) $
giveup "unable to lock file" giveup "unable to lock file"
Database.Keys.storeInodeCaches key [obj] Database.Keys.storeInodeCaches key [obj]
-- Try to repopulate obj from an unmodified associated file. -- Try to repopulate obj from an unmodified associated file.
repopulate obj = modifyContent obj $ do repopulate obj = modifyContent obj $ do
g <- Annex.gitRepo g <- Annex.gitRepo
fs <- map fromRawFilePath . map (`fromTopFilePath` g) fs <- map (`fromTopFilePath` g)
<$> Database.Keys.getAssociatedFiles key <$> Database.Keys.getAssociatedFiles key
mfile <- firstM (isUnmodified key) fs mfile <- firstM (isUnmodified key) fs
liftIO $ nukeFile obj liftIO $ nukeFile obj
case mfile of case mfile of
Just unmodified -> Just unmodified ->
unlessM (checkedCopyFile key unmodified obj Nothing) unlessM (checkedCopyFile key (fromRawFilePath unmodified) obj Nothing)
lostcontent lostcontent
Nothing -> lostcontent Nothing -> lostcontent

2
Command/Migrate.hs
View file

@ -86,7 +86,7 @@ perform file oldkey oldbackend newbackend = go =<< genkey (fastMigrate oldbacken
content <- calcRepo $ gitAnnexLocation oldkey content <- calcRepo $ gitAnnexLocation oldkey
let source = KeySource let source = KeySource
{ keyFilename = fromRawFilePath file { keyFilename = fromRawFilePath file
, contentLocation = content , contentLocation = fromRawFilePath content
, inodeCache = Nothing , inodeCache = Nothing
} }
v <- genKey source nullMeterUpdate (Just newbackend) v <- genKey source nullMeterUpdate (Just newbackend)

3
Command/Multicast.hs
View file

@ -137,7 +137,8 @@ send ups fs = do
mk <- lookupFile f mk <- lookupFile f
case mk of case mk of
Nothing -> noop Nothing -> noop
Just k -> withObjectLoc k (addlist f) Just k -> withObjectLoc k $
addlist f . fromRawFilePath
liftIO $ hClose h liftIO $ hClose h
serverkey <- uftpKey serverkey <- uftpKey

6
Command/ReKey.hs
View file

@ -83,12 +83,12 @@ linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file)
- unlocked file, which would leave the new key unlocked - unlocked file, which would leave the new key unlocked
- and vulnerable to corruption. -} - and vulnerable to corruption. -}
( getViaTmpFromDisk RetrievalAllKeysSecure DefaultVerify newkey $ \tmp -> unVerified $ do ( getViaTmpFromDisk RetrievalAllKeysSecure DefaultVerify newkey $ \tmp -> unVerified $ do
oldobj <- calcRepo (gitAnnexLocation oldkey) oldobj <- fromRawFilePath <$> calcRepo (gitAnnexLocation oldkey)
isJust <$> linkOrCopy' (return True) newkey oldobj tmp Nothing isJust <$> linkOrCopy' (return True) newkey oldobj tmp Nothing
, do , do
{- The file being rekeyed is itself an unlocked file; if {- The file being rekeyed is itself an unlocked file; if
- it's hard linked to the old key, that link must be broken. -} - it's hard linked to the old key, that link must be broken. -}
oldobj <- calcRepo (gitAnnexLocation oldkey) oldobj <- fromRawFilePath <$> calcRepo (gitAnnexLocation oldkey)
v <- tryNonAsync $ do v <- tryNonAsync $ do
st <- liftIO $ R.getFileStatus file st <- liftIO $ R.getFileStatus file
when (linkCount st > 1) $ do when (linkCount st > 1) $ do
@ -97,7 +97,7 @@ linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file)
unlessM (checkedCopyFile oldkey oldobj tmp Nothing) $ unlessM (checkedCopyFile oldkey oldobj tmp Nothing) $
error "can't lock old key" error "can't lock old key"
thawContent tmp thawContent tmp
ic <- withTSDelta (liftIO . genInodeCache' file) ic <- withTSDelta (liftIO . genInodeCache file)
case v of case v of
Left e -> do Left e -> do
warning (show e) warning (show e)

8
Command/Smudge.hs
View file

@ -108,7 +108,7 @@ clean file = do
-- annexed and is unmodified. -- annexed and is unmodified.
case oldkey of case oldkey of
Nothing -> doingest oldkey Nothing -> doingest oldkey
Just ko -> ifM (isUnmodifiedCheap ko file) Just ko -> ifM (isUnmodifiedCheap ko (toRawFilePath file))
( liftIO $ emitPointer ko ( liftIO $ emitPointer ko
, doingest oldkey , doingest oldkey
) )
@ -174,7 +174,7 @@ shouldAnnex file moldkey = ifM (annexGitAddToAnnex <$> Annex.getGitConfig)
Just _ -> return True Just _ -> return True
Nothing -> checkknowninode Nothing -> checkknowninode
checkknowninode = withTSDelta (liftIO . genInodeCache file) >>= \case checkknowninode = withTSDelta (liftIO . genInodeCache (toRawFilePath file)) >>= \case
Nothing -> pure False Nothing -> pure False
Just ic -> Database.Keys.isInodeKnown ic =<< sentinalStatus Just ic -> Database.Keys.isInodeKnown ic =<< sentinalStatus
@ -191,7 +191,7 @@ emitPointer = S.putStr . formatPointer
getMoveRaceRecovery :: Key -> RawFilePath -> Annex () getMoveRaceRecovery :: Key -> RawFilePath -> Annex ()
getMoveRaceRecovery k file = void $ tryNonAsync $ getMoveRaceRecovery k file = void $ tryNonAsync $
whenM (inAnnex k) $ do whenM (inAnnex k) $ do
obj <- toRawFilePath <$> calcRepo (gitAnnexLocation k) obj <- calcRepo (gitAnnexLocation k)
-- Cannot restage because git add is running and has -- Cannot restage because git add is running and has
-- the index locked. -- the index locked.
populatePointerFile (Restage False) k obj file >>= \case populatePointerFile (Restage False) k obj file >>= \case
@ -207,7 +207,7 @@ updateSmudged :: Restage -> Annex ()
updateSmudged restage = streamSmudged $ \k topf -> do updateSmudged restage = streamSmudged $ \k topf -> do
f <- fromRepo (fromTopFilePath topf) f <- fromRepo (fromTopFilePath topf)
whenM (inAnnex k) $ do whenM (inAnnex k) $ do
obj <- toRawFilePath <$> calcRepo (gitAnnexLocation k) obj <- calcRepo (gitAnnexLocation k)
unlessM (isJust <$> populatePointerFile restage k obj f) $ unlessM (isJust <$> populatePointerFile restage k obj f) $
liftIO (isPointerFile f) >>= \case liftIO (isPointerFile f) >>= \case
Just k' | k' == k -> toplevelWarning False $ Just k' | k' == k -> toplevelWarning False $

6
Command/TestRemote.hs
View file

@ -168,7 +168,7 @@ test st r k = catMaybes
get get
, Just $ check "fsck downloaded object" fsck , Just $ check "fsck downloaded object" fsck
, Just $ check "retrieveKeyFile resume from 33%" $ do , Just $ check "retrieveKeyFile resume from 33%" $ do
loc <- Annex.calcRepo (gitAnnexLocation k) loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k)
tmp <- prepTmp k tmp <- prepTmp k
partial <- liftIO $ bracket (openBinaryFile loc ReadMode) hClose $ \h -> do partial <- liftIO $ bracket (openBinaryFile loc ReadMode) hClose $ \h -> do
sz <- hFileSize h sz <- hFileSize h
@ -184,7 +184,7 @@ test st r k = catMaybes
get get
, Just $ check "fsck downloaded object" fsck , Just $ check "fsck downloaded object" fsck
, Just $ check "retrieveKeyFile resume from end" $ do , Just $ check "retrieveKeyFile resume from end" $ do
loc <- Annex.calcRepo (gitAnnexLocation k) loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k)
tmp <- prepTmp k tmp <- prepTmp k
void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp
lockContentForRemoval k removeAnnex lockContentForRemoval k removeAnnex
@ -240,7 +240,7 @@ testExportTree st (Just _) ea k1 k2 =
check desc a = testCase desc $ check desc a = testCase desc $
Annex.eval st (Annex.setOutput QuietOutput >> a) @? "failed" Annex.eval st (Annex.setOutput QuietOutput >> a) @? "failed"
storeexport k = do storeexport k = do
loc <- Annex.calcRepo (gitAnnexLocation k) loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k)
Remote.storeExport ea loc k testexportlocation nullMeterUpdate Remote.storeExport ea loc k testexportlocation nullMeterUpdate
retrieveexport k = withTmpFile "exported" $ \tmp h -> do retrieveexport k = withTmpFile "exported" $ \tmp h -> do
liftIO $ hClose h liftIO $ hClose h

2
Command/Unannex.hs
View file

@ -46,7 +46,7 @@ perform file key = do
cleanup :: RawFilePath -> Key -> CommandCleanup cleanup :: RawFilePath -> Key -> CommandCleanup
cleanup file key = do cleanup file key = do
Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath file) Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath file)
src <- calcRepo $ gitAnnexLocation key src <- fromRawFilePath <$> calcRepo (gitAnnexLocation key)
ifM (Annex.getState Annex.fast) ifM (Annex.getState Annex.fast)
( do ( do
-- Only make a hard link if the annexed file does not -- Only make a hard link if the annexed file does not

3
Command/Uninit.hs
View file

@ -17,6 +17,7 @@ import qualified Database.Keys
import Annex.Content import Annex.Content
import Annex.Init import Annex.Init
import Utility.FileMode import Utility.FileMode
import qualified Utility.RawFilePath as R
cmd :: Command cmd :: Command
cmd = addCheck check $ cmd = addCheck check $
@ -117,5 +118,5 @@ removeUnannexed = go []
, go (k:c) ks , go (k:c) ks
) )
enoughlinks f = catchBoolIO $ do enoughlinks f = catchBoolIO $ do
s <- getFileStatus f s <- R.getFileStatus f
return $ linkCount s > 1 return $ linkCount s > 1

2
Command/Unused.hs
View file

@ -283,7 +283,7 @@ associatedFilesFilter = filterM go
checkunmodified _ [] = return True checkunmodified _ [] = return True
checkunmodified cs (f:fs) = do checkunmodified cs (f:fs) = do
relf <- fromRepo $ fromTopFilePath f relf <- fromRepo $ fromTopFilePath f
ifM (sameInodeCache (fromRawFilePath relf) cs) ifM (sameInodeCache relf cs)
( return False ( return False
, checkunmodified cs fs , checkunmodified cs fs
) )

12
Database/Keys.hs
View file

@ -169,13 +169,13 @@ removeAssociatedFile :: Key -> TopFilePath -> Annex ()
removeAssociatedFile k = runWriterIO . SQL.removeAssociatedFile (toIKey k) removeAssociatedFile k = runWriterIO . SQL.removeAssociatedFile (toIKey k)
{- Stats the files, and stores their InodeCaches. -} {- Stats the files, and stores their InodeCaches. -}
storeInodeCaches :: Key -> [FilePath] -> Annex () storeInodeCaches :: Key -> [RawFilePath] -> Annex ()
storeInodeCaches k fs = storeInodeCaches' k fs [] storeInodeCaches k fs = storeInodeCaches' k fs []
storeInodeCaches' :: Key -> [FilePath] -> [InodeCache] -> Annex () storeInodeCaches' :: Key -> [RawFilePath] -> [InodeCache] -> Annex ()
storeInodeCaches' k fs ics = withTSDelta $ \d -> storeInodeCaches' k fs ics = withTSDelta $ \d ->
addInodeCaches k . (++ ics) . catMaybes addInodeCaches k . (++ ics) . catMaybes
=<< liftIO (mapM (`genInodeCache` d) fs) =<< liftIO (mapM (\f -> genInodeCache f d) fs)
addInodeCaches :: Key -> [InodeCache] -> Annex () addInodeCaches :: Key -> [InodeCache] -> Annex ()
addInodeCaches k is = runWriterIO $ SQL.addInodeCaches (toIKey k) is addInodeCaches k is = runWriterIO $ SQL.addInodeCaches (toIKey k) is
@ -223,7 +223,7 @@ reconcileStaged :: H.DbQueue -> Annex ()
reconcileStaged qh = do reconcileStaged qh = do
gitindex <- inRepo currentIndexFile gitindex <- inRepo currentIndexFile
indexcache <- fromRepo gitAnnexKeysDbIndexCache indexcache <- fromRepo gitAnnexKeysDbIndexCache
withTSDelta (liftIO . genInodeCache gitindex) >>= \case withTSDelta (liftIO . genInodeCache (toRawFilePath gitindex)) >>= \case
Just cur -> Just cur ->
liftIO (maybe Nothing readInodeCache <$> catchMaybeIO (readFile indexcache)) >>= \case liftIO (maybe Nothing readInodeCache <$> catchMaybeIO (readFile indexcache)) >>= \case
Nothing -> go cur indexcache Nothing -> go cur indexcache
@ -295,10 +295,10 @@ reconcileStaged qh = do
keyloc <- calcRepo (gitAnnexLocation key) keyloc <- calcRepo (gitAnnexLocation key)
keypopulated <- sameInodeCache keyloc caches keypopulated <- sameInodeCache keyloc caches
p <- fromRepo $ fromTopFilePath file p <- fromRepo $ fromTopFilePath file
filepopulated <- sameInodeCache (fromRawFilePath p) caches filepopulated <- sameInodeCache p caches
case (keypopulated, filepopulated) of case (keypopulated, filepopulated) of
(True, False) -> (True, False) ->
populatePointerFile (Restage True) key (toRawFilePath keyloc) p >>= \case populatePointerFile (Restage True) key 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)

6
Limit.hs
View file

@ -33,6 +33,7 @@ import Git.Types (RefDate(..))
import Utility.Glob import Utility.Glob
import Utility.HumanTime import Utility.HumanTime
import Utility.DataUnits import Utility.DataUnits
import qualified Utility.RawFilePath as R
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
import qualified Data.Set as S import qualified Data.Set as S
@ -117,7 +118,8 @@ addMagicLimit limitname querymagic selectprovidedinfo glob = do
-- 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 (toRawFilePath f) >>= \case Nothing -> isAnnexLink (toRawFilePath f) >>= \case
Just k -> withObjectLoc k $ querymagic magic Just k -> withObjectLoc k $
querymagic magic . fromRawFilePath
Nothing -> querymagic magic f Nothing -> querymagic magic f
matchMagic :: String -> (Magic -> FilePath -> Annex (Maybe String)) -> (ProvidedInfo -> OptInfo String) -> Maybe Magic -> MkLimit Annex matchMagic :: String -> (Magic -> FilePath -> Annex (Maybe String)) -> (ProvidedInfo -> OptInfo String) -> Maybe Magic -> MkLimit Annex
@ -363,7 +365,7 @@ addAccessedWithin duration = do
where where
check now k = inAnnexCheck k $ \f -> check now k = inAnnexCheck k $ \f ->
liftIO $ catchDefaultIO False $ do liftIO $ catchDefaultIO False $ do
s <- getFileStatus f s <- R.getFileStatus f
let accessed = realToFrac (accessTime s) let accessed = realToFrac (accessTime s)
let delta = now - accessed let delta = now - accessed
return $ delta <= secs return $ delta <= secs

25
Logs.hs
View file

@ -13,6 +13,7 @@ import Annex.Common
import Annex.DirHashes import Annex.DirHashes
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified System.FilePath.ByteString as P
{- There are several varieties of log file formats. -} {- There are several varieties of log file formats. -}
data LogVariety data LogVariety
@ -117,19 +118,19 @@ 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 -> RawFilePath locationLogFile :: GitConfig -> Key -> RawFilePath
locationLogFile config key = toRawFilePath $ locationLogFile config key =
branchHashDir config key </> keyFile key ++ ".log" branchHashDir config key P.</> 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 -> RawFilePath urlLogFile :: GitConfig -> Key -> RawFilePath
urlLogFile config key = toRawFilePath $ urlLogFile config key =
branchHashDir config key </> keyFile key ++ decodeBS' urlLogExt branchHashDir config key P.</> keyFile' key <> urlLogExt
{- Old versions stored the urls elsewhere. -} {- Old versions stored the urls elsewhere. -}
oldurlLogs :: GitConfig -> Key -> [RawFilePath] oldurlLogs :: GitConfig -> Key -> [RawFilePath]
oldurlLogs config key = map toRawFilePath oldurlLogs config key =
[ "remote/web" </> hdir </> serializeKey key ++ ".log" [ "remote/web" P.</> hdir P.</> serializeKey' key <> ".log"
, "remote/web" </> hdir </> keyFile key ++ ".log" , "remote/web" P.</> hdir P.</> keyFile' key <> ".log"
] ]
where where
hdir = branchHashDir config key hdir = branchHashDir config key
@ -144,7 +145,7 @@ 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 -> RawFilePath remoteStateLogFile :: GitConfig -> Key -> RawFilePath
remoteStateLogFile config key = remoteStateLogFile config key =
toRawFilePath (branchHashDir config key </> keyFile key) (branchHashDir config key P.</> keyFile' key)
<> remoteStateLogExt <> remoteStateLogExt
remoteStateLogExt :: S.ByteString remoteStateLogExt :: S.ByteString
@ -156,7 +157,7 @@ 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 -> RawFilePath chunkLogFile :: GitConfig -> Key -> RawFilePath
chunkLogFile config key = chunkLogFile config key =
toRawFilePath (branchHashDir config key </> keyFile key) (branchHashDir config key P.</> keyFile' key)
<> chunkLogExt <> chunkLogExt
chunkLogExt :: S.ByteString chunkLogExt :: S.ByteString
@ -168,7 +169,7 @@ 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 -> RawFilePath metaDataLogFile :: GitConfig -> Key -> RawFilePath
metaDataLogFile config key = metaDataLogFile config key =
toRawFilePath (branchHashDir config key </> keyFile key) (branchHashDir config key P.</> keyFile' key)
<> metaDataLogExt <> metaDataLogExt
metaDataLogExt :: S.ByteString metaDataLogExt :: S.ByteString
@ -180,7 +181,7 @@ 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 -> RawFilePath remoteMetaDataLogFile :: GitConfig -> Key -> RawFilePath
remoteMetaDataLogFile config key = remoteMetaDataLogFile config key =
toRawFilePath (branchHashDir config key </> keyFile key) (branchHashDir config key P.</> keyFile' key)
<> remoteMetaDataLogExt <> remoteMetaDataLogExt
remoteMetaDataLogExt :: S.ByteString remoteMetaDataLogExt :: S.ByteString
@ -192,7 +193,7 @@ 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 -> RawFilePath remoteContentIdentifierLogFile :: GitConfig -> Key -> RawFilePath
remoteContentIdentifierLogFile config key = remoteContentIdentifierLogFile config key =
toRawFilePath (branchHashDir config key </> keyFile key) (branchHashDir config key P.</> keyFile' key)
<> remoteContentIdentifierExt <> remoteContentIdentifierExt
remoteContentIdentifierExt :: S.ByteString remoteContentIdentifierExt :: S.ByteString

2
P2P/Annex.hs
View file

@ -47,7 +47,7 @@ runLocal runst runner a = case a of
size <- liftIO $ catchDefaultIO 0 $ getFileSize f size <- liftIO $ catchDefaultIO 0 $ getFileSize f
runner (next (Len size)) runner (next (Len size))
ContentSize k next -> do ContentSize k next -> do
let getsize = liftIO . catchMaybeIO . getFileSize let getsize = liftIO . catchMaybeIO . getFileSize . fromRawFilePath
size <- inAnnex' isJust Nothing getsize k size <- inAnnex' isJust Nothing getsize k
runner (next (Len <$> size)) runner (next (Len <$> size))
ReadContent k af o sender next -> do ReadContent k af o sender next -> do

2
Remote/Adb.hs
View file

@ -212,7 +212,7 @@ androidHashDir :: AndroidPath -> Key -> AndroidPath
androidHashDir adir k = AndroidPath $ androidHashDir adir k = AndroidPath $
fromAndroidPath adir ++ "/" ++ hdir fromAndroidPath adir ++ "/" ++ hdir
where where
hdir = replace [pathSeparator] "/" (hashDirLower def k) hdir = replace [pathSeparator] "/" (fromRawFilePath (hashDirLower def k))
storeExportM :: AndroidSerial -> AndroidPath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool storeExportM :: AndroidSerial -> AndroidPath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
storeExportM serial adir src _k loc _p = store' serial dest src storeExportM serial adir src _k loc _p = store' serial dest src

5
Remote/Directory.hs
View file

@ -127,7 +127,7 @@ directorySetup _ mu _ c gc = do
- We try more than one since we used to write to different hash - We try more than one since we used to write to different hash
- directories. -} - directories. -}
locations :: FilePath -> Key -> [FilePath] locations :: FilePath -> Key -> [FilePath]
locations d k = map (d </>) (keyPaths k) locations d k = map (\f -> d </> fromRawFilePath f) (keyPaths k)
{- Returns the location off a Key in the directory. If the key is {- Returns the location off a Key in the directory. If the key is
- present, returns the location that is actually used, otherwise - present, returns the location that is actually used, otherwise
@ -139,7 +139,8 @@ getLocation d k = do
{- Directory where the file(s) for a key are stored. -} {- Directory where the file(s) for a key are stored. -}
storeDir :: FilePath -> Key -> FilePath storeDir :: FilePath -> Key -> FilePath
storeDir d k = addTrailingPathSeparator $ d </> hashDirLower def k </> keyFile k storeDir d k = addTrailingPathSeparator $
d </> fromRawFilePath (hashDirLower def k) </> keyFile k
{- Check if there is enough free disk space in the remote's directory to {- Check if there is enough free disk space in the remote's directory to
- store the key. Note that the unencrypted key size is checked. -} - store the key. Note that the unencrypted key size is checked. -}

4
Remote/External.hs
View file

@ -383,9 +383,9 @@ handleRequest' st external req mp responsehandler
handleRemoteRequest (PROGRESS bytesprocessed) = handleRemoteRequest (PROGRESS bytesprocessed) =
maybe noop (\a -> liftIO $ a bytesprocessed) mp maybe noop (\a -> liftIO $ a bytesprocessed) mp
handleRemoteRequest (DIRHASH k) = handleRemoteRequest (DIRHASH k) =
send $ VALUE $ hashDirMixed def k send $ VALUE $ fromRawFilePath $ hashDirMixed def k
handleRemoteRequest (DIRHASH_LOWER k) = handleRemoteRequest (DIRHASH_LOWER k) =
send $ VALUE $ hashDirLower def k send $ VALUE $ fromRawFilePath $ hashDirLower def k
handleRemoteRequest (SETCONFIG setting value) = handleRemoteRequest (SETCONFIG setting value) =
liftIO $ atomically $ modifyTVar' (externalConfig st) $ liftIO $ atomically $ modifyTVar' (externalConfig st) $
M.insert setting value M.insert setting value

3
Remote/GCrypt.hs
View file

@ -422,7 +422,8 @@ checkKey' repo r rsyncopts k
{- Annexed objects are hashed using lower-case directories for max {- Annexed objects are hashed using lower-case directories for max
- portability. -} - portability. -}
gCryptLocation :: Git.Repo -> Key -> FilePath gCryptLocation :: Git.Repo -> Key -> FilePath
gCryptLocation repo key = Git.repoLocation repo </> objectDir </> keyPath key (hashDirLower def) gCryptLocation repo key = Git.repoLocation repo </> objectDir
</> fromRawFilePath (keyPath key (hashDirLower def))
data AccessMethod = AccessDirect | AccessShell data AccessMethod = AccessDirect | AccessShell

9
Remote/Git.hs
View file

@ -61,6 +61,7 @@ import Creds
import Types.NumCopies import Types.NumCopies
import Annex.Action import Annex.Action
import Messages.Progress import Messages.Progress
import qualified Utility.RawFilePath as R
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
import Utility.FileMode import Utility.FileMode
@ -393,9 +394,9 @@ keyUrls gc repo r key = map tourl locs'
| remoteAnnexBare remoteconfig == Just False = reverse (annexLocations gc key) | remoteAnnexBare remoteconfig == Just False = reverse (annexLocations gc key)
| otherwise = annexLocations gc key | otherwise = annexLocations gc key
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
locs' = locs locs' = map fromRawFilePath locs
#else #else
locs' = map (replace "\\" "/") locs locs' = map (replace "\\" "/" . fromRawFilePath) locs
#endif #endif
remoteconfig = gitconfig r remoteconfig = gitconfig r
@ -599,9 +600,9 @@ copyFromRemoteCheap' repo r st key af file
| not $ Git.repoIsUrl repo = guardUsable repo (return False) $ do | not $ Git.repoIsUrl repo = guardUsable repo (return False) $ do
gc <- getGitConfigFromState st gc <- getGitConfigFromState st
loc <- liftIO $ gitAnnexLocation key repo gc loc <- liftIO $ gitAnnexLocation key repo gc
liftIO $ ifM (doesFileExist loc) liftIO $ ifM (R.doesPathExist loc)
( do ( do
absloc <- absPath loc absloc <- absPath (fromRawFilePath loc)
catchBoolIO $ do catchBoolIO $ do
createSymbolicLink absloc file createSymbolicLink absloc file
return True return True

3
Remote/Hook.hs
View file

@ -104,7 +104,8 @@ hookEnv action k f = Just <$> mergeenv (fileenv f ++ keyenv)
] ]
fileenv Nothing = [] fileenv Nothing = []
fileenv (Just file) = [envvar "FILE" file] fileenv (Just file) = [envvar "FILE" file]
hashbits = map takeDirectory $ splitPath $ hashDirMixed def k hashbits = map takeDirectory $ splitPath $
fromRawFilePath $ hashDirMixed def k
lookupHook :: HookName -> Action -> Annex (Maybe String) lookupHook :: HookName -> Action -> Annex (Maybe String)
lookupHook hookname action = do lookupHook hookname action = do

4
Remote/Rsync.hs
View file

@ -183,7 +183,7 @@ rsyncSetup _ mu _ c gc = do
store :: RsyncOpts -> Key -> FilePath -> MeterUpdate -> Annex Bool store :: RsyncOpts -> Key -> FilePath -> MeterUpdate -> Annex Bool
store o k src meterupdate = storeGeneric o meterupdate basedest populatedest store o k src meterupdate = storeGeneric o meterupdate basedest populatedest
where where
basedest = Prelude.head (keyPaths k) basedest = fromRawFilePath $ Prelude.head (keyPaths k)
populatedest dest = liftIO $ if canrename populatedest dest = liftIO $ if canrename
then do then do
rename src dest rename src dest
@ -222,7 +222,7 @@ remove :: RsyncOpts -> Remover
remove o k = removeGeneric o includes remove o k = removeGeneric o includes
where where
includes = concatMap use dirHashes includes = concatMap use dirHashes
use h = let dir = h def k in use h = let dir = fromRawFilePath (h def k) in
[ parentDir dir [ parentDir dir
, dir , dir
-- match content directory and anything in it -- match content directory and anything in it

11
Remote/Rsync/RsyncUrl.hs
View file

@ -13,13 +13,14 @@ import Types
import Annex.Locations import Annex.Locations
import Utility.Rsync import Utility.Rsync
import Utility.SafeCommand import Utility.SafeCommand
import Utility.FileSystemEncoding
import Data.Default import Annex.DirHashes
import System.FilePath.Posix
#ifdef mingw32_HOST_OS #ifdef mingw32_HOST_OS
import Utility.Split import Utility.Split
#endif #endif
import Annex.DirHashes
import Data.Default
import System.FilePath.Posix
type RsyncUrl = String type RsyncUrl = String
@ -42,7 +43,7 @@ mkRsyncUrl o f = rsyncUrl o </> rsyncEscape o f
rsyncUrls :: RsyncOpts -> Key -> [RsyncUrl] rsyncUrls :: RsyncOpts -> Key -> [RsyncUrl]
rsyncUrls o k = map use dirHashes rsyncUrls o k = map use dirHashes
where where
use h = rsyncUrl o </> hash h </> rsyncEscape o (f </> f) use h = rsyncUrl o </> fromRawFilePath (hash h) </> rsyncEscape o (f </> f)
f = keyFile k f = keyFile k
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
hash h = h def k hash h = h def k

4
Remote/WebDAV/DavLocation.hs
View file

@ -39,9 +39,9 @@ keyDir :: Key -> DavLocation
keyDir k = addTrailingPathSeparator $ hashdir </> keyFile k keyDir k = addTrailingPathSeparator $ hashdir </> keyFile k
where where
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
hashdir = hashDirLower def k hashdir = fromRawFilePath $ hashDirLower def k
#else #else
hashdir = replace "\\" "/" (hashDirLower def k) hashdir = replace "\\" "/" (fromRawFilePath $ hashDirLower def k)
#endif #endif
keyLocation :: Key -> DavLocation keyLocation :: Key -> DavLocation

3
Test.hs
View file

@ -1638,7 +1638,8 @@ test_crypto = do
checkFile mvariant filename = checkFile mvariant filename =
Utility.Gpg.checkEncryptionFile gpgcmd filename $ Utility.Gpg.checkEncryptionFile gpgcmd filename $
if mvariant == Just Types.Crypto.PubKey then ks else Nothing if mvariant == Just Types.Crypto.PubKey then ks else Nothing
serializeKeys cipher = Annex.Locations.keyPaths . serializeKeys cipher = map fromRawFilePath .
Annex.Locations.keyPaths .
Crypto.encryptKey Types.Crypto.HmacSha1 cipher Crypto.encryptKey Types.Crypto.HmacSha1 cipher
#else #else
test_crypto = putStrLn "gpg testing not implemented on Windows" test_crypto = putStrLn "gpg testing not implemented on Windows"

4
Upgrade/V1.hs
View file

@ -236,9 +236,9 @@ logFile1 repo key = Upgrade.V2.gitStateDir repo ++ keyFile1 key ++ ".log"
logFile2 :: Key -> Git.Repo -> String logFile2 :: Key -> Git.Repo -> String
logFile2 = logFile' (hashDirLower def) logFile2 = logFile' (hashDirLower def)
logFile' :: (Key -> FilePath) -> Key -> Git.Repo -> String logFile' :: (Key -> RawFilePath) -> Key -> Git.Repo -> String
logFile' hasher key repo = logFile' hasher key repo =
gitStateDir repo ++ hasher key ++ keyFile key ++ ".log" gitStateDir repo ++ fromRawFilePath (hasher key) ++ keyFile key ++ ".log"
stateDir :: FilePath stateDir :: FilePath
stateDir = addTrailingPathSeparator ".git-annex" stateDir = addTrailingPathSeparator ".git-annex"

2
Upgrade/V5.hs
View file

@ -135,7 +135,7 @@ upgradeDirectWorkTree = do
-- is just not populated with it. Since the work tree -- is just not populated with it. Since the work tree
-- file is recorded as an associated file, things will -- file is recorded as an associated file, things will
-- still work that way, it's just not ideal. -- still work that way, it's just not ideal.
ic <- withTSDelta (liftIO . genInodeCache f) ic <- withTSDelta (liftIO . genInodeCache (toRawFilePath f))
void $ Content.linkToAnnex k f ic void $ Content.linkToAnnex k f ic
, unlessM (Content.inAnnex k) $ do , unlessM (Content.inAnnex k) $ do
-- Worktree file was deleted or modified; -- Worktree file was deleted or modified;

4
Upgrade/V5/Direct.hs
View file

@ -107,7 +107,9 @@ removeAssociatedFiles key = do
- expected mtime and inode. - expected mtime and inode.
-} -}
goodContent :: Key -> FilePath -> Annex Bool goodContent :: Key -> FilePath -> Annex Bool
goodContent key file = sameInodeCache file =<< recordedInodeCache key goodContent key file =
sameInodeCache (toRawFilePath file)
=<< recordedInodeCache key
{- Gets the recorded inode cache for a key. {- Gets the recorded inode cache for a key.
- -

19
Utility/InodeCache.hs
View file

@ -22,7 +22,6 @@ module Utility.InodeCache (
readInodeCache, readInodeCache,
showInodeCache, showInodeCache,
genInodeCache, genInodeCache,
genInodeCache',
toInodeCache, toInodeCache,
likeInodeCacheWeak, likeInodeCacheWeak,
@ -182,12 +181,8 @@ readInodeCache s = case words s of
return $ InodeCache $ InodeCachePrim i sz (MTimeHighRes t) return $ InodeCache $ InodeCachePrim i sz (MTimeHighRes t)
_ -> Nothing _ -> Nothing
genInodeCache :: FilePath -> TSDelta -> IO (Maybe InodeCache) genInodeCache :: RawFilePath -> TSDelta -> IO (Maybe InodeCache)
genInodeCache f delta = catchDefaultIO Nothing $ genInodeCache f delta = catchDefaultIO Nothing $
toInodeCache delta f =<< getFileStatus f
genInodeCache' :: RawFilePath -> TSDelta -> IO (Maybe InodeCache)
genInodeCache' f delta = catchDefaultIO Nothing $
toInodeCache delta (fromRawFilePath f) =<< R.getFileStatus f toInodeCache delta (fromRawFilePath f) =<< R.getFileStatus f
toInodeCache :: TSDelta -> FilePath -> FileStatus -> IO (Maybe InodeCache) toInodeCache :: TSDelta -> FilePath -> FileStatus -> IO (Maybe InodeCache)
@ -208,8 +203,8 @@ toInodeCache (TSDelta getdelta) f s
- Its InodeCache at the time of its creation is written to the cache file, - Its InodeCache at the time of its creation is written to the cache file,
- so changes can later be detected. -} - so changes can later be detected. -}
data SentinalFile = SentinalFile data SentinalFile = SentinalFile
{ sentinalFile :: FilePath { sentinalFile :: RawFilePath
, sentinalCacheFile :: FilePath , sentinalCacheFile :: RawFilePath
} }
deriving (Show) deriving (Show)
@ -226,8 +221,8 @@ noTSDelta = TSDelta (pure 0)
writeSentinalFile :: SentinalFile -> IO () writeSentinalFile :: SentinalFile -> IO ()
writeSentinalFile s = do writeSentinalFile s = do
writeFile (sentinalFile s) "" writeFile (fromRawFilePath (sentinalFile s)) ""
maybe noop (writeFile (sentinalCacheFile s) . showInodeCache) maybe noop (writeFile (fromRawFilePath (sentinalCacheFile s)) . showInodeCache)
=<< genInodeCache (sentinalFile s) noTSDelta =<< genInodeCache (sentinalFile s) noTSDelta
data SentinalStatus = SentinalStatus data SentinalStatus = SentinalStatus
@ -256,7 +251,7 @@ checkSentinalFile s = do
Just new -> return $ calc old new Just new -> return $ calc old new
where where
loadoldcache = catchDefaultIO Nothing $ loadoldcache = catchDefaultIO Nothing $
readInodeCache <$> readFile (sentinalCacheFile s) readInodeCache <$> readFile (fromRawFilePath (sentinalCacheFile s))
gennewcache = genInodeCache (sentinalFile s) noTSDelta gennewcache = genInodeCache (sentinalFile s) noTSDelta
calc (InodeCache (InodeCachePrim oldinode oldsize oldmtime)) (InodeCache (InodeCachePrim newinode newsize newmtime)) = calc (InodeCache (InodeCachePrim oldinode oldsize oldmtime)) (InodeCache (InodeCachePrim newinode newsize newmtime)) =
SentinalStatus (not unchanged) tsdelta SentinalStatus (not unchanged) tsdelta
@ -281,7 +276,7 @@ checkSentinalFile s = do
dummy = SentinalStatus True noTSDelta dummy = SentinalStatus True noTSDelta
sentinalFileExists :: SentinalFile -> IO Bool sentinalFileExists :: SentinalFile -> IO Bool
sentinalFileExists s = allM doesFileExist [sentinalCacheFile s, sentinalFile s] sentinalFileExists s = allM R.doesPathExist [sentinalCacheFile s, sentinalFile s]
instance Arbitrary InodeCache where instance Arbitrary InodeCache where
arbitrary = arbitrary =

5
Utility/MD5.hs
View file

@ -8,13 +8,14 @@ module Utility.MD5 where
import Data.Bits import Data.Bits
import Data.Word import Data.Word
import Data.Char
display_32bits_as_dir :: Word32 -> String display_32bits_as_dir :: Word32 -> [Word8]
display_32bits_as_dir w = trim $ swap_pairs cs display_32bits_as_dir w = trim $ swap_pairs cs
where where
-- Need 32 characters to use. To avoid inaverdently making -- Need 32 characters to use. To avoid inaverdently making
-- a real word, use letters that appear less frequently. -- a real word, use letters that appear less frequently.
chars = ['0'..'9'] ++ "zqjxkmvwgpfZQJXKMVWGPF" chars = map (fromIntegral . ord) (['0'..'9'] ++ "zqjxkmvwgpfZQJXKMVWGPF")
cs = map (\x -> getc $ (shiftR w (6*x)) .&. 31) [0..7] cs = map (\x -> getc $ (shiftR w (6*x)) .&. 31) [0..7]
getc n = chars !! fromIntegral n getc n = chars !! fromIntegral n
swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs

9
Utility/RawFilePath.hs
View file

@ -19,14 +19,20 @@ module Utility.RawFilePath (
readSymbolicLink, readSymbolicLink,
getFileStatus, getFileStatus,
getSymbolicLinkStatus, getSymbolicLinkStatus,
doesPathExist,
) where ) where
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
import Utility.FileSystemEncoding (RawFilePath) import Utility.FileSystemEncoding (RawFilePath)
import System.Posix.Files.ByteString import System.Posix.Files.ByteString
doesPathExist :: RawFilePath -> IO Bool
doesPathExist = fileExist
#else #else
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified System.PosixCompat as P import qualified System.PosixCompat as P
import qualified System.Directory as D
import Utility.FileSystemEncoding import Utility.FileSystemEncoding
readSymbolicLink :: RawFilePath -> IO RawFilePath readSymbolicLink :: RawFilePath -> IO RawFilePath
@ -37,4 +43,7 @@ getFileStatus = P.getFileStatus . fromRawFilePath
getSymbolicLinkStatus :: RawFilePath -> IO FileStatus getSymbolicLinkStatus :: RawFilePath -> IO FileStatus
getSymbolicLinkStatus = P.getSymbolicLinkStatus . fromRawFilePath getSymbolicLinkStatus = P.getSymbolicLinkStatus . fromRawFilePath
doesPathExist :: RawFilePath -> IO Bool
doesPathExist = D.doesPathExist . fromRawFilePath
#endif #endif

20
doc/todo/optimize_by_converting_String_to_ByteString.mdwn
View file

@ -11,26 +11,12 @@ than find so the improvement is not as large.
The `bs` branch is in a mergeable state now, but still needs work: The `bs` branch is in a mergeable state now, but still needs work:
* Profile various commands and look for hot spots.
* Eliminate all the fromRawFilePath, toRawFilePath, encodeBS, * Eliminate all the fromRawFilePath, toRawFilePath, encodeBS,
decodeBS conversions. Or at least most of them. There are likely decodeBS conversions. Or at least most of them. There are likely
quite a few places where a value is converted back and forth several times. some places where a value is converted back and forth several times.
As a first step, profile and look for the hot spots. Known hot spots:
* keyFile uses fromRawFilePath and that adds around 3% overhead in `git-annex find`.
Converting it to a RawFilePath needs a version of `</>` for RawFilePaths.
* getJournalFileStale uses fromRawFilePath, and adds 3-5% overhead in
`git-annex whereis`. Converting it to RawFilePath needs a version
of `</>` for RawFilePaths. It also needs a ByteString.readFile
for RawFilePath.
* System.FilePath is not available for RawFilePath, and many of the
conversions are to get a FilePath in order to use that library.
It should be entirely straightforward to make a version of System.FilePath
that can operate on RawFilePath, except possibly there could be some
complications due to Windows.
* Use versions of IO actions like getFileStatus that take a RawFilePath, * Use versions of IO actions like getFileStatus that take a RawFilePath,
avoiding a conversion. Note that these are only available on unix, not avoiding a conversion. Note that these are only available on unix, not
windows, so a compatability shim will be needed. windows, so a compatability shim will be needed.

40
doc/todo/optimize_by_converting_String_to_ByteString/comment_3_5cad0557a1409703f8c71078f0785309._comment Normal file
View file

@ -0,0 +1,40 @@
[[!comment format=mdwn
username="joey"
subject="""comment 3"""
date="2019-12-11T18:16:13Z"
content="""
Updated profiling. git-annex find is now ByteString end-to-end!
Note the massive reduction in alloc, and improved runtime.
Wed Dec 11 14:41 2019 Time and Allocation Profiling Report (Final)
git-annex +RTS -p -RTS find
total time = 1.51 secs (1515 ticks @ 1000 us, 1 processor)
total alloc = 608,475,328 bytes (excludes profiling overheads)
COST CENTRE MODULE SRC %time %alloc
keyFile' Annex.Locations Annex/Locations.hs:(590,1)-(600,30) 8.2 16.6
>>=.\.succ' Data.Attoparsec.Internal.Types Data/Attoparsec/Internal/Types.hs:146:13-76 4.7 0.7
getAnnexLinkTarget'.probesymlink Annex.Link Annex/Link.hs:79:9-46 4.2 7.6
>>=.\ Data.Attoparsec.Internal.Types Data/Attoparsec/Internal/Types.hs:(146,9)-(147,44) 3.9 2.3
parseLinkTarget Annex.Link Annex/Link.hs:(255,1)-(263,25) 3.9 11.8
doesPathExist Utility.RawFilePath Utility/RawFilePath.hs:30:1-25 3.4 0.6
keyFile'.esc Annex.Locations Annex/Locations.hs:(596,9)-(600,30) 3.2 14.7
fileKey' Annex.Locations Annex/Locations.hs:(609,1)-(619,41) 3.0 4.7
parseLinkTargetOrPointer Annex.Link Annex/Link.hs:(240,1)-(244,25) 2.8 0.2
hashUpdates.\.\.\ Crypto.Hash Crypto/Hash.hs:85:48-99 2.5 0.1
combineAlways System.FilePath.Posix.ByteString System/FilePath/Posix/../Internal.hs:(698,1)-(704,67) 2.0 3.3
getState Annex Annex.hs:(251,1)-(254,27) 2.0 1.1
withPtr.makeTrampoline Basement.Block.Base Basement/Block/Base.hs:(401,5)-(404,31) 1.9 1.7
withMutablePtrHint Basement.Block.Base Basement/Block/Base.hs:(468,1)-(482,50) 1.8 1.2
parseKeyVariety Types.Key Types/Key.hs:(323,1)-(371,42) 1.8 0.0
fileKey'.go Annex.Locations Annex/Locations.hs:611:9-55 1.7 2.2
isLinkToAnnex Annex.Link Annex/Link.hs:(299,1)-(305,47) 1.7 1.0
hashDirMixed Annex.DirHashes Annex/DirHashes.hs:(82,1)-(90,27) 1.7 1.3
primitive Basement.Monad Basement/Monad.hs:72:5-18 1.6 0.1
withPtr Basement.Block.Base Basement/Block/Base.hs:(395,1)-(404,31) 1.5 1.6
mkKeySerialization Types.Key Types/Key.hs:(115,1)-(117,22) 1.1 2.8
decimal.step Data.Attoparsec.ByteString.Char8 Data/Attoparsec/ByteString/Char8.hs:448:9-49 0.8 1.2
"""]]

1
stack.yaml
View file

@ -24,6 +24,7 @@ extra-deps:
- sandi-0.5 - sandi-0.5
- http-client-0.5.14 - http-client-0.5.14
- silently-1.2.5.1 - silently-1.2.5.1
- filepath-bytestring-1.4.2.1.0
explicit-setup-deps: explicit-setup-deps:
git-annex: true git-annex: true
resolver: lts-13.29 resolver: lts-13.29