more OsPath conversion (520/749)

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

View file

@ -5,6 +5,7 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Annex.FileMatcher (
@ -56,14 +57,14 @@ import Data.Either
import qualified Data.Set as S
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 (return True)
-- | 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
matcher <- getmatcher file
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
return False
fileMatchInfo :: RawFilePath -> Maybe Key -> Annex MatchInfo
fileMatchInfo :: OsPath -> Maybe Key -> Annex MatchInfo
fileMatchInfo file mkey = do
matchfile <- getTopFilePath <$> inRepo (toTopFilePath file)
return $ MatchingFile FileInfo
@ -160,7 +161,7 @@ parseToken l t = case syntaxToken t of
tokenizeMatcher :: String -> [String]
tokenizeMatcher = filter (not . null) . concatMap splitparens . words
where
splitparens = segmentDelim (`elem` "()")
splitparens = segmentDelim (`elem` ("()" :: String))
commonTokens :: LimitBy -> [ParseToken (MatchFiles Annex)]
commonTokens lb =
@ -201,7 +202,7 @@ preferredContentTokens pcd =
, ValueToken "fullysizebalanced" (usev $ limitFullySizeBalanced (repoUUID pcd) (getGroupMap pcd))
] ++ commonTokens LimitAnnexFiles
where
preferreddir = maybe "public" fromProposedAccepted $
preferreddir = toOsPath $ maybe "public" fromProposedAccepted $
M.lookup preferreddirField =<< (`M.lookup` configMap pcd) =<< repoUUID pcd
preferredContentParser :: [ParseToken (MatchFiles Annex)] -> String -> [ParseResult (MatchFiles Annex)]

View file

@ -66,7 +66,7 @@ data LockedDown = LockedDown
data LockDownConfig = LockDownConfig
{ lockingFile :: Bool
-- ^ write bit removed during lock down
, hardlinkFileTmpDir :: Maybe RawFilePath
, hardlinkFileTmpDir :: Maybe OsPath
-- ^ hard link to temp directory
, checkWritePerms :: Bool
-- ^ 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
- write permissions, and Nothing will be returned.
-}
lockDown :: LockDownConfig-> FilePath -> Annex (Maybe LockedDown)
lockDown :: LockDownConfig-> OsPath -> Annex (Maybe LockedDown)
lockDown cfg file = either
(\e -> warning (UnquotedString (show e)) >> return Nothing)
(return . Just)
=<< lockDown' cfg file
lockDown' :: LockDownConfig -> FilePath -> Annex (Either SomeException LockedDown)
lockDown' :: LockDownConfig -> OsPath -> Annex (Either SomeException LockedDown)
lockDown' cfg file = tryNonAsync $ ifM crippledFileSystem
( nohardlink
, case hardlinkFileTmpDir cfg of
@ -101,49 +101,46 @@ lockDown' cfg file = tryNonAsync $ ifM crippledFileSystem
Just tmpdir -> withhardlink tmpdir
)
where
file' = toRawFilePath file
nohardlink = do
setperms
withTSDelta $ liftIO . nohardlink'
nohardlink' delta = do
cache <- genInodeCache file' delta
cache <- genInodeCache file delta
return $ LockedDown cfg $ KeySource
{ keyFilename = file'
, contentLocation = file'
{ keyFilename = file
, contentLocation = file
, inodeCache = cache
}
withhardlink tmpdir = do
setperms
withTSDelta $ \delta -> liftIO $ do
(tmpfile, h) <- openTmpFileIn (toOsPath tmpdir) $
relatedTemplate $ toRawFilePath $
"ingest-" ++ takeFileName file
(tmpfile, h) <- openTmpFileIn tmpdir $
relatedTemplate $ fromOsPath $
literalOsPath "ingest-" <> takeFileName file
hClose h
let tmpfile' = fromOsPath tmpfile
removeWhenExistsWith R.removeLink tmpfile'
withhardlink' delta tmpfile'
removeWhenExistsWith R.removeLink (fromOsPath tmpfile)
withhardlink' delta tmpfile
`catchIO` const (nohardlink' delta)
withhardlink' delta tmpfile = do
R.createLink file' tmpfile
R.createLink (fromOsPath file) (fromOsPath tmpfile)
cache <- genInodeCache tmpfile delta
return $ LockedDown cfg $ KeySource
{ keyFilename = file'
{ keyFilename = file
, contentLocation = tmpfile
, inodeCache = cache
}
setperms = when (lockingFile cfg) $ do
freezeContent file'
freezeContent file
when (checkWritePerms cfg) $ do
qp <- coreQuotePath <$> Annex.getGitConfig
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
Just False -> Just $ "Unable to remove all write permissions from "
<> QuotedPath displayfile
@ -167,7 +164,8 @@ ingestAdd' meterupdate ld@(Just (LockedDown cfg source)) mk = do
then addSymlink f k mic
else do
mode <- liftIO $ catchMaybeIO $
fileMode <$> R.getFileStatus (contentLocation source)
fileMode <$> R.getFileStatus
(fromOsPath (contentLocation source))
stagePointerFile f mode =<< hashPointerFile k
return (Just k)
@ -188,7 +186,7 @@ ingest' preferredbackend meterupdate (Just (LockedDown cfg source)) mk restage =
fst <$> genKey source meterupdate backend
Just k -> return k
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
case (mcache, inodeCache source) of
(_, Nothing) -> go k mcache
@ -263,12 +261,12 @@ populateUnlockedFiles key source restage _ = do
cleanCruft :: KeySource -> Annex ()
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,
-- modifying the file would have caused the object to have the wrong
-- content. Clean up from that.
cleanOldKeys :: RawFilePath -> Key -> Annex ()
cleanOldKeys :: OsPath -> Key -> Annex ()
cleanOldKeys file newkey = do
g <- Annex.gitRepo
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.
- 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
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
-- content in the annex, and make a copy back to the file.
obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key)
unlessM (liftIO $ copyFileExternal CopyTimeStamps obj (fromRawFilePath file)) $
warning $ "Unable to restore content of " <> QuotedPath file <> "; it should be located in " <> QuotedPath (toRawFilePath obj)
obj <- calcRepo (gitAnnexLocation key)
unlessM (liftIO $ copyFileExternal CopyTimeStamps obj file) $
warning $ "Unable to restore content of " <> QuotedPath file <> "; it should be located in " <> QuotedPath obj
thawContent file
throwM e
{- 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
l <- calcRepo $ gitAnnexLink file key
l <- fromOsPath <$> calcRepo (gitAnnexLink file key)
replaceWorkTreeFile file $ makeAnnexLink l
-- touch symlink to have same time as the original file,
-- as provided in the InodeCache
case mcache of
Just c -> liftIO $ touch file (inodeCacheToMtime c) False
Just c -> liftIO $
touch (fromOsPath file) (inodeCacheToMtime c) False
Nothing -> noop
return l
{- 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
genSymlink :: RawFilePath -> Key -> Maybe InodeCache -> Annex Git.Sha
genSymlink :: OsPath -> Key -> Maybe InodeCache -> Annex Git.Sha
genSymlink file key mcache = do
linktarget <- makeLink file key mcache
hashSymlink linktarget
@ -368,12 +367,12 @@ addUnlocked matcher mi contentpresent =
-
- 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))
( do
mode <- maybe
(pure Nothing)
(\tmp -> liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus tmp)
(\tmp -> liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (fromOsPath tmp))
mtmp
stagePointerFile file mode =<< hashPointerFile key
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
- file. The warning avoids a confusing situation where the file got copied
- 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
unlessM (isKnownKey k <||> inAnnex k) $ do
islink <- isJust <$> isAnnexLink f

View file

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

View file

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

View file

@ -40,13 +40,12 @@ import Logs.View
import Utility.Glob
import Types.Command
import CmdLine.Action
import qualified Utility.RawFilePath as R
import qualified Utility.OsString as OS
import qualified Data.Text as T
import qualified Data.ByteString as B
import qualified Data.Set as S
import qualified Data.Map as M
import qualified System.FilePath.ByteString as P
import Control.Concurrent.Async
import "mtl" Control.Monad.Writer
@ -251,7 +250,7 @@ combineViewFilter (ExcludeValues _) new@(FilterGlobOrUnset _ _) = (new, Widening
- evaluate this function with the view parameter and reuse
- 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 =
let matchers = map viewComponentMatcher (viewComponents view)
in \mkviewedfile file metadata ->
@ -260,7 +259,8 @@ viewedFiles view =
then []
else
let paths = pathProduct $
map (map toviewpath) (visible matches)
map (map (toOsPath . toviewpath))
(visible matches)
in if null paths
then [mkviewedfile file]
else map (</> mkviewedfile file) paths
@ -346,7 +346,7 @@ fromViewPath = toMetaValue . encodeBS . deescapepseudo []
prop_viewPath_roundtrips :: MetaValue -> Bool
prop_viewPath_roundtrips v = fromViewPath (toViewPath v) == v
pathProduct :: [[FilePath]] -> [FilePath]
pathProduct :: [[OsPath]] -> [OsPath]
pathProduct [] = []
pathProduct (l:ls) = foldl combinel l ls
where
@ -364,7 +364,7 @@ fromView view f = MetaData $ m `M.difference` derived
filter (not . isviewunset) (zip visible values)
visible = filter viewVisible (viewComponents view)
paths = splitDirectories (dropFileName f)
values = map (S.singleton . fromViewPath) paths
values = map (S.singleton . fromViewPath . fromOsPath) paths
MetaData derived = getViewedFileMetaData f
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 Nothing) _ _ = True
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
, all hasfields (viewedFiles view (viewedFileFromReference' Nothing Nothing) (fromRawFilePath f) metadata)
, all hasfields (viewedFiles view (viewedFileFromReference' Nothing Nothing) f metadata)
]
where
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.
- This is necessary to have a 1:1 mapping between directory names and
- fields. So this MetaData cannot safely be serialized. -}
getDirMetaData :: FilePath -> MetaData
getDirMetaData :: OsPath -> MetaData
getDirMetaData d = MetaData $ M.fromList $ zip fields values
where
dirs = splitDirectories d
fields = map (mkMetaFieldUnchecked . T.pack . addTrailingPathSeparator . joinPath)
fields = map (mkMetaFieldUnchecked . T.pack . fromOsPath . addTrailingPathSeparator . joinPath)
(inits dirs)
values = map (S.singleton . toMetaValue . encodeBS . fromMaybe "" . headMaybe)
(tails dirs)
(tails (map fromOsPath dirs))
getWorkTreeMetaData :: FilePath -> MetaData
getWorkTreeMetaData :: OsPath -> MetaData
getWorkTreeMetaData = getDirMetaData . dropFileName
getViewedFileMetaData :: FilePath -> MetaData
getViewedFileMetaData :: OsPath -> MetaData
getViewedFileMetaData = getDirMetaData . dirFromViewedFile . takeFileName
{- 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,
- 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
top <- fromRepo Git.repoPath
(l, clean) <- inRepo $ Git.LsFiles.inRepoDetails [] [top]
@ -452,7 +452,7 @@ applyView' mkviewedfile getfilemetadata view madj = do
applyView''
:: MkViewedFile
-> (FilePath -> MetaData)
-> (OsPath -> MetaData)
-> View
-> Maybe Adjustment
-> [t]
@ -488,18 +488,18 @@ applyView'' mkviewedfile getfilemetadata view madj l clean conv = do
-- Git.UpdateIndex.streamUpdateIndex'
-- here would race with process's calls
-- to it.
| "." `B.isPrefixOf` getTopFilePath topf ->
feed "dummy"
| literalOsPath "." `OS.isPrefixOf` getTopFilePath topf ->
feed (literalOsPath "dummy")
| otherwise -> noop
getmetadata gc mdfeeder mdcloser ts
process uh mdreader = liftIO mdreader >>= \case
Just ((topf, _, mtreeitemtype, Just k), mdlog) -> do
let metadata = maybe emptyMetaData parseCurrentMetaData mdlog
let f = fromRawFilePath $ getTopFilePath topf
let f = getTopFilePath topf
let metadata' = getfilemetadata f `unionMetaData` metadata
forM_ (genviewedfiles f metadata') $ \fv -> do
f' <- fromRepo (fromTopFilePath $ asTopFilePath $ toRawFilePath fv)
f' <- fromRepo (fromTopFilePath $ asTopFilePath fv)
stagefile uh f' k mtreeitemtype
process uh mdreader
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 = do
linktarget <- calcRepo (gitAnnexLink f k)
linktarget <- fromOsPath <$> calcRepo (gitAnnexLink f k)
sha <- hashSymlink linktarget
liftIO . Git.UpdateIndex.streamUpdateIndex' uh
=<< inRepo (Git.UpdateIndex.stageSymlink f sha)
@ -609,7 +609,7 @@ withViewChanges addmeta removemeta = do
=<< catKey (DiffTree.dstsha item)
| otherwise = 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.
- 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 a = do
liftIO . removeWhenExistsWith R.removeLink =<< fromRepo gitAnnexViewIndex
liftIO . removeWhenExistsWith removeFile
=<< fromRepo gitAnnexViewIndex
withViewIndex a
{- Generates a branch for a view, using the view index file

View file

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

View file

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

View file

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

View file

@ -48,6 +48,7 @@ import qualified Database.Keys
import qualified Utility.RawFilePath as R
import Utility.Tuple
import Utility.HumanTime
import qualified Utility.OsString as OS
import Control.Concurrent.Async
import Control.Concurrent.STM
@ -55,11 +56,9 @@ import System.Posix.Types
import Data.IORef
import Data.Time.Clock.POSIX
import System.PosixCompat.Files (isDirectory, isSymbolicLink, deviceID, fileID)
import qualified System.FilePath.ByteString as P
import qualified Data.ByteString as S
data AnnexedFileSeeker = AnnexedFileSeeker
{ startAction :: Maybe KeySha -> SeekInput -> RawFilePath -> Key -> CommandStart
{ startAction :: Maybe KeySha -> SeekInput -> OsPath -> Key -> CommandStart
, checkContentPresent :: Maybe 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 (p:ps) = do
os <- seekOptions ww
(fs, cleanup) <- inRepo $ LsFiles.inRepoDetails os [toRawFilePath p]
(fs, cleanup) <- inRepo $ LsFiles.inRepoDetails os [toOsPath p]
r <- case fs of
[f] -> do
propagateLsFilesError cleanup
@ -96,18 +95,18 @@ withFilesInGitAnnexNonRecursive ww needforce a (WorkTreeItems l) = ifM (Annex.ge
return (r, pure True)
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
force <- Annex.getRead Annex.force
let include_ignored = force || not ci
seekFiltered (const (pure True)) a $
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
matcher <- Limit.getMatcher
checktimelimit <- mkCheckTimeLimit
go matcher checktimelimit params []
go matcher checktimelimit (map toOsPath params) []
where
go _ _ [] [] = return ()
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,
-- the same as it fails if the path that the user provided does not
-- exist.
get p = ifM (isDirectory <$> R.getFileStatus p')
get p = ifM (isDirectory <$> R.getFileStatus (fromOsPath p))
( map (\f ->
(f, P.makeRelative (P.takeDirectory (P.dropTrailingPathSeparator p')) f))
<$> dirContentsRecursiveSkipping (".git" `S.isSuffixOf`) False p'
, return [(p', P.takeFileName p')]
(f, makeRelative (takeDirectory (dropTrailingPathSeparator p)) f))
<$> dirContentsRecursiveSkipping (literalOsPath ".git" `OS.isSuffixOf`) False p
, return [(p, takeFileName p)]
)
where
p' = toRawFilePath p
checkmatch matcher (f, relf) = matcher $ MatchingFile $ FileInfo
{ contentFile = f
@ -150,24 +147,24 @@ withPairs a params = sequence_ $
pairs c (x:y:xs) = pairs ((x,y):c) xs
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 $
seekHelper id ww (const LsFiles.stagedNotDeleted) l
{- unlocked pointer files that are staged, and whose content has not been
- modified-}
withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> ((SeekInput, OsPath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
withUnmodifiedUnlockedPointers ww a l =
seekFiltered (isUnmodifiedUnlocked . snd) a $
seekHelper id ww (const LsFiles.typeChangedStaged) l
isUnmodifiedUnlocked :: RawFilePath -> Annex Bool
isUnmodifiedUnlocked :: OsPath -> Annex Bool
isUnmodifiedUnlocked f = catKeyFile f >>= \case
Nothing -> return False
Just k -> sameInodeCache f =<< Database.Keys.getInodeCaches k
{- 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 $
seekHelper id ww LsFiles.modified params
@ -320,7 +317,7 @@ withKeyOptions' ko auto mkkeyaction fallbackaction worktreeitems = do
forM_ ts $ \(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
matcher <- Limit.getMatcher
checktimelimit <- mkCheckTimeLimit
@ -351,7 +348,7 @@ checkMatcherWhen mi c i a
-- because of the way data is streamed through git cat-file.
--
-- 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
g <- Annex.gitRepo
mi <- MatcherInfo
@ -465,7 +462,7 @@ seekFilteredKeys seeker listfs = do
-- Check if files exist, because a deleted file will still be
-- 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
Just ((si, f), Just (sha, size, _type))
@ -485,18 +482,18 @@ seekFilteredKeys seeker listfs = do
null <$> Annex.Branch.getUnmergedRefs
| 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
os <- seekOptions ww
v <- liftIO $ newIORef []
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)
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
-- 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
(ls, cleanup) <- a os fs g
@ -561,7 +558,7 @@ workTreeItems' (AllowHidden allowhidden) ww ps = case ww of
currbranch <- getCurrentBranch
stopattop <- prepviasymlink
ps' <- flip filterM ps $ \p -> do
let p' = toRawFilePath p
let p' = toOsPath p
relf <- liftIO $ relPathCwdToFile p'
ifM (not <$> (exists p' <||> hidden currbranch relf))
( prob action FileNotFound p' "not found"
@ -574,13 +571,13 @@ workTreeItems' (AllowHidden allowhidden) ww ps = case ww of
then return NoWorkTreeItems
else return (WorkTreeItems ps')
exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus p)
exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus $ fromOsPath p)
prepviasymlink = do
repotopst <- inRepo $
maybe
(pure Nothing)
(catchMaybeIO . R.getSymbolicLinkStatus)
(catchMaybeIO . R.getSymbolicLinkStatus . fromOsPath)
. Git.repoWorkTree
return $ \st -> case repotopst of
Nothing -> False
@ -589,7 +586,7 @@ workTreeItems' (AllowHidden allowhidden) ww ps = case ww of
viasymlink _ Nothing = return False
viasymlink stopattop (Just p) = do
st <- liftIO $ R.getSymbolicLinkStatus p
st <- liftIO $ R.getSymbolicLinkStatus $ fromOsPath p
if stopattop st
then return False
else if isSymbolicLink st
@ -602,12 +599,12 @@ workTreeItems' (AllowHidden allowhidden) ww ps = case ww of
| otherwise = return False
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
return False
notSymlink :: RawFilePath -> IO Bool
notSymlink f = liftIO $ not . isSymbolicLink <$> R.getSymbolicLinkStatus f
notSymlink :: OsPath -> IO Bool
notSymlink f = liftIO $ not . isSymbolicLink <$> R.getSymbolicLinkStatus (fromOsPath f)
{- 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

View file

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

View file

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