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

more OsPath conversion (520/749)

Browse source 
Sponsored-by: mycroft
This commit is contained in:
Joey Hess 2025-02-05 15:07:59 -04:00
parent 9394197621
commit 0d2b805806
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
11 changed files with 141 additions and 148 deletions
Download patch file Download diff file Expand all files Collapse all files

13
Annex/FileMatcher.hs
View file

@ -5,6 +5,7 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Annex.FileMatcher ( module Annex.FileMatcher (
@ -56,14 +57,14 @@ import Data.Either
import qualified Data.Set as S import qualified Data.Set as S
import Control.Monad.Writer import Control.Monad.Writer
type GetFileMatcher = RawFilePath -> Annex (FileMatcher Annex) type GetFileMatcher = OsPath -> Annex (FileMatcher Annex)
checkFileMatcher :: LiveUpdate -> GetFileMatcher -> RawFilePath -> Annex Bool checkFileMatcher :: LiveUpdate -> GetFileMatcher -> OsPath -> Annex Bool
checkFileMatcher lu getmatcher file = checkFileMatcher lu getmatcher file =
checkFileMatcher' lu getmatcher file (return True) checkFileMatcher' lu getmatcher file (return True)
-- | Allows running an action when no matcher is configured for the file. -- | Allows running an action when no matcher is configured for the file.
checkFileMatcher' :: LiveUpdate -> GetFileMatcher -> RawFilePath -> Annex Bool -> Annex Bool checkFileMatcher' :: LiveUpdate -> GetFileMatcher -> OsPath -> Annex Bool -> Annex Bool
checkFileMatcher' lu getmatcher file notconfigured = do checkFileMatcher' lu getmatcher file notconfigured = do
matcher <- getmatcher file matcher <- getmatcher file
checkMatcher matcher Nothing afile lu S.empty notconfigured d checkMatcher matcher Nothing afile lu S.empty notconfigured d
@ -120,7 +121,7 @@ checkMatcher' (matcher, (MatcherDesc matcherdesc)) mi lu notpresent =
fromMaybe mempty descmsg <> UnquotedString s fromMaybe mempty descmsg <> UnquotedString s
return False return False
fileMatchInfo :: RawFilePath -> Maybe Key -> Annex MatchInfo fileMatchInfo :: OsPath -> Maybe Key -> Annex MatchInfo
fileMatchInfo file mkey = do fileMatchInfo file mkey = do
matchfile <- getTopFilePath <$> inRepo (toTopFilePath file) matchfile <- getTopFilePath <$> inRepo (toTopFilePath file)
return $ MatchingFile FileInfo return $ MatchingFile FileInfo
@ -160,7 +161,7 @@ parseToken l t = case syntaxToken t of
tokenizeMatcher :: String -> [String] tokenizeMatcher :: String -> [String]
tokenizeMatcher = filter (not . null) . concatMap splitparens . words tokenizeMatcher = filter (not . null) . concatMap splitparens . words
where where
splitparens = segmentDelim (`elem` "()") splitparens = segmentDelim (`elem` ("()" :: String))
commonTokens :: LimitBy -> [ParseToken (MatchFiles Annex)] commonTokens :: LimitBy -> [ParseToken (MatchFiles Annex)]
commonTokens lb = commonTokens lb =
@ -201,7 +202,7 @@ preferredContentTokens pcd =
, ValueToken "fullysizebalanced" (usev $ limitFullySizeBalanced (repoUUID pcd) (getGroupMap pcd)) , ValueToken "fullysizebalanced" (usev $ limitFullySizeBalanced (repoUUID pcd) (getGroupMap pcd))
] ++ commonTokens LimitAnnexFiles ] ++ commonTokens LimitAnnexFiles
where where
preferreddir = maybe "public" fromProposedAccepted $ preferreddir = toOsPath $ maybe "public" fromProposedAccepted $
M.lookup preferreddirField =<< (`M.lookup` configMap pcd) =<< repoUUID pcd M.lookup preferreddirField =<< (`M.lookup` configMap pcd) =<< repoUUID pcd
preferredContentParser :: [ParseToken (MatchFiles Annex)] -> String -> [ParseResult (MatchFiles Annex)] preferredContentParser :: [ParseToken (MatchFiles Annex)] -> String -> [ParseResult (MatchFiles Annex)]

71
Annex/Ingest.hs
View file

@ -66,7 +66,7 @@ data LockedDown = LockedDown
data LockDownConfig = LockDownConfig data LockDownConfig = LockDownConfig
{ lockingFile :: Bool { lockingFile :: Bool
-- ^ write bit removed during lock down -- ^ write bit removed during lock down
, hardlinkFileTmpDir :: Maybe RawFilePath , hardlinkFileTmpDir :: Maybe OsPath
-- ^ hard link to temp directory -- ^ hard link to temp directory
, checkWritePerms :: Bool , checkWritePerms :: Bool
-- ^ check that write perms are successfully removed -- ^ check that write perms are successfully removed
@ -87,13 +87,13 @@ data LockDownConfig = LockDownConfig
- Lockdown can fail if a file gets deleted, or if it's unable to remove - Lockdown can fail if a file gets deleted, or if it's unable to remove
- write permissions, and Nothing will be returned. - write permissions, and Nothing will be returned.
-} -}
lockDown :: LockDownConfig-> FilePath -> Annex (Maybe LockedDown) lockDown :: LockDownConfig-> OsPath -> Annex (Maybe LockedDown)
lockDown cfg file = either lockDown cfg file = either
(\e -> warning (UnquotedString (show e)) >> return Nothing) (\e -> warning (UnquotedString (show e)) >> return Nothing)
(return . Just) (return . Just)
=<< lockDown' cfg file =<< lockDown' cfg file
lockDown' :: LockDownConfig -> FilePath -> Annex (Either SomeException LockedDown) lockDown' :: LockDownConfig -> OsPath -> Annex (Either SomeException LockedDown)
lockDown' cfg file = tryNonAsync $ ifM crippledFileSystem lockDown' cfg file = tryNonAsync $ ifM crippledFileSystem
( nohardlink ( nohardlink
, case hardlinkFileTmpDir cfg of , case hardlinkFileTmpDir cfg of
@ -101,49 +101,46 @@ lockDown' cfg file = tryNonAsync $ ifM crippledFileSystem
Just tmpdir -> withhardlink tmpdir Just tmpdir -> withhardlink tmpdir
) )
where where
file' = toRawFilePath file
nohardlink = do nohardlink = do
setperms setperms
withTSDelta $ liftIO . nohardlink' withTSDelta $ liftIO . nohardlink'
nohardlink' delta = do nohardlink' delta = do
cache <- genInodeCache file' delta cache <- genInodeCache file delta
return $ LockedDown cfg $ KeySource return $ LockedDown cfg $ KeySource
{ keyFilename = file' { keyFilename = file
, contentLocation = file' , contentLocation = file
, inodeCache = cache , inodeCache = cache
} }
withhardlink tmpdir = do withhardlink tmpdir = do
setperms setperms
withTSDelta $ \delta -> liftIO $ do withTSDelta $ \delta -> liftIO $ do
(tmpfile, h) <- openTmpFileIn (toOsPath tmpdir) $ (tmpfile, h) <- openTmpFileIn tmpdir $
relatedTemplate $ toRawFilePath $ relatedTemplate $ fromOsPath $
"ingest-" ++ takeFileName file literalOsPath "ingest-" <> takeFileName file
hClose h hClose h
let tmpfile' = fromOsPath tmpfile removeWhenExistsWith R.removeLink (fromOsPath tmpfile)
removeWhenExistsWith R.removeLink tmpfile' withhardlink' delta tmpfile
withhardlink' delta tmpfile'
`catchIO` const (nohardlink' delta) `catchIO` const (nohardlink' delta)
withhardlink' delta tmpfile = do withhardlink' delta tmpfile = do
R.createLink file' tmpfile R.createLink (fromOsPath file) (fromOsPath tmpfile)
cache <- genInodeCache tmpfile delta cache <- genInodeCache tmpfile delta
return $ LockedDown cfg $ KeySource return $ LockedDown cfg $ KeySource
{ keyFilename = file' { keyFilename = file
, contentLocation = tmpfile , contentLocation = tmpfile
, inodeCache = cache , inodeCache = cache
} }
setperms = when (lockingFile cfg) $ do setperms = when (lockingFile cfg) $ do
freezeContent file' freezeContent file
when (checkWritePerms cfg) $ do when (checkWritePerms cfg) $ do
qp <- coreQuotePath <$> Annex.getGitConfig qp <- coreQuotePath <$> Annex.getGitConfig
maybe noop (giveup . decodeBS . quote qp) maybe noop (giveup . decodeBS . quote qp)
=<< checkLockedDownWritePerms file' file' =<< checkLockedDownWritePerms file file
checkLockedDownWritePerms :: RawFilePath -> RawFilePath -> Annex (Maybe StringContainingQuotedPath) checkLockedDownWritePerms :: OsPath -> OsPath -> Annex (Maybe StringContainingQuotedPath)
checkLockedDownWritePerms file displayfile = checkContentWritePerm file >>= return . \case checkLockedDownWritePerms file displayfile = checkContentWritePerm file >>= return . \case
Just False -> Just $ "Unable to remove all write permissions from " Just False -> Just $ "Unable to remove all write permissions from "
<> QuotedPath displayfile <> QuotedPath displayfile
@ -167,7 +164,8 @@ ingestAdd' meterupdate ld@(Just (LockedDown cfg source)) mk = do
then addSymlink f k mic then addSymlink f k mic
else do else do
mode <- liftIO $ catchMaybeIO $ mode <- liftIO $ catchMaybeIO $
fileMode <$> R.getFileStatus (contentLocation source) fileMode <$> R.getFileStatus
(fromOsPath (contentLocation source))
stagePointerFile f mode =<< hashPointerFile k stagePointerFile f mode =<< hashPointerFile k
return (Just k) return (Just k)
@ -188,7 +186,7 @@ ingest' preferredbackend meterupdate (Just (LockedDown cfg source)) mk restage =
fst <$> genKey source meterupdate backend fst <$> genKey source meterupdate backend
Just k -> return k Just k -> return k
let src = contentLocation source let src = contentLocation source
ms <- liftIO $ catchMaybeIO $ R.getFileStatus src ms <- liftIO $ catchMaybeIO $ R.getFileStatus (fromOsPath src)
mcache <- maybe (pure Nothing) (liftIO . toInodeCache delta src) ms mcache <- maybe (pure Nothing) (liftIO . toInodeCache delta src) ms
case (mcache, inodeCache source) of case (mcache, inodeCache source) of
(_, Nothing) -> go k mcache (_, Nothing) -> go k mcache
@ -263,12 +261,12 @@ populateUnlockedFiles key source restage _ = do
cleanCruft :: KeySource -> Annex () cleanCruft :: KeySource -> Annex ()
cleanCruft source = when (contentLocation source /= keyFilename source) $ cleanCruft source = when (contentLocation source /= keyFilename source) $
liftIO $ removeWhenExistsWith R.removeLink $ contentLocation source liftIO $ removeWhenExistsWith removeFile $ contentLocation source
-- If a worktree file was was hard linked to an annex object before, -- If a worktree file was was hard linked to an annex object before,
-- modifying the file would have caused the object to have the wrong -- modifying the file would have caused the object to have the wrong
-- content. Clean up from that. -- content. Clean up from that.
cleanOldKeys :: RawFilePath -> Key -> Annex () cleanOldKeys :: OsPath -> Key -> Annex ()
cleanOldKeys file newkey = do cleanOldKeys file newkey = do
g <- Annex.gitRepo g <- Annex.gitRepo
topf <- inRepo (toTopFilePath file) topf <- inRepo (toTopFilePath file)
@ -293,37 +291,38 @@ cleanOldKeys file newkey = do
{- 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.
- This can be called before or after the symlink is in place. -} - This can be called before or after the symlink is in place. -}
restoreFile :: RawFilePath -> Key -> SomeException -> Annex a restoreFile :: OsPath -> Key -> SomeException -> Annex a
restoreFile file key e = do restoreFile file key e = do
whenM (inAnnex key) $ do whenM (inAnnex key) $ do
liftIO $ removeWhenExistsWith R.removeLink file liftIO $ removeWhenExistsWith removeFile 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 <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) obj <- calcRepo (gitAnnexLocation key)
unlessM (liftIO $ copyFileExternal CopyTimeStamps obj (fromRawFilePath file)) $ unlessM (liftIO $ copyFileExternal CopyTimeStamps obj file) $
warning $ "Unable to restore content of " <> QuotedPath file <> "; it should be located in " <> QuotedPath (toRawFilePath obj) warning $ "Unable to restore content of " <> QuotedPath file <> "; it should be located in " <> QuotedPath obj
thawContent file thawContent file
throwM e throwM e
{- Creates the symlink to the annexed content, returns the link target. -} {- Creates the symlink to the annexed content, returns the link target. -}
makeLink :: RawFilePath -> Key -> Maybe InodeCache -> Annex LinkTarget makeLink :: OsPath -> Key -> Maybe InodeCache -> Annex LinkTarget
makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do
l <- calcRepo $ gitAnnexLink file key l <- fromOsPath <$> calcRepo (gitAnnexLink file key)
replaceWorkTreeFile file $ makeAnnexLink l replaceWorkTreeFile file $ makeAnnexLink l
-- touch symlink to have same time as the original file, -- touch symlink to have same time as the original file,
-- as provided in the InodeCache -- as provided in the InodeCache
case mcache of case mcache of
Just c -> liftIO $ touch file (inodeCacheToMtime c) False Just c -> liftIO $
touch (fromOsPath file) (inodeCacheToMtime c) False
Nothing -> noop Nothing -> noop
return l return l
{- Creates the symlink to the annexed content, and stages it in git. -} {- Creates the symlink to the annexed content, and stages it in git. -}
addSymlink :: RawFilePath -> Key -> Maybe InodeCache -> Annex () addSymlink :: OsPath -> Key -> Maybe InodeCache -> Annex ()
addSymlink file key mcache = stageSymlink file =<< genSymlink file key mcache addSymlink file key mcache = stageSymlink file =<< genSymlink file key mcache
genSymlink :: RawFilePath -> Key -> Maybe InodeCache -> Annex Git.Sha genSymlink :: OsPath -> Key -> Maybe InodeCache -> Annex Git.Sha
genSymlink file key mcache = do genSymlink file key mcache = do
linktarget <- makeLink file key mcache linktarget <- makeLink file key mcache
hashSymlink linktarget hashSymlink linktarget
@ -368,12 +367,12 @@ addUnlocked matcher mi contentpresent =
- -
- When the content of the key is not accepted into the annex, returns False. - When the content of the key is not accepted into the annex, returns False.
-} -}
addAnnexedFile :: AddUnlockedMatcher -> RawFilePath -> Key -> Maybe RawFilePath -> Annex Bool addAnnexedFile :: AddUnlockedMatcher -> OsPath -> Key -> Maybe OsPath -> Annex Bool
addAnnexedFile matcher file key mtmp = ifM (addUnlocked matcher mi (isJust mtmp)) addAnnexedFile matcher file key mtmp = ifM (addUnlocked matcher mi (isJust mtmp))
( do ( do
mode <- maybe mode <- maybe
(pure Nothing) (pure Nothing)
(\tmp -> liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus tmp) (\tmp -> liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (fromOsPath tmp))
mtmp mtmp
stagePointerFile file mode =<< hashPointerFile key stagePointerFile file mode =<< hashPointerFile key
Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file) Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)
@ -411,7 +410,7 @@ addAnnexedFile matcher file key mtmp = ifM (addUnlocked matcher mi (isJust mtmp)
{- Use with actions that add an already existing annex symlink or pointer {- Use with actions that add an already existing annex symlink or pointer
- file. The warning avoids a confusing situation where the file got copied - file. The warning avoids a confusing situation where the file got copied
- from another git-annex repo, probably by accident. -} - from another git-annex repo, probably by accident. -}
addingExistingLink :: RawFilePath -> Key -> Annex a -> Annex a addingExistingLink :: OsPath -> Key -> Annex a -> Annex a
addingExistingLink f k a = do addingExistingLink f k a = do
unlessM (isKnownKey k <||> inAnnex k) $ do unlessM (isKnownKey k <||> inAnnex k) $ do
islink <- isJust <$> isAnnexLink f islink <- isJust <$> isAnnexLink f

12
Annex/NumCopies.hs
View file

@ -88,7 +88,7 @@ getMinCopies = fromSourcesOr defaultMinCopies
{- NumCopies and MinCopies value for a file, from any configuration source, {- NumCopies and MinCopies value for a file, from any configuration source,
- including .gitattributes. -} - including .gitattributes. -}
getFileNumMinCopies :: RawFilePath -> Annex (NumCopies, MinCopies) getFileNumMinCopies :: OsPath -> Annex (NumCopies, MinCopies)
getFileNumMinCopies f = do getFileNumMinCopies f = do
fnumc <- getForcedNumCopies fnumc <- getForcedNumCopies
fminc <- getForcedMinCopies fminc <- getForcedMinCopies
@ -141,7 +141,7 @@ getSafestNumMinCopies afile k =
Database.Keys.getAssociatedFilesIncluding afile k Database.Keys.getAssociatedFilesIncluding afile k
>>= getSafestNumMinCopies' afile k >>= getSafestNumMinCopies' afile k
getSafestNumMinCopies' :: AssociatedFile -> Key -> [RawFilePath] -> Annex (NumCopies, MinCopies) getSafestNumMinCopies' :: AssociatedFile -> Key -> [OsPath] -> Annex (NumCopies, MinCopies)
getSafestNumMinCopies' afile k fs = do getSafestNumMinCopies' afile k fs = do
l <- mapM getFileNumMinCopies fs l <- mapM getFileNumMinCopies fs
let l' = zip l fs let l' = zip l fs
@ -174,13 +174,13 @@ getSafestNumMinCopies' afile k fs = do
{- This is the globally visible numcopies value for a file. So it does {- This is the globally visible numcopies value for a file. So it does
- not include local configuration in the git config or command line - not include local configuration in the git config or command line
- options. -} - options. -}
getGlobalFileNumCopies :: RawFilePath -> Annex NumCopies getGlobalFileNumCopies :: OsPath -> Annex NumCopies
getGlobalFileNumCopies f = fromSourcesOr defaultNumCopies getGlobalFileNumCopies f = fromSourcesOr defaultNumCopies
[ fst <$> getNumMinCopiesAttr f [ fst <$> getNumMinCopiesAttr f
, getGlobalNumCopies , getGlobalNumCopies
] ]
getNumMinCopiesAttr :: RawFilePath -> Annex (Maybe NumCopies, Maybe MinCopies) getNumMinCopiesAttr :: OsPath -> Annex (Maybe NumCopies, Maybe MinCopies)
getNumMinCopiesAttr file = getNumMinCopiesAttr file =
checkAttrs ["annex.numcopies", "annex.mincopies"] file >>= \case checkAttrs ["annex.numcopies", "annex.mincopies"] file >>= \case
(n:m:[]) -> return (n:m:[]) -> return
@ -196,12 +196,12 @@ getNumMinCopiesAttr file =
- This is good enough for everything except dropping the file, which - This is good enough for everything except dropping the file, which
- requires active verification of the copies. - requires active verification of the copies.
-} -}
numCopiesCheck :: RawFilePath -> Key -> (Int -> Int -> v) -> Annex v numCopiesCheck :: OsPath -> Key -> (Int -> Int -> v) -> Annex v
numCopiesCheck file key vs = do numCopiesCheck file key vs = do
have <- trustExclude UnTrusted =<< Remote.keyLocations key have <- trustExclude UnTrusted =<< Remote.keyLocations key
numCopiesCheck' file vs have numCopiesCheck' file vs have
numCopiesCheck' :: RawFilePath -> (Int -> Int -> v) -> [UUID] -> Annex v numCopiesCheck' :: OsPath -> (Int -> Int -> v) -> [UUID] -> Annex v
numCopiesCheck' file vs have = do numCopiesCheck' file vs have = do
needed <- fst <$> getFileNumMinCopies file needed <- fst <$> getFileNumMinCopies file
let nhave = numCopiesCount have let nhave = numCopiesCount have

19
Annex/Proxy.hs
View file

@ -41,7 +41,6 @@ import Control.Concurrent.STM
import Control.Concurrent.Async import Control.Concurrent.Async
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified System.FilePath.ByteString as P
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Set as S import qualified Data.Set as S
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
@ -177,8 +176,8 @@ proxySpecialRemote protoversion r ihdl ohdl owaitv oclosedv mexportdb = go
-- independently. Also, this key is not getting added into the -- independently. Also, this key is not getting added into the
-- local annex objects. -- local annex objects.
withproxytmpfile k a = withOtherTmp $ \othertmpdir -> withproxytmpfile k a = withOtherTmp $ \othertmpdir ->
withTmpDirIn (fromRawFilePath othertmpdir) (toOsPath "proxy") $ \tmpdir -> withTmpDirIn othertmpdir (literalOsPath "proxy") $ \tmpdir ->
a (toRawFilePath tmpdir P.</> keyFile k) a (tmpdir </> keyFile k)
proxyput af k = do proxyput af k = do
liftIO $ sendmessage $ PUT_FROM (Offset 0) liftIO $ sendmessage $ PUT_FROM (Offset 0)
@ -188,14 +187,14 @@ proxySpecialRemote protoversion r ihdl ohdl owaitv oclosedv mexportdb = go
-- the client, to avoid bad content -- the client, to avoid bad content
-- being stored in the special remote. -- being stored in the special remote.
iv <- startVerifyKeyContentIncrementally Remote.AlwaysVerify k iv <- startVerifyKeyContentIncrementally Remote.AlwaysVerify k
h <- liftIO $ F.openFile (toOsPath tmpfile) WriteMode h <- liftIO $ F.openFile tmpfile WriteMode
let nuketmp = liftIO $ removeWhenExistsWith removeFile (fromRawFilePath tmpfile) let nuketmp = liftIO $ removeWhenExistsWith removeFile tmpfile
gotall <- liftIO $ receivetofile iv h len gotall <- liftIO $ receivetofile iv h len
liftIO $ hClose h liftIO $ hClose h
verified <- if gotall verified <- if gotall
then fst <$> finishVerifyKeyContentIncrementally' True iv then fst <$> finishVerifyKeyContentIncrementally' True iv
else pure False else pure False
let store = tryNonAsync (storeput k af (decodeBS tmpfile)) >>= \case let store = tryNonAsync (storeput k af tmpfile) >>= \case
Right () -> liftIO $ sendmessage SUCCESS Right () -> liftIO $ sendmessage SUCCESS
Left err -> liftIO $ propagateerror err Left err -> liftIO $ propagateerror err
if protoversion > ProtocolVersion 1 if protoversion > ProtocolVersion 1
@ -262,8 +261,8 @@ proxySpecialRemote protoversion r ihdl ohdl owaitv oclosedv mexportdb = go
storetofile iv h (n - fromIntegral (B.length b)) bs storetofile iv h (n - fromIntegral (B.length b)) bs
proxyget offset af k = withproxytmpfile k $ \tmpfile -> do proxyget offset af k = withproxytmpfile k $ \tmpfile -> do
let retrieve = tryNonAsync $ Remote.retrieveKeyFile r k af let retrieve = tryNonAsync $ Remote.retrieveKeyFile
(fromRawFilePath tmpfile) nullMeterUpdate vc r k af tmpfile nullMeterUpdate vc
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
ordered <- Remote.retrieveKeyFileInOrder r ordered <- Remote.retrieveKeyFileInOrder r
#else #else
@ -298,7 +297,7 @@ proxySpecialRemote protoversion r ihdl ohdl owaitv oclosedv mexportdb = go
sendlen offset size sendlen offset size
waitforfile waitforfile
x <- tryNonAsync $ do x <- tryNonAsync $ do
h <- openFileBeingWritten f h <- openFileBeingWritten (fromOsPath f)
hSeek h AbsoluteSeek offset hSeek h AbsoluteSeek offset
senddata' h (getcontents size) senddata' h (getcontents size)
case x of case x of
@ -350,7 +349,7 @@ proxySpecialRemote protoversion r ihdl ohdl owaitv oclosedv mexportdb = go
senddata (Offset offset) f = do senddata (Offset offset) f = do
size <- fromIntegral <$> getFileSize f size <- fromIntegral <$> getFileSize f
sendlen offset size sendlen offset size
withBinaryFile (fromRawFilePath f) ReadMode $ \h -> do F.withBinaryFile f ReadMode $ \h -> do
hSeek h AbsoluteSeek offset hSeek h AbsoluteSeek offset
senddata' h L.hGetContents senddata' h L.hGetContents

45
Annex/View.hs
View file

@ -40,13 +40,12 @@ import Logs.View
import Utility.Glob import Utility.Glob
import Types.Command import Types.Command
import CmdLine.Action import CmdLine.Action
import qualified Utility.RawFilePath as R import qualified Utility.OsString as OS
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Map as M import qualified Data.Map as M
import qualified System.FilePath.ByteString as P
import Control.Concurrent.Async import Control.Concurrent.Async
import "mtl" Control.Monad.Writer import "mtl" Control.Monad.Writer
@ -251,7 +250,7 @@ combineViewFilter (ExcludeValues _) new@(FilterGlobOrUnset _ _) = (new, Widening
- evaluate this function with the view parameter and reuse - evaluate this function with the view parameter and reuse
- the result. The globs in the view will then be compiled and memoized. - the result. The globs in the view will then be compiled and memoized.
-} -}
viewedFiles :: View -> MkViewedFile -> FilePath -> MetaData -> [ViewedFile] viewedFiles :: View -> MkViewedFile -> OsPath -> MetaData -> [ViewedFile]
viewedFiles view = viewedFiles view =
let matchers = map viewComponentMatcher (viewComponents view) let matchers = map viewComponentMatcher (viewComponents view)
in \mkviewedfile file metadata -> in \mkviewedfile file metadata ->
@ -260,7 +259,8 @@ viewedFiles view =
then [] then []
else else
let paths = pathProduct $ let paths = pathProduct $
map (map toviewpath) (visible matches) map (map (toOsPath . toviewpath))
(visible matches)
in if null paths in if null paths
then [mkviewedfile file] then [mkviewedfile file]
else map (</> mkviewedfile file) paths else map (</> mkviewedfile file) paths
@ -346,7 +346,7 @@ fromViewPath = toMetaValue . encodeBS . deescapepseudo []
prop_viewPath_roundtrips :: MetaValue -> Bool prop_viewPath_roundtrips :: MetaValue -> Bool
prop_viewPath_roundtrips v = fromViewPath (toViewPath v) == v prop_viewPath_roundtrips v = fromViewPath (toViewPath v) == v
pathProduct :: [[FilePath]] -> [FilePath] pathProduct :: [[OsPath]] -> [OsPath]
pathProduct [] = [] pathProduct [] = []
pathProduct (l:ls) = foldl combinel l ls pathProduct (l:ls) = foldl combinel l ls
where where
@ -364,7 +364,7 @@ fromView view f = MetaData $ m `M.difference` derived
filter (not . isviewunset) (zip visible values) filter (not . isviewunset) (zip visible values)
visible = filter viewVisible (viewComponents view) visible = filter viewVisible (viewComponents view)
paths = splitDirectories (dropFileName f) paths = splitDirectories (dropFileName f)
values = map (S.singleton . fromViewPath) paths values = map (S.singleton . fromViewPath . fromOsPath) paths
MetaData derived = getViewedFileMetaData f MetaData derived = getViewedFileMetaData f
convfield (vc, v) = (viewField vc, v) convfield (vc, v) = (viewField vc, v)
@ -385,9 +385,9 @@ fromView view f = MetaData $ m `M.difference` derived
prop_view_roundtrips :: AssociatedFile -> MetaData -> Bool -> Bool prop_view_roundtrips :: AssociatedFile -> MetaData -> Bool -> Bool
prop_view_roundtrips (AssociatedFile Nothing) _ _ = True prop_view_roundtrips (AssociatedFile Nothing) _ _ = True
prop_view_roundtrips (AssociatedFile (Just f)) metadata visible = or prop_view_roundtrips (AssociatedFile (Just f)) metadata visible = or
[ B.null (P.takeFileName f) && B.null (P.takeDirectory f) [ OS.null (takeFileName f) && OS.null (takeDirectory f)
, viewTooLarge view , viewTooLarge view
, all hasfields (viewedFiles view (viewedFileFromReference' Nothing Nothing) (fromRawFilePath f) metadata) , all hasfields (viewedFiles view (viewedFileFromReference' Nothing Nothing) f metadata)
] ]
where where
view = View (Git.Ref "foo") $ view = View (Git.Ref "foo") $
@ -402,19 +402,19 @@ prop_view_roundtrips (AssociatedFile (Just f)) metadata visible = or
- Note that this may generate MetaFields that legalField rejects. - Note that this may generate MetaFields that legalField rejects.
- This is necessary to have a 1:1 mapping between directory names and - This is necessary to have a 1:1 mapping between directory names and
- fields. So this MetaData cannot safely be serialized. -} - fields. So this MetaData cannot safely be serialized. -}
getDirMetaData :: FilePath -> MetaData getDirMetaData :: OsPath -> MetaData
getDirMetaData d = MetaData $ M.fromList $ zip fields values getDirMetaData d = MetaData $ M.fromList $ zip fields values
where where
dirs = splitDirectories d dirs = splitDirectories d
fields = map (mkMetaFieldUnchecked . T.pack . addTrailingPathSeparator . joinPath) fields = map (mkMetaFieldUnchecked . T.pack . fromOsPath . addTrailingPathSeparator . joinPath)
(inits dirs) (inits dirs)
values = map (S.singleton . toMetaValue . encodeBS . fromMaybe "" . headMaybe) values = map (S.singleton . toMetaValue . encodeBS . fromMaybe "" . headMaybe)
(tails dirs) (tails (map fromOsPath dirs))
getWorkTreeMetaData :: FilePath -> MetaData getWorkTreeMetaData :: OsPath -> MetaData
getWorkTreeMetaData = getDirMetaData . dropFileName getWorkTreeMetaData = getDirMetaData . dropFileName
getViewedFileMetaData :: FilePath -> MetaData getViewedFileMetaData :: OsPath -> MetaData
getViewedFileMetaData = getDirMetaData . dirFromViewedFile . takeFileName getViewedFileMetaData = getDirMetaData . dirFromViewedFile . takeFileName
{- Applies a view to the currently checked out branch, generating a new {- Applies a view to the currently checked out branch, generating a new
@ -439,7 +439,7 @@ narrowView = applyView' viewedFileReuse getViewedFileMetaData
- Look up the metadata of annexed files, and generate any ViewedFiles, - Look up the metadata of annexed files, and generate any ViewedFiles,
- and stage them. - and stage them.
-} -}
applyView' :: MkViewedFile -> (FilePath -> MetaData) -> View -> Maybe Adjustment -> Annex Git.Branch applyView' :: MkViewedFile -> (OsPath -> MetaData) -> View -> Maybe Adjustment -> Annex Git.Branch
applyView' mkviewedfile getfilemetadata view madj = do applyView' mkviewedfile getfilemetadata view madj = do
top <- fromRepo Git.repoPath top <- fromRepo Git.repoPath
(l, clean) <- inRepo $ Git.LsFiles.inRepoDetails [] [top] (l, clean) <- inRepo $ Git.LsFiles.inRepoDetails [] [top]
@ -452,7 +452,7 @@ applyView' mkviewedfile getfilemetadata view madj = do
applyView'' applyView''
:: MkViewedFile :: MkViewedFile
-> (FilePath -> MetaData) -> (OsPath -> MetaData)
-> View -> View
-> Maybe Adjustment -> Maybe Adjustment
-> [t] -> [t]
@ -488,18 +488,18 @@ applyView'' mkviewedfile getfilemetadata view madj l clean conv = do
-- Git.UpdateIndex.streamUpdateIndex' -- Git.UpdateIndex.streamUpdateIndex'
-- here would race with process's calls -- here would race with process's calls
-- to it. -- to it.
| "." `B.isPrefixOf` getTopFilePath topf -> | literalOsPath "." `OS.isPrefixOf` getTopFilePath topf ->
feed "dummy" feed (literalOsPath "dummy")
| otherwise -> noop | otherwise -> noop
getmetadata gc mdfeeder mdcloser ts getmetadata gc mdfeeder mdcloser ts
process uh mdreader = liftIO mdreader >>= \case process uh mdreader = liftIO mdreader >>= \case
Just ((topf, _, mtreeitemtype, Just k), mdlog) -> do Just ((topf, _, mtreeitemtype, Just k), mdlog) -> do
let metadata = maybe emptyMetaData parseCurrentMetaData mdlog let metadata = maybe emptyMetaData parseCurrentMetaData mdlog
let f = fromRawFilePath $ getTopFilePath topf let f = getTopFilePath topf
let metadata' = getfilemetadata f `unionMetaData` metadata let metadata' = getfilemetadata f `unionMetaData` metadata
forM_ (genviewedfiles f metadata') $ \fv -> do forM_ (genviewedfiles f metadata') $ \fv -> do
f' <- fromRepo (fromTopFilePath $ asTopFilePath $ toRawFilePath fv) f' <- fromRepo (fromTopFilePath $ asTopFilePath fv)
stagefile uh f' k mtreeitemtype stagefile uh f' k mtreeitemtype
process uh mdreader process uh mdreader
Just ((topf, sha, Just treeitemtype, Nothing), _) -> do Just ((topf, sha, Just treeitemtype, Nothing), _) -> do
@ -527,7 +527,7 @@ applyView'' mkviewedfile getfilemetadata view madj l clean conv = do
_ -> stagesymlink uh f k _ -> stagesymlink uh f k
stagesymlink uh f k = do stagesymlink uh f k = do
linktarget <- calcRepo (gitAnnexLink f k) linktarget <- fromOsPath <$> calcRepo (gitAnnexLink f k)
sha <- hashSymlink linktarget sha <- hashSymlink linktarget
liftIO . Git.UpdateIndex.streamUpdateIndex' uh liftIO . Git.UpdateIndex.streamUpdateIndex' uh
=<< inRepo (Git.UpdateIndex.stageSymlink f sha) =<< inRepo (Git.UpdateIndex.stageSymlink f sha)
@ -609,7 +609,7 @@ withViewChanges addmeta removemeta = do
=<< catKey (DiffTree.dstsha item) =<< catKey (DiffTree.dstsha item)
| otherwise = noop | otherwise = noop
handlechange item a = maybe noop handlechange item a = maybe noop
(void . commandAction . a (fromRawFilePath $ getTopFilePath $ DiffTree.file item)) (void . commandAction . a (getTopFilePath $ DiffTree.file item))
{- Runs an action using the view index file. {- Runs an action using the view index file.
- Note that the file does not necessarily exist, or can contain - Note that the file does not necessarily exist, or can contain
@ -619,7 +619,8 @@ withViewIndex = withIndexFile ViewIndexFile . const
withNewViewIndex :: Annex a -> Annex a withNewViewIndex :: Annex a -> Annex a
withNewViewIndex a = do withNewViewIndex a = do
liftIO . removeWhenExistsWith R.removeLink =<< fromRepo gitAnnexViewIndex liftIO . removeWhenExistsWith removeFile
=<< fromRepo gitAnnexViewIndex
withViewIndex a withViewIndex a
{- Generates a branch for a view, using the view index file {- Generates a branch for a view, using the view index file

13
Annex/View/ViewedFile.hs
View file

@ -25,8 +25,7 @@ import qualified Utility.OsString as OS
import qualified Data.ByteString as S import qualified Data.ByteString as S
type FileName = String type ViewedFile = OsPath
type ViewedFile = FileName
type MkViewedFile = OsPath -> ViewedFile type MkViewedFile = OsPath -> ViewedFile
@ -45,7 +44,7 @@ viewedFileFromReference g = viewedFileFromReference'
(annexMaxExtensions g) (annexMaxExtensions g)
viewedFileFromReference' :: Maybe Int -> Maybe Int -> MkViewedFile viewedFileFromReference' :: Maybe Int -> Maybe Int -> MkViewedFile
viewedFileFromReference' maxextlen maxextensions f = concat $ viewedFileFromReference' maxextlen maxextensions f = toOsPath $ concat $
[ escape (fromOsPath base') [ escape (fromOsPath base')
, if null dirs , if null dirs
then "" then ""
@ -90,12 +89,12 @@ escchar = '!'
{- For use when operating already within a view, so whatever filepath {- For use when operating already within a view, so whatever filepath
- is present in the work tree is already a ViewedFile. -} - is present in the work tree is already a ViewedFile. -}
viewedFileReuse :: MkViewedFile viewedFileReuse :: MkViewedFile
viewedFileReuse = fromOsPath . takeFileName viewedFileReuse = takeFileName
{- Extracts from a ViewedFile the directory where the file is located on {- Extracts from a ViewedFile the directory where the file is located on
- in the reference branch. -} - in the reference branch. -}
dirFromViewedFile :: ViewedFile -> FilePath dirFromViewedFile :: ViewedFile -> OsPath
dirFromViewedFile = fromOsPath . joinPath . map toOsPath . drop 1 . sep [] "" dirFromViewedFile = joinPath . map toOsPath . drop 1 . sep [] "" . fromOsPath
where where
sep l _ [] = reverse l sep l _ [] = reverse l
sep l curr (c:cs) sep l curr (c:cs)
@ -110,7 +109,7 @@ prop_viewedFile_roundtrips tf
-- Relative filenames wanted, not directories. -- Relative filenames wanted, not directories.
| OS.any isPathSeparator (toOsPath (end f ++ beginning f)) = True | OS.any isPathSeparator (toOsPath (end f ++ beginning f)) = True
| isAbsolute (toOsPath f) || isDrive (toOsPath f) = True | isAbsolute (toOsPath f) || isDrive (toOsPath f) = True
| otherwise = fromOsPath dir == dirFromViewedFile | otherwise = dir == dirFromViewedFile
(viewedFileFromReference' Nothing Nothing (toOsPath f)) (viewedFileFromReference' Nothing Nothing (toOsPath f))
where where
f = fromTestableFilePath tf f = fromTestableFilePath tf

4
Assistant/Types/Changes.hs
View file

@ -9,10 +9,10 @@
module Assistant.Types.Changes where module Assistant.Types.Changes where
import Common
import Types.KeySource import Types.KeySource
import Types.Key import Types.Key
import Utility.TList import Utility.TList
import Utility.FileSystemEncoding
import Annex.Ingest import Annex.Ingest
import Control.Concurrent.STM import Control.Concurrent.STM
@ -58,7 +58,7 @@ changeInfoKey _ = Nothing
changeFile :: Change -> FilePath changeFile :: Change -> FilePath
changeFile (Change _ f _) = f changeFile (Change _ f _) = f
changeFile (PendingAddChange _ f) = f changeFile (PendingAddChange _ f) = f
changeFile (InProcessAddChange _ ld) = fromRawFilePath $ keyFilename $ keySource ld changeFile (InProcessAddChange _ ld) = fromOsPath $ keyFilename $ keySource ld
isPendingAddChange :: Change -> Bool isPendingAddChange :: Change -> Bool
isPendingAddChange (PendingAddChange {}) = True isPendingAddChange (PendingAddChange {}) = True

6
CmdLine/Batch.hs
View file

@ -154,12 +154,12 @@ batchCommandStart a = a >>= \case
-- to handle them. -- to handle them.
-- --
-- File matching options are checked, and non-matching files skipped. -- File matching options are checked, and non-matching files skipped.
batchFiles :: BatchFormat -> ((SeekInput, RawFilePath) -> CommandStart) -> Annex () batchFiles :: BatchFormat -> ((SeekInput, OsPath) -> CommandStart) -> Annex ()
batchFiles fmt a = batchFilesKeys fmt $ \(si, v) -> case v of batchFiles fmt a = batchFilesKeys fmt $ \(si, v) -> case v of
Right f -> a (si, f) Right f -> a (si, f)
Left _k -> return Nothing Left _k -> return Nothing
batchFilesKeys :: BatchFormat -> ((SeekInput, Either Key RawFilePath) -> CommandStart) -> Annex () batchFilesKeys :: BatchFormat -> ((SeekInput, Either Key OsPath) -> CommandStart) -> Annex ()
batchFilesKeys fmt a = do batchFilesKeys fmt a = do
matcher <- getMatcher matcher <- getMatcher
go $ \si v -> case v of go $ \si v -> case v of
@ -177,7 +177,7 @@ batchFilesKeys fmt a = do
-- CmdLine.Seek uses git ls-files. -- CmdLine.Seek uses git ls-files.
BatchFormat _ (BatchKeys False) -> BatchFormat _ (BatchKeys False) ->
Right . Right Right . Right
<$$> liftIO . relPathCwdToFile . toRawFilePath <$$> liftIO . relPathCwdToFile . toOsPath
BatchFormat _ (BatchKeys True) -> \i -> BatchFormat _ (BatchKeys True) -> \i ->
pure $ case deserializeKey i of pure $ case deserializeKey i of
Just k -> Right (Left k) Just k -> Right (Left k)

59
CmdLine/Seek.hs
View file

@ -48,6 +48,7 @@ import qualified Database.Keys
import qualified Utility.RawFilePath as R import qualified Utility.RawFilePath as R
import Utility.Tuple import Utility.Tuple
import Utility.HumanTime import Utility.HumanTime
import qualified Utility.OsString as OS
import Control.Concurrent.Async import Control.Concurrent.Async
import Control.Concurrent.STM import Control.Concurrent.STM
@ -55,11 +56,9 @@ import System.Posix.Types
import Data.IORef import Data.IORef
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
import System.PosixCompat.Files (isDirectory, isSymbolicLink, deviceID, fileID) import System.PosixCompat.Files (isDirectory, isSymbolicLink, deviceID, fileID)
import qualified System.FilePath.ByteString as P
import qualified Data.ByteString as S
data AnnexedFileSeeker = AnnexedFileSeeker data AnnexedFileSeeker = AnnexedFileSeeker
{ startAction :: Maybe KeySha -> SeekInput -> RawFilePath -> Key -> CommandStart { startAction :: Maybe KeySha -> SeekInput -> OsPath -> Key -> CommandStart
, checkContentPresent :: Maybe Bool , checkContentPresent :: Maybe Bool
, usesLocationLog :: Bool , usesLocationLog :: Bool
} }
@ -82,7 +81,7 @@ withFilesInGitAnnexNonRecursive ww needforce a (WorkTreeItems l) = ifM (Annex.ge
getfiles c [] = return (reverse c, pure True) getfiles c [] = return (reverse c, pure True)
getfiles c (p:ps) = do getfiles c (p:ps) = do
os <- seekOptions ww os <- seekOptions ww
(fs, cleanup) <- inRepo $ LsFiles.inRepoDetails os [toRawFilePath p] (fs, cleanup) <- inRepo $ LsFiles.inRepoDetails os [toOsPath p]
r <- case fs of r <- case fs of
[f] -> do [f] -> do
propagateLsFilesError cleanup propagateLsFilesError cleanup
@ -96,18 +95,18 @@ withFilesInGitAnnexNonRecursive ww needforce a (WorkTreeItems l) = ifM (Annex.ge
return (r, pure True) return (r, pure True)
withFilesInGitAnnexNonRecursive _ _ _ NoWorkTreeItems = noop withFilesInGitAnnexNonRecursive _ _ _ NoWorkTreeItems = noop
withFilesNotInGit :: CheckGitIgnore -> WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek withFilesNotInGit :: CheckGitIgnore -> WarnUnmatchWhen -> ((SeekInput, OsPath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
withFilesNotInGit (CheckGitIgnore ci) ww a l = do withFilesNotInGit (CheckGitIgnore ci) ww a l = do
force <- Annex.getRead Annex.force force <- Annex.getRead Annex.force
let include_ignored = force || not ci let include_ignored = force || not ci
seekFiltered (const (pure True)) a $ seekFiltered (const (pure True)) a $
seekHelper id ww (const $ LsFiles.notInRepo [] include_ignored) l seekHelper id ww (const $ LsFiles.notInRepo [] include_ignored) l
withPathContents :: ((RawFilePath, RawFilePath) -> CommandSeek) -> CmdParams -> CommandSeek withPathContents :: ((OsPath, OsPath) -> CommandSeek) -> CmdParams -> CommandSeek
withPathContents a params = do withPathContents a params = do
matcher <- Limit.getMatcher matcher <- Limit.getMatcher
checktimelimit <- mkCheckTimeLimit checktimelimit <- mkCheckTimeLimit
go matcher checktimelimit params [] go matcher checktimelimit (map toOsPath params) []
where where
go _ _ [] [] = return () go _ _ [] [] = return ()
go matcher checktimelimit (p:ps) [] = go matcher checktimelimit (p:ps) [] =
@ -121,14 +120,12 @@ withPathContents a params = do
-- fail if the path that the user provided is a broken symlink, -- fail if the path that the user provided is a broken symlink,
-- the same as it fails if the path that the user provided does not -- the same as it fails if the path that the user provided does not
-- exist. -- exist.
get p = ifM (isDirectory <$> R.getFileStatus p') get p = ifM (isDirectory <$> R.getFileStatus (fromOsPath p))
( map (\f -> ( map (\f ->
(f, P.makeRelative (P.takeDirectory (P.dropTrailingPathSeparator p')) f)) (f, makeRelative (takeDirectory (dropTrailingPathSeparator p)) f))
<$> dirContentsRecursiveSkipping (".git" `S.isSuffixOf`) False p' <$> dirContentsRecursiveSkipping (literalOsPath ".git" `OS.isSuffixOf`) False p
, return [(p', P.takeFileName p')] , return [(p, takeFileName p)]
) )
where
p' = toRawFilePath p
checkmatch matcher (f, relf) = matcher $ MatchingFile $ FileInfo checkmatch matcher (f, relf) = matcher $ MatchingFile $ FileInfo
{ contentFile = f { contentFile = f
@ -150,24 +147,24 @@ withPairs a params = sequence_ $
pairs c (x:y:xs) = pairs ((x,y):c) xs pairs c (x:y:xs) = pairs ((x,y):c) xs
pairs _ _ = giveup "expected pairs" pairs _ _ = giveup "expected pairs"
withFilesToBeCommitted :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek withFilesToBeCommitted :: WarnUnmatchWhen -> ((SeekInput, OsPath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
withFilesToBeCommitted ww a l = seekFiltered (const (pure True)) a $ withFilesToBeCommitted ww a l = seekFiltered (const (pure True)) a $
seekHelper id ww (const LsFiles.stagedNotDeleted) l seekHelper id ww (const LsFiles.stagedNotDeleted) l
{- unlocked pointer files that are staged, and whose content has not been {- unlocked pointer files that are staged, and whose content has not been
- modified-} - modified-}
withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> ((SeekInput, OsPath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
withUnmodifiedUnlockedPointers ww a l = withUnmodifiedUnlockedPointers ww a l =
seekFiltered (isUnmodifiedUnlocked . snd) a $ seekFiltered (isUnmodifiedUnlocked . snd) a $
seekHelper id ww (const LsFiles.typeChangedStaged) l seekHelper id ww (const LsFiles.typeChangedStaged) l
isUnmodifiedUnlocked :: RawFilePath -> Annex Bool isUnmodifiedUnlocked :: OsPath -> Annex Bool
isUnmodifiedUnlocked f = catKeyFile f >>= \case isUnmodifiedUnlocked f = catKeyFile f >>= \case
Nothing -> return False Nothing -> return False
Just k -> sameInodeCache f =<< Database.Keys.getInodeCaches k Just k -> sameInodeCache f =<< Database.Keys.getInodeCaches k
{- Finds files that may be modified. -} {- Finds files that may be modified. -}
withFilesMaybeModified :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek withFilesMaybeModified :: WarnUnmatchWhen -> ((SeekInput, OsPath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
withFilesMaybeModified ww a params = seekFiltered (const (pure True)) a $ withFilesMaybeModified ww a params = seekFiltered (const (pure True)) a $
seekHelper id ww LsFiles.modified params seekHelper id ww LsFiles.modified params
@ -320,7 +317,7 @@ withKeyOptions' ko auto mkkeyaction fallbackaction worktreeitems = do
forM_ ts $ \(t, i) -> forM_ ts $ \(t, i) ->
keyaction Nothing (SeekInput [], transferKey t, mkActionItem (t, i)) keyaction Nothing (SeekInput [], transferKey t, mkActionItem (t, i))
seekFiltered :: ((SeekInput, RawFilePath) -> Annex Bool) -> ((SeekInput, RawFilePath) -> CommandSeek) -> Annex ([(SeekInput, RawFilePath)], IO Bool) -> Annex () seekFiltered :: ((SeekInput, OsPath) -> Annex Bool) -> ((SeekInput, OsPath) -> CommandSeek) -> Annex ([(SeekInput, OsPath)], IO Bool) -> Annex ()
seekFiltered prefilter a listfs = do seekFiltered prefilter a listfs = do
matcher <- Limit.getMatcher matcher <- Limit.getMatcher
checktimelimit <- mkCheckTimeLimit checktimelimit <- mkCheckTimeLimit
@ -351,7 +348,7 @@ checkMatcherWhen mi c i a
-- because of the way data is streamed through git cat-file. -- because of the way data is streamed through git cat-file.
-- --
-- It can also precache location logs using the same efficient streaming. -- It can also precache location logs using the same efficient streaming.
seekFilteredKeys :: AnnexedFileSeeker -> Annex ([(SeekInput, (RawFilePath, Git.Sha, FileMode))], IO Bool) -> Annex () seekFilteredKeys :: AnnexedFileSeeker -> Annex ([(SeekInput, (OsPath, Git.Sha, FileMode))], IO Bool) -> Annex ()
seekFilteredKeys seeker listfs = do seekFilteredKeys seeker listfs = do
g <- Annex.gitRepo g <- Annex.gitRepo
mi <- MatcherInfo mi <- MatcherInfo
@ -465,7 +462,7 @@ seekFilteredKeys seeker listfs = do
-- Check if files exist, because a deleted file will still be -- Check if files exist, because a deleted file will still be
-- listed by ls-tree, but should not be processed. -- listed by ls-tree, but should not be processed.
exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus p) exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus (fromOsPath p))
mdprocess mi mdreader ofeeder ocloser = liftIO mdreader >>= \case mdprocess mi mdreader ofeeder ocloser = liftIO mdreader >>= \case
Just ((si, f), Just (sha, size, _type)) Just ((si, f), Just (sha, size, _type))
@ -485,18 +482,18 @@ seekFilteredKeys seeker listfs = do
null <$> Annex.Branch.getUnmergedRefs null <$> Annex.Branch.getUnmergedRefs
| otherwise = pure False | otherwise = pure False
seekHelper :: (a -> RawFilePath) -> WarnUnmatchWhen -> ([LsFiles.Options] -> [RawFilePath] -> Git.Repo -> IO ([a], IO Bool)) -> WorkTreeItems -> Annex ([(SeekInput, a)], IO Bool) seekHelper :: (a -> OsPath) -> WarnUnmatchWhen -> ([LsFiles.Options] -> [OsPath] -> Git.Repo -> IO ([a], IO Bool)) -> WorkTreeItems -> Annex ([(SeekInput, a)], IO Bool)
seekHelper c ww a (WorkTreeItems l) = do seekHelper c ww a (WorkTreeItems l) = do
os <- seekOptions ww os <- seekOptions ww
v <- liftIO $ newIORef [] v <- liftIO $ newIORef []
r <- inRepo $ \g -> concat . concat <$> forM (segmentXargsOrdered l) r <- inRepo $ \g -> concat . concat <$> forM (segmentXargsOrdered l)
(runSegmentPaths' mk c (\fs -> go v os fs g) . map toRawFilePath) (runSegmentPaths' mk c (\fs -> go v os fs g) . map toOsPath)
return (r, cleanupall v) return (r, cleanupall v)
where where
mk (Just i) f = (SeekInput [fromRawFilePath i], f) mk (Just i) f = (SeekInput [fromOsPath i], f)
-- This is not accurate, but it only happens when there are a -- This is not accurate, but it only happens when there are a
-- great many input WorkTreeItems. -- great many input WorkTreeItems.
mk Nothing f = (SeekInput [fromRawFilePath (c f)], f) mk Nothing f = (SeekInput [fromOsPath (c f)], f)
go v os fs g = do go v os fs g = do
(ls, cleanup) <- a os fs g (ls, cleanup) <- a os fs g
@ -561,7 +558,7 @@ workTreeItems' (AllowHidden allowhidden) ww ps = case ww of
currbranch <- getCurrentBranch currbranch <- getCurrentBranch
stopattop <- prepviasymlink stopattop <- prepviasymlink
ps' <- flip filterM ps $ \p -> do ps' <- flip filterM ps $ \p -> do
let p' = toRawFilePath p let p' = toOsPath p
relf <- liftIO $ relPathCwdToFile p' relf <- liftIO $ relPathCwdToFile p'
ifM (not <$> (exists p' <||> hidden currbranch relf)) ifM (not <$> (exists p' <||> hidden currbranch relf))
( prob action FileNotFound p' "not found" ( prob action FileNotFound p' "not found"
@ -574,13 +571,13 @@ workTreeItems' (AllowHidden allowhidden) ww ps = case ww of
then return NoWorkTreeItems then return NoWorkTreeItems
else return (WorkTreeItems ps') else return (WorkTreeItems ps')
exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus p) exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus $ fromOsPath p)
prepviasymlink = do prepviasymlink = do
repotopst <- inRepo $ repotopst <- inRepo $
maybe maybe
(pure Nothing) (pure Nothing)
(catchMaybeIO . R.getSymbolicLinkStatus) (catchMaybeIO . R.getSymbolicLinkStatus . fromOsPath)
. Git.repoWorkTree . Git.repoWorkTree
return $ \st -> case repotopst of return $ \st -> case repotopst of
Nothing -> False Nothing -> False
@ -589,7 +586,7 @@ workTreeItems' (AllowHidden allowhidden) ww ps = case ww of
viasymlink _ Nothing = return False viasymlink _ Nothing = return False
viasymlink stopattop (Just p) = do viasymlink stopattop (Just p) = do
st <- liftIO $ R.getSymbolicLinkStatus p st <- liftIO $ R.getSymbolicLinkStatus $ fromOsPath p
if stopattop st if stopattop st
then return False then return False
else if isSymbolicLink st else if isSymbolicLink st
@ -602,12 +599,12 @@ workTreeItems' (AllowHidden allowhidden) ww ps = case ww of
| otherwise = return False | otherwise = return False
prob action errorid p msg = do prob action errorid p msg = do
toplevelFileProblem False errorid msg action p Nothing (SeekInput [fromRawFilePath p]) toplevelFileProblem False errorid msg action p Nothing (SeekInput [fromOsPath p])
Annex.incError Annex.incError
return False return False
notSymlink :: RawFilePath -> IO Bool notSymlink :: OsPath -> IO Bool
notSymlink f = liftIO $ not . isSymbolicLink <$> R.getSymbolicLinkStatus f notSymlink f = liftIO $ not . isSymbolicLink <$> R.getSymbolicLinkStatus (fromOsPath f)
{- Returns an action that, when there's a time limit, can be used {- Returns an action that, when there's a time limit, can be used
- to check it before processing a file. The first action is run when - to check it before processing a file. The first action is run when

45
Limit.hs
View file

@ -48,7 +48,6 @@ import Control.Monad.Writer
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Map as M import qualified Data.Map as M
import qualified System.FilePath.ByteString as P
import System.PosixCompat.Files (accessTime, isSymbolicLink) import System.PosixCompat.Files (accessTime, isSymbolicLink)
{- Some limits can look at the current status of files on {- Some limits can look at the current status of files on
@ -140,11 +139,12 @@ matchGlobFile :: String -> MatchInfo -> Annex Bool
matchGlobFile glob = go matchGlobFile glob = go
where where
cglob = compileGlob glob CaseSensitive (GlobFilePath True) -- memoized cglob = compileGlob glob CaseSensitive (GlobFilePath True) -- memoized
go (MatchingFile fi) = pure $ matchGlob cglob (fromRawFilePath (matchFile fi)) go (MatchingFile fi) = pure $ matchGlob cglob (fromOsPath (matchFile fi))
go (MatchingInfo p) = pure $ case providedFilePath p of go (MatchingInfo p) = pure $ case providedFilePath p of
Just f -> matchGlob cglob (fromRawFilePath f) Just f -> matchGlob cglob (fromOsPath f)
Nothing -> False Nothing -> False
go (MatchingUserInfo p) = matchGlob cglob <$> getUserInfo (userProvidedFilePath p) go (MatchingUserInfo p) = matchGlob cglob . fromOsPath
<$> getUserInfo (userProvidedFilePath p)
{- Add a limit to skip files when there is no other file using the same {- Add a limit to skip files when there is no other file using the same
- content, with a name matching the glob. -} - content, with a name matching the glob. -}
@ -188,23 +188,22 @@ matchSameContentGlob glob mi = checkKey (go mi) mi
Just f -> check k f Just f -> check k f
Nothing -> return False Nothing -> return False
go (MatchingUserInfo p) k = go (MatchingUserInfo p) k =
check k . toRawFilePath check k =<< getUserInfo (userProvidedFilePath p)
=<< getUserInfo (userProvidedFilePath p)
cglob = compileGlob glob CaseSensitive (GlobFilePath True) -- memoized cglob = compileGlob glob CaseSensitive (GlobFilePath True) -- memoized
matchesglob f = matchGlob cglob (fromRawFilePath f) matchesglob f = matchGlob cglob (fromOsPath f)
#ifdef mingw32_HOST_OS #ifdef mingw32_HOST_OS
|| matchGlob cglob (fromRawFilePath (toInternalGitPath f)) || matchGlob cglob (fromOsPath (toInternalGitPath f))
#endif #endif
check k skipf = do check k skipf = do
-- Find other files with the same content, with filenames -- Find other files with the same content, with filenames
-- matching the glob. -- matching the glob.
g <- Annex.gitRepo g <- Annex.gitRepo
fs <- filter (/= P.normalise skipf) fs <- filter (/= normalise skipf)
. filter matchesglob . filter matchesglob
. map (\f -> P.normalise (fromTopFilePath f g)) . map (\f -> normalise (fromTopFilePath f g))
<$> Database.Keys.getAssociatedFiles k <$> Database.Keys.getAssociatedFiles k
-- Some associated files in the keys database may no longer -- Some associated files in the keys database may no longer
-- correspond to files in the repository. This is checked -- correspond to files in the repository. This is checked
@ -219,7 +218,7 @@ addMimeEncoding = addMagicLimit "mimeencoding" getMagicMimeEncoding providedMime
addMagicLimit addMagicLimit
:: String :: String
-> (Magic -> FilePath -> Annex (Maybe String)) -> (Magic -> OsPath -> Annex (Maybe String))
-> (ProvidedInfo -> Maybe String) -> (ProvidedInfo -> Maybe String)
-> (UserProvidedInfo -> UserInfo String) -> (UserProvidedInfo -> UserInfo String)
-> String -> String
@ -228,20 +227,19 @@ addMagicLimit limitname querymagic selectprovidedinfo selectuserprovidedinfo glo
magic <- liftIO initMagicMime magic <- liftIO initMagicMime
addLimit $ matchMagic limitname querymagic' selectprovidedinfo selectuserprovidedinfo magic glob addLimit $ matchMagic limitname querymagic' selectprovidedinfo selectuserprovidedinfo magic glob
where where
querymagic' magic f = liftIO (isPointerFile (toRawFilePath f)) >>= \case querymagic' magic f = liftIO (isPointerFile f) >>= \case
-- Avoid getting magic of a pointer file, which would -- Avoid getting magic of a pointer file, which would
-- wrongly be detected as text. -- wrongly be detected as text.
Just _ -> return Nothing Just _ -> return Nothing
-- When the file is an annex symlink, get magic of the -- When the file is an annex symlink, get magic of the
-- object file. -- object file.
Nothing -> isAnnexLink (toRawFilePath f) >>= \case Nothing -> isAnnexLink f >>= \case
Just k -> withObjectLoc k $ Just k -> withObjectLoc k (querymagic magic)
querymagic magic . fromRawFilePath
Nothing -> querymagic magic f Nothing -> querymagic magic f
matchMagic matchMagic
:: String :: String
-> (Magic -> FilePath -> Annex (Maybe String)) -> (Magic -> OsPath -> Annex (Maybe String))
-> (ProvidedInfo -> Maybe String) -> (ProvidedInfo -> Maybe String)
-> (UserProvidedInfo -> UserInfo String) -> (UserProvidedInfo -> UserInfo String)
-> Maybe Magic -> Maybe Magic
@ -261,7 +259,7 @@ matchMagic limitname querymagic selectprovidedinfo selectuserprovidedinfo (Just
cglob = compileGlob glob CaseSensitive (GlobFilePath False) -- memoized cglob = compileGlob glob CaseSensitive (GlobFilePath False) -- memoized
go (MatchingFile fi) = catchBoolIO $ go (MatchingFile fi) = catchBoolIO $
maybe False (matchGlob cglob) maybe False (matchGlob cglob)
<$> querymagic magic (fromRawFilePath (contentFile fi)) <$> querymagic magic (contentFile fi)
go (MatchingInfo p) = maybe go (MatchingInfo p) = maybe
(usecontent (providedKey p)) (usecontent (providedKey p))
(pure . matchGlob cglob) (pure . matchGlob cglob)
@ -269,8 +267,7 @@ matchMagic limitname querymagic selectprovidedinfo selectuserprovidedinfo (Just
go (MatchingUserInfo p) = go (MatchingUserInfo p) =
matchGlob cglob <$> getUserInfo (selectuserprovidedinfo p) matchGlob cglob <$> getUserInfo (selectuserprovidedinfo p)
usecontent (Just k) = withObjectLoc k $ \obj -> catchBoolIO $ usecontent (Just k) = withObjectLoc k $ \obj -> catchBoolIO $
maybe False (matchGlob cglob) maybe False (matchGlob cglob) <$> querymagic magic obj
<$> querymagic magic (fromRawFilePath obj)
usecontent Nothing = pure False usecontent Nothing = pure False
matchMagic limitname _ _ _ Nothing _ = matchMagic limitname _ _ _ Nothing _ =
Left $ "unable to load magic database; \""++limitname++"\" cannot be used" Left $ "unable to load magic database; \""++limitname++"\" cannot be used"
@ -305,7 +302,7 @@ matchLockStatus wantlocked (MatchingFile fi) = liftIO $ do
islocked <- isPointerFile f >>= \case islocked <- isPointerFile f >>= \case
Just _key -> return False Just _key -> return False
Nothing -> isSymbolicLink Nothing -> isSymbolicLink
<$> R.getSymbolicLinkStatus f <$> R.getSymbolicLinkStatus (fromOsPath f)
return (islocked == wantlocked) return (islocked == wantlocked)
matchLockStatus wantlocked (MatchingInfo p) = matchLockStatus wantlocked (MatchingInfo p) =
pure $ case providedLinkType p of pure $ case providedLinkType p of
@ -388,7 +385,7 @@ limitPresent u = MatchFiles
} }
{- Limit to content that is in a directory, anywhere in the repository tree -} {- Limit to content that is in a directory, anywhere in the repository tree -}
limitInDir :: FilePath -> String -> MatchFiles Annex limitInDir :: OsPath -> String -> MatchFiles Annex
limitInDir dir desc = MatchFiles limitInDir dir desc = MatchFiles
{ matchAction = const $ const go { matchAction = const $ const go
, matchNeedsFileName = True , matchNeedsFileName = True
@ -400,8 +397,8 @@ limitInDir dir desc = MatchFiles
, matchDesc = matchDescSimple desc , matchDesc = matchDescSimple desc
} }
where where
go (MatchingFile fi) = checkf $ fromRawFilePath $ matchFile fi go (MatchingFile fi) = checkf $ matchFile fi
go (MatchingInfo p) = maybe (pure False) (checkf . fromRawFilePath) (providedFilePath p) go (MatchingInfo p) = maybe (pure False) checkf (providedFilePath p)
go (MatchingUserInfo p) = checkf =<< getUserInfo (userProvidedFilePath p) go (MatchingUserInfo p) = checkf =<< getUserInfo (userProvidedFilePath p)
checkf = return . elem dir . splitPath . takeDirectory checkf = return . elem dir . splitPath . takeDirectory
@ -867,7 +864,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 <- R.getSymbolicLinkStatus f s <- R.getSymbolicLinkStatus (fromOsPath 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

2
Types/FileMatcher.hs
View file

@ -61,7 +61,7 @@ keyMatchInfoWithoutContent key file = MatchingInfo $ ProvidedInfo
-- This is used when testing a matcher, with values to match against -- This is used when testing a matcher, with values to match against
-- provided by the user. -- provided by the user.
data UserProvidedInfo = UserProvidedInfo data UserProvidedInfo = UserProvidedInfo
{ userProvidedFilePath :: UserInfo FilePath { userProvidedFilePath :: UserInfo OsPath
, userProvidedKey :: UserInfo Key , userProvidedKey :: UserInfo Key
, userProvidedFileSize :: UserInfo FileSize , userProvidedFileSize :: UserInfo FileSize
, userProvidedMimeType :: UserInfo MimeType , userProvidedMimeType :: UserInfo MimeType