more OsPath conversion (520/749)
Sponsored-by: mycroft
This commit is contained in:
Joey Hess
parent
9394197621
commit
0d2b805806
11 changed files with 141 additions and 148 deletions
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
45
Limit.hs
45
Limit.hs
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue