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

more OsPath conversion (572/749)

Browse source 
Sponsored-by: Jack Hill
This commit is contained in:
Joey Hess 2025-02-06 16:18:52 -04:00
parent cb2c069ad1
commit 2d1db7986c
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
18 changed files with 99 additions and 96 deletions
Download patch file Download diff file Expand all files Collapse all files

21
Command/P2P.hs
View file

@ -25,7 +25,6 @@ import Utility.Tmp.Dir
import Utility.FileMode import Utility.FileMode
import Utility.ThreadScheduler import Utility.ThreadScheduler
import Utility.SafeOutput import Utility.SafeOutput
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F import qualified Utility.FileIO as F
import qualified Utility.MagicWormhole as Wormhole import qualified Utility.MagicWormhole as Wormhole
@ -220,12 +219,12 @@ wormholePairing remotename ouraddrs ui = do
-- files. Permissions of received files may allow others -- files. Permissions of received files may allow others
-- to read them. So, set up a temp directory that only -- to read them. So, set up a temp directory that only
-- we can read. -- we can read.
withTmpDir (toOsPath "pair") $ \tmp -> do withTmpDir (literalOsPath "pair") $ \tmp -> do
liftIO $ void $ tryIO $ modifyFileMode (toRawFilePath tmp) $ liftIO $ void $ tryIO $ modifyFileMode tmp $
removeModes otherGroupModes removeModes otherGroupModes
let sendf = tmp </> "send" let sendf = tmp </> literalOsPath "send"
let recvf = tmp </> "recv" let recvf = tmp </> literalOsPath "recv"
liftIO $ writeFileProtected (toRawFilePath sendf) $ liftIO $ writeFileProtected sendf $
serializePairData ourpairdata serializePairData ourpairdata
observer <- liftIO Wormhole.mkCodeObserver observer <- liftIO Wormhole.mkCodeObserver
@ -235,18 +234,18 @@ wormholePairing remotename ouraddrs ui = do
-- the same channels that other wormhole users use. -- the same channels that other wormhole users use.
let appid = Wormhole.appId "git-annex.branchable.com/p2p-setup" let appid = Wormhole.appId "git-annex.branchable.com/p2p-setup"
(sendres, recvres) <- liftIO $ (sendres, recvres) <- liftIO $
Wormhole.sendFile sendf observer appid Wormhole.sendFile (fromOsPath sendf) observer appid
`concurrently` `concurrently`
Wormhole.receiveFile recvf producer appid Wormhole.receiveFile (fromOsPath recvf) producer appid
liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath sendf) liftIO $ removeWhenExistsWith removeFile sendf
if sendres /= True if sendres /= True
then return SendFailed then return SendFailed
else if recvres /= True else if recvres /= True
then return ReceiveFailed then return ReceiveFailed
else do else do
r <- liftIO $ tryIO $ r <- liftIO $ tryIO $
map decodeBS . fileLines' <$> F.readFile' map decodeBS . fileLines'
(toOsPath (toRawFilePath recvf)) <$> F.readFile' recvf
case r of case r of
Left _e -> return ReceiveFailed Left _e -> return ReceiveFailed
Right ls -> maybe Right ls -> maybe

2
Command/P2PHttp.hs
View file

@ -267,7 +267,7 @@ getAuthEnv = do
findRepos :: Options -> IO [Git.Repo] findRepos :: Options -> IO [Git.Repo]
findRepos o = do findRepos o = do
files <- concat files <- concat
<$> mapM (dirContents . toRawFilePath) (directoryOption o) <$> mapM (dirContents . toOsPath) (directoryOption o)
map Git.Construct.newFrom . catMaybes map Git.Construct.newFrom . catMaybes
<$> mapM Git.Construct.checkForRepo files <$> mapM Git.Construct.checkForRepo files

19
Command/ReKey.hs
View file

@ -44,7 +44,7 @@ optParser desc = ReKeyOptions
-- Split on the last space, since a FilePath can contain whitespace, -- Split on the last space, since a FilePath can contain whitespace,
-- but a Key very rarely does. -- but a Key very rarely does.
batchParser :: String -> Annex (Either String (RawFilePath, Key)) batchParser :: String -> Annex (Either String (OsPath, Key))
batchParser s = case separate (== ' ') (reverse s) of batchParser s = case separate (== ' ') (reverse s) of
(rk, rf) (rk, rf)
| null rk || null rf -> return $ Left "Expected: \"file key\"" | null rk || null rf -> return $ Left "Expected: \"file key\""
@ -52,7 +52,7 @@ batchParser s = case separate (== ' ') (reverse s) of
Nothing -> return $ Left "bad key" Nothing -> return $ Left "bad key"
Just k -> do Just k -> do
let f = reverse rf let f = reverse rf
f' <- liftIO $ relPathCwdToFile (toRawFilePath f) f' <- liftIO $ relPathCwdToFile (toOsPath f)
return $ Right (f', k) return $ Right (f', k)
seek :: ReKeyOptions -> CommandSeek seek :: ReKeyOptions -> CommandSeek
@ -65,9 +65,9 @@ seek o = case batchOption o of
(reKeyThese o) (reKeyThese o)
where where
parsekey (file, skey) = parsekey (file, skey) =
(toRawFilePath file, fromMaybe (giveup "bad key") (deserializeKey skey)) (toOsPath file, fromMaybe (giveup "bad key") (deserializeKey skey))
start :: SeekInput -> (RawFilePath, Key) -> CommandStart start :: SeekInput -> (OsPath, Key) -> CommandStart
start si (file, newkey) = lookupKey file >>= \case start si (file, newkey) = lookupKey file >>= \case
Just k -> go k Just k -> go k
Nothing -> stop Nothing -> stop
@ -79,7 +79,7 @@ start si (file, newkey) = lookupKey file >>= \case
ai = ActionItemTreeFile file ai = ActionItemTreeFile file
perform :: RawFilePath -> Key -> Key -> CommandPerform perform :: OsPath -> Key -> Key -> CommandPerform
perform file oldkey newkey = do perform file oldkey newkey = do
ifM (inAnnex oldkey) ifM (inAnnex oldkey)
( unlessM (linkKey file oldkey newkey) $ ( unlessM (linkKey file oldkey newkey) $
@ -93,7 +93,7 @@ perform file oldkey newkey = do
{- Make a hard link to the old key content (when supported), {- Make a hard link to the old key content (when supported),
- to avoid wasting disk space. -} - to avoid wasting disk space. -}
linkKey :: RawFilePath -> Key -> Key -> Annex Bool linkKey :: OsPath -> Key -> Key -> Annex Bool
linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file) linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file)
( linkKey' DefaultVerify oldkey newkey ( linkKey' DefaultVerify oldkey newkey
, do , do
@ -101,7 +101,7 @@ linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file)
- it's hard linked to the old key, that link must be broken. -} - it's hard linked to the old key, that link must be broken. -}
oldobj <- calcRepo (gitAnnexLocation oldkey) oldobj <- calcRepo (gitAnnexLocation oldkey)
v <- tryNonAsync $ do v <- tryNonAsync $ do
st <- liftIO $ R.getFileStatus file st <- liftIO $ R.getFileStatus (fromOsPath file)
when (linkCount st > 1) $ do when (linkCount st > 1) $ do
freezeContent oldobj freezeContent oldobj
replaceWorkTreeFile file $ \tmp -> do replaceWorkTreeFile file $ \tmp -> do
@ -132,7 +132,7 @@ linkKey' v oldkey newkey =
oldobj <- calcRepo (gitAnnexLocation oldkey) oldobj <- calcRepo (gitAnnexLocation oldkey)
isJust <$> linkOrCopy' (return True) newkey oldobj tmp Nothing isJust <$> linkOrCopy' (return True) newkey oldobj tmp Nothing
cleanup :: RawFilePath -> Key -> (MigrationRecord -> Annex ()) -> CommandCleanup cleanup :: OsPath -> Key -> (MigrationRecord -> Annex ()) -> CommandCleanup
cleanup file newkey a = do cleanup file newkey a = do
newkeyrec <- ifM (isJust <$> isAnnexLink file) newkeyrec <- ifM (isJust <$> isAnnexLink file)
( do ( do
@ -141,7 +141,8 @@ cleanup file newkey a = do
stageSymlink file sha stageSymlink file sha
return (MigrationRecord sha) return (MigrationRecord sha)
, do , do
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file mode <- liftIO $ catchMaybeIO $
fileMode <$> R.getFileStatus (fromOsPath file)
liftIO $ whenM (isJust <$> isPointerFile file) $ liftIO $ whenM (isJust <$> isPointerFile file) $
writePointerFile file newkey mode writePointerFile file newkey mode
sha <- hashPointerFile newkey sha <- hashPointerFile newkey

2
Command/RecvKey.hs
View file

@ -39,4 +39,4 @@ start (_, key) = fieldTransfer Download key $ \_p -> do
go tmp = unVerified $ do go tmp = unVerified $ do
opts <- filterRsyncSafeOptions . maybe [] words opts <- filterRsyncSafeOptions . maybe [] words
<$> getField "RsyncOptions" <$> getField "RsyncOptions"
liftIO $ rsyncServerReceive (map Param opts) (fromRawFilePath tmp) liftIO $ rsyncServerReceive (map Param opts) (fromOsPath tmp)

16
Command/Reinject.hs
View file

@ -57,26 +57,26 @@ startSrcDest :: (SeekInput, (String, String)) -> CommandStart
startSrcDest (si, (src, dest)) startSrcDest (si, (src, dest))
| src == dest = stop | src == dest = stop
| otherwise = starting "reinject" ai si $ notAnnexed src' $ | otherwise = starting "reinject" ai si $ notAnnexed src' $
lookupKey (toRawFilePath dest) >>= \case lookupKey (toOsPath dest) >>= \case
Just key -> ifM (verifyKeyContent key src') Just key -> ifM (verifyKeyContent key src')
( perform src' key ( perform src' key
, do , do
qp <- coreQuotePath <$> Annex.getGitConfig qp <- coreQuotePath <$> Annex.getGitConfig
giveup $ decodeBS $ quote qp $ QuotedPath src' giveup $ decodeBS $ quote qp $ QuotedPath src'
<> " does not have expected content of " <> " does not have expected content of "
<> QuotedPath (toRawFilePath dest) <> QuotedPath (toOsPath dest)
) )
Nothing -> do Nothing -> do
qp <- coreQuotePath <$> Annex.getGitConfig qp <- coreQuotePath <$> Annex.getGitConfig
giveup $ decodeBS $ quote qp $ QuotedPath src' giveup $ decodeBS $ quote qp $ QuotedPath src'
<> " is not an annexed file" <> " is not an annexed file"
where where
src' = toRawFilePath src src' = toOsPath src
ai = ActionItemOther (Just (QuotedPath src')) ai = ActionItemOther (Just (QuotedPath src'))
startGuessKeys :: FilePath -> CommandStart startGuessKeys :: FilePath -> CommandStart
startGuessKeys src = starting "reinject" ai si $ notAnnexed src' $ startGuessKeys src = starting "reinject" ai si $ notAnnexed src' $
case fileKey (toRawFilePath (takeFileName src)) of case fileKey (takeFileName src') of
Just key -> ifM (verifyKeyContent key src') Just key -> ifM (verifyKeyContent key src')
( perform src' key ( perform src' key
, do , do
@ -88,7 +88,7 @@ startGuessKeys src = starting "reinject" ai si $ notAnnexed src' $
warning "Not named like an object file; skipping" warning "Not named like an object file; skipping"
next $ return True next $ return True
where where
src' = toRawFilePath src src' = toOsPath src
ai = ActionItemOther (Just (QuotedPath src')) ai = ActionItemOther (Just (QuotedPath src'))
si = SeekInput [src] si = SeekInput [src]
@ -102,12 +102,12 @@ startKnown src = starting "reinject" ai si $ notAnnexed src' $ do
next $ return True next $ return True
) )
where where
src' = toRawFilePath src src' = toOsPath src
ks = KeySource src' src' Nothing ks = KeySource src' src' Nothing
ai = ActionItemOther (Just (QuotedPath src')) ai = ActionItemOther (Just (QuotedPath src'))
si = SeekInput [src] si = SeekInput [src]
notAnnexed :: RawFilePath -> CommandPerform -> CommandPerform notAnnexed :: OsPath -> CommandPerform -> CommandPerform
notAnnexed src a = notAnnexed src a =
ifM (fromRepo Git.repoIsLocalBare) ifM (fromRepo Git.repoIsLocalBare)
( a ( a
@ -120,7 +120,7 @@ notAnnexed src a =
Nothing -> a Nothing -> a
) )
perform :: RawFilePath -> Key -> CommandPerform perform :: OsPath -> Key -> CommandPerform
perform src key = do perform src key = do
maybeAddJSONField "key" (serializeKey key) maybeAddJSONField "key" (serializeKey key)
ifM move ifM move

2
Command/RemoteDaemon.hs
View file

@ -29,7 +29,7 @@ run o
| foregroundDaemonOption o = liftIO runInteractive | foregroundDaemonOption o = liftIO runInteractive
| otherwise = do | otherwise = do
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
git_annex <- liftIO programPath git_annex <- fromOsPath <$> liftIO programPath
ps <- gitAnnexDaemonizeParams ps <- gitAnnexDaemonizeParams
let logfd = openFdWithMode (toRawFilePath "/dev/null") ReadOnly Nothing defaultFileFlags let logfd = openFdWithMode (toRawFilePath "/dev/null") ReadOnly Nothing defaultFileFlags
liftIO $ daemonize git_annex ps logfd Nothing False runNonInteractive liftIO $ daemonize git_annex ps logfd Nothing False runNonInteractive

3
Command/Repair.hs
View file

@ -14,7 +14,6 @@ import qualified Annex.Branch
import qualified Git.Ref import qualified Git.Ref
import Git.Types import Git.Types
import Annex.Version import Annex.Version
import qualified Utility.RawFilePath as R
cmd :: Command cmd :: Command
cmd = noCommit $ dontCheck repoExists $ cmd = noCommit $ dontCheck repoExists $
@ -76,7 +75,7 @@ repairAnnexBranch modifiedbranches
Annex.Branch.forceCommit "committing index after git repository repair" Annex.Branch.forceCommit "committing index after git repository repair"
liftIO $ putStrLn "Successfully recovered the git-annex branch using .git/annex/index" liftIO $ putStrLn "Successfully recovered the git-annex branch using .git/annex/index"
nukeindex = do nukeindex = do
inRepo $ removeWhenExistsWith R.removeLink . gitAnnexIndex inRepo $ removeWhenExistsWith removeFile . gitAnnexIndex
liftIO $ putStrLn "Had to delete the .git/annex/index file as it was corrupt." liftIO $ putStrLn "Had to delete the .git/annex/index file as it was corrupt."
missingbranch = liftIO $ putStrLn "Since the git-annex branch is not up-to-date anymore. It would be a very good idea to run: git annex fsck --fast" missingbranch = liftIO $ putStrLn "Since the git-annex branch is not up-to-date anymore. It would be a very good idea to run: git annex fsck --fast"

6
Command/ResolveMerge.hs
View file

@ -16,8 +16,6 @@ import qualified Git.Branch
import Annex.AutoMerge import Annex.AutoMerge
import qualified Utility.FileIO as F import qualified Utility.FileIO as F
import qualified System.FilePath.ByteString as P
cmd :: Command cmd :: Command
cmd = command "resolvemerge" SectionPlumbing cmd = command "resolvemerge" SectionPlumbing
"resolve merge conflicts" "resolve merge conflicts"
@ -30,7 +28,7 @@ start :: CommandStart
start = starting "resolvemerge" (ActionItemOther Nothing) (SeekInput []) $ do start = starting "resolvemerge" (ActionItemOther Nothing) (SeekInput []) $ do
us <- fromMaybe nobranch <$> inRepo Git.Branch.current us <- fromMaybe nobranch <$> inRepo Git.Branch.current
d <- fromRepo Git.localGitDir d <- fromRepo Git.localGitDir
let merge_head = toOsPath $ d P.</> "MERGE_HEAD" let merge_head = d </> literalOsPath "MERGE_HEAD"
them <- fromMaybe (giveup nomergehead) . extractSha them <- fromMaybe (giveup nomergehead) . extractSha
<$> liftIO (F.readFile' merge_head) <$> liftIO (F.readFile' merge_head)
ifM (resolveMerge (Just us) them False) ifM (resolveMerge (Just us) them False)
@ -41,4 +39,4 @@ start = starting "resolvemerge" (ActionItemOther Nothing) (SeekInput []) $ do
) )
where where
nobranch = giveup "No branch is currently checked out." nobranch = giveup "No branch is currently checked out."
nomergehead = giveup "No SHA found in .git/merge_head" nomergehead = giveup "No SHA found in .git/MERGE_HEAD"

21
Command/RmUrl.hs
View file

@ -32,29 +32,28 @@ seek :: RmUrlOptions -> CommandSeek
seek o = case batchOption o of seek o = case batchOption o of
Batch fmt -> batchOnly Nothing (rmThese o) $ Batch fmt -> batchOnly Nothing (rmThese o) $
batchInput fmt batchParser (batchCommandAction . start) batchInput fmt batchParser (batchCommandAction . start)
NoBatch -> withPairs (commandAction . start) (rmThese o) NoBatch -> withPairs (commandAction . start . conv) (rmThese o)
where
conv (si, (f, u)) = (si, (toOsPath f, u))
-- Split on the last space, since a FilePath can contain whitespace, -- Split on the last space, since a OsPath can contain whitespace,
-- but a url should not. -- but a url should not.
batchParser :: String -> Annex (Either String (FilePath, URLString)) batchParser :: String -> Annex (Either String (OsPath, URLString))
batchParser s = case separate (== ' ') (reverse s) of batchParser s = case separate (== ' ') (reverse s) of
(ru, rf) (ru, rf)
| null ru || null rf -> return $ Left "Expected: \"file url\"" | null ru || null rf -> return $ Left "Expected: \"file url\""
| otherwise -> do | otherwise -> do
let f = reverse rf let f = toOsPath (reverse rf)
f' <- liftIO $ fromRawFilePath f' <- liftIO $ relPathCwdToFile f
<$> relPathCwdToFile (toRawFilePath f)
return $ Right (f', reverse ru) return $ Right (f', reverse ru)
start :: (SeekInput, (FilePath, URLString)) -> CommandStart start :: (SeekInput, (OsPath, URLString)) -> CommandStart
start (si, (file, url)) = lookupKeyStaged file' >>= \case start (si, (file, url)) = lookupKeyStaged file >>= \case
Nothing -> stop Nothing -> stop
Just key -> do Just key -> do
let ai = mkActionItem (key, AssociatedFile (Just file')) let ai = mkActionItem (key, AssociatedFile (Just file))
starting "rmurl" ai si $ starting "rmurl" ai si $
next $ cleanup url key next $ cleanup url key
where
file' = toRawFilePath file
cleanup :: String -> Key -> CommandCleanup cleanup :: String -> Key -> CommandCleanup
cleanup url key = do cleanup url key = do

4
Command/SendKey.hs
View file

@ -33,7 +33,9 @@ start (_, key) = do
ifM (inAnnex key) ifM (inAnnex key)
( fieldTransfer Upload key $ \_p -> ( fieldTransfer Upload key $ \_p ->
sendAnnex key Nothing rollback $ \f _sz -> sendAnnex key Nothing rollback $ \f _sz ->
liftIO $ rsyncServerSend (map Param opts) f liftIO $ rsyncServerSend
(map Param opts)
(fromOsPath f)
, do , do
warning "requested key is not present" warning "requested key is not present"
liftIO exitFailure liftIO exitFailure

4
Command/SetKey.hs
View file

@ -25,13 +25,13 @@ start ps@(keyname:file:[]) = starting "setkey" ai si $
where where
ai = ActionItemOther (Just (QuotedPath file')) ai = ActionItemOther (Just (QuotedPath file'))
si = SeekInput ps si = SeekInput ps
file' = toRawFilePath file file' = toOsPath file
start _ = giveup "specify a key and a content file" start _ = giveup "specify a key and a content file"
keyOpt :: String -> Key keyOpt :: String -> Key
keyOpt = fromMaybe (giveup "bad key") . deserializeKey keyOpt = fromMaybe (giveup "bad key") . deserializeKey
perform :: RawFilePath -> Key -> CommandPerform perform :: OsPath -> Key -> CommandPerform
perform file key = do perform file key = do
-- the file might be on a different filesystem, so moveFile is used -- the file might be on a different filesystem, so moveFile is used
-- rather than simply calling moveAnnex; disk space is also -- rather than simply calling moveAnnex; disk space is also

24
Command/Smudge.hs
View file

@ -44,7 +44,7 @@ cmd = noCommit $ noMessages $
paramFile (seek <$$> optParser) paramFile (seek <$$> optParser)
data SmudgeOptions = UpdateOption | SmudgeOptions data SmudgeOptions = UpdateOption | SmudgeOptions
{ smudgeFile :: FilePath { smudgeFile :: OsPath
, cleanOption :: Bool , cleanOption :: Bool
} }
@ -52,14 +52,14 @@ optParser :: CmdParamsDesc -> Parser SmudgeOptions
optParser desc = smudgeoptions <|> updateoption optParser desc = smudgeoptions <|> updateoption
where where
smudgeoptions = SmudgeOptions smudgeoptions = SmudgeOptions
<$> argument str ( metavar desc ) <$> (stringToOsPath <$> argument str ( metavar desc ))
<*> switch ( long "clean" <> help "clean filter" ) <*> switch ( long "clean" <> help "clean filter" )
updateoption = flag' UpdateOption updateoption = flag' UpdateOption
( long "update" <> help "populate annexed worktree files" ) ( long "update" <> help "populate annexed worktree files" )
seek :: SmudgeOptions -> CommandSeek seek :: SmudgeOptions -> CommandSeek
seek (SmudgeOptions f False) = commandAction (smudge f) seek (SmudgeOptions f False) = commandAction (smudge f)
seek (SmudgeOptions f True) = commandAction (clean (toRawFilePath f)) seek (SmudgeOptions f True) = commandAction (clean f)
seek UpdateOption = commandAction update seek UpdateOption = commandAction update
-- Smudge filter is fed git file content, and if it's a pointer to an -- Smudge filter is fed git file content, and if it's a pointer to an
@ -73,7 +73,7 @@ seek UpdateOption = commandAction update
-- * To support annex.thin -- * To support annex.thin
-- * Because git currently buffers the whole object received from the -- * Because git currently buffers the whole object received from the
-- smudge filter in memory, which is a problem with large files. -- smudge filter in memory, which is a problem with large files.
smudge :: FilePath -> CommandStart smudge :: OsPath -> CommandStart
smudge file = do smudge file = do
b <- liftIO $ L.hGetContents stdin b <- liftIO $ L.hGetContents stdin
smudge' file b smudge' file b
@ -81,18 +81,18 @@ smudge file = do
stop stop
-- Handles everything except the IO of the file content. -- Handles everything except the IO of the file content.
smudge' :: FilePath -> L.ByteString -> Annex () smudge' :: OsPath -> L.ByteString -> Annex ()
smudge' file b = case parseLinkTargetOrPointerLazy b of smudge' file b = case parseLinkTargetOrPointerLazy b of
Nothing -> noop Nothing -> noop
Just k -> do Just k -> do
topfile <- inRepo (toTopFilePath (toRawFilePath file)) topfile <- inRepo (toTopFilePath file)
Database.Keys.addAssociatedFile k topfile Database.Keys.addAssociatedFile k topfile
void $ smudgeLog k topfile void $ smudgeLog k topfile
-- Clean filter is fed file content on stdin, decides if a file -- Clean filter is fed file content on stdin, decides if a file
-- should be stored in the annex, and outputs a pointer to its -- should be stored in the annex, and outputs a pointer to its
-- injested content if so. Otherwise, the original content. -- injested content if so. Otherwise, the original content.
clean :: RawFilePath -> CommandStart clean :: OsPath -> CommandStart
clean file = do clean file = do
Annex.BranchState.disableUpdate -- optimisation Annex.BranchState.disableUpdate -- optimisation
b <- liftIO $ L.hGetContents stdin b <- liftIO $ L.hGetContents stdin
@ -116,7 +116,7 @@ clean file = do
-- Handles everything except the IO of the file content. -- Handles everything except the IO of the file content.
clean' clean'
:: RawFilePath :: OsPath
-> Either InvalidAppendedPointerFile (Maybe Key) -> Either InvalidAppendedPointerFile (Maybe Key)
-- ^ If the content provided by git is an annex pointer, -- ^ If the content provided by git is an annex pointer,
-- this is the key it points to. -- this is the key it points to.
@ -188,7 +188,7 @@ clean' file mk passthrough discardreststdin emitpointer =
emitpointer emitpointer
=<< postingest =<< postingest
=<< (\ld -> ingest' preferredbackend nullMeterUpdate ld Nothing norestage) =<< (\ld -> ingest' preferredbackend nullMeterUpdate ld Nothing norestage)
=<< lockDown cfg (fromRawFilePath file) =<< lockDown cfg file
postingest (Just k, _) = do postingest (Just k, _) = do
logStatus NoLiveUpdate k InfoPresent logStatus NoLiveUpdate k InfoPresent
@ -203,7 +203,7 @@ clean' file mk passthrough discardreststdin emitpointer =
-- git diff can run the clean filter on files outside the -- git diff can run the clean filter on files outside the
-- repository; can't annex those -- repository; can't annex those
fileOutsideRepo :: RawFilePath -> Annex Bool fileOutsideRepo :: OsPath -> Annex Bool
fileOutsideRepo file = do fileOutsideRepo file = do
repopath <- liftIO . absPath =<< fromRepo Git.repoPath repopath <- liftIO . absPath =<< fromRepo Git.repoPath
filepath <- liftIO $ absPath file filepath <- liftIO $ absPath file
@ -232,7 +232,7 @@ inSmudgeCleanFilter = bracket setup cleanup . const
-- in the index, and has the same content, leave it in git. -- in the index, and has the same content, leave it in git.
-- This handles cases such as renaming a file followed by git add, -- This handles cases such as renaming a file followed by git add,
-- which the user naturally expects to behave the same as git mv. -- which the user naturally expects to behave the same as git mv.
shouldAnnex :: RawFilePath -> Maybe (Sha, FileSize, ObjectType) -> Maybe Key -> Annex Bool shouldAnnex :: OsPath -> Maybe (Sha, FileSize, ObjectType) -> Maybe Key -> Annex Bool
shouldAnnex file indexmeta moldkey = do shouldAnnex file indexmeta moldkey = do
ifM (annexGitAddToAnnex <$> Annex.getGitConfig) ifM (annexGitAddToAnnex <$> Annex.getGitConfig)
( checkunchanged $ checkmatcher checkwasannexed ( checkunchanged $ checkmatcher checkwasannexed
@ -299,7 +299,7 @@ shouldAnnex file indexmeta moldkey = do
-- This also handles the case where a copy of a pointer file is made, -- This also handles the case where a copy of a pointer file is made,
-- then git-annex gets the content, and later git add is run on -- then git-annex gets the content, and later git add is run on
-- the pointer copy. It will then be populated with the content. -- the pointer copy. It will then be populated with the content.
getMoveRaceRecovery :: Key -> RawFilePath -> Annex () getMoveRaceRecovery :: Key -> OsPath -> Annex ()
getMoveRaceRecovery k file = void $ tryNonAsync $ getMoveRaceRecovery k file = void $ tryNonAsync $
whenM (inAnnex k) $ do whenM (inAnnex k) $ do
obj <- calcRepo (gitAnnexLocation k) obj <- calcRepo (gitAnnexLocation k)

2
Command/Status.hs
View file

@ -66,6 +66,6 @@ displayStatus s = do
absf <- fromRepo $ fromTopFilePath (statusFile s) absf <- fromRepo $ fromTopFilePath (statusFile s)
f <- liftIO $ relPathCwdToFile absf f <- liftIO $ relPathCwdToFile absf
qp <- coreQuotePath <$> Annex.getGitConfig qp <- coreQuotePath <$> Annex.getGitConfig
unlessM (showFullJSON $ JSONChunk [("status", [c]), ("file", fromRawFilePath f)]) $ unlessM (showFullJSON $ JSONChunk [("status", [c]), ("file", fromOsPath f)]) $
liftIO $ B8.putStrLn $ quote qp $ liftIO $ B8.putStrLn $ quote qp $
UnquotedString (c : " ") <> QuotedPath f UnquotedString (c : " ") <> QuotedPath f

45
Command/TestRemote.hs
View file

@ -87,8 +87,7 @@ start o = starting "testremote" (ActionItemOther (Just (UnquotedString (testRemo
showAction "generating test keys" showAction "generating test keys"
NE.fromList NE.fromList
<$> mapM randKey (keySizes basesz fast) <$> mapM randKey (keySizes basesz fast)
fs -> NE.fromList fs -> NE.fromList <$> mapM (getReadonlyKey r . toOsPath) fs
<$> mapM (getReadonlyKey r . toRawFilePath) fs
let r' = if null (testReadonlyFile o) let r' = if null (testReadonlyFile o)
then r then r
else r { Remote.readonly = True } else r { Remote.readonly = True }
@ -256,15 +255,15 @@ test runannex mkr mkk =
get r k get r k
, check "fsck downloaded object" fsck , check "fsck downloaded object" fsck
, check "retrieveKeyFile resume from 0" $ \r k -> do , check "retrieveKeyFile resume from 0" $ \r k -> do
tmp <- toOsPath <$> prepTmp k tmp <- prepTmp k
liftIO $ F.writeFile' tmp mempty liftIO $ F.writeFile' tmp mempty
lockContentForRemoval k noop removeAnnex lockContentForRemoval k noop removeAnnex
get r k get r k
, check "fsck downloaded object" fsck , check "fsck downloaded object" fsck
, check "retrieveKeyFile resume from 33%" $ \r k -> do , check "retrieveKeyFile resume from 33%" $ \r k -> do
loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) loc <- Annex.calcRepo (gitAnnexLocation k)
tmp <- toOsPath <$> prepTmp k tmp <- prepTmp k
partial <- liftIO $ bracket (openBinaryFile loc ReadMode) hClose $ \h -> do partial <- liftIO $ bracket (F.openBinaryFile loc ReadMode) hClose $ \h -> do
sz <- hFileSize h sz <- hFileSize h
L.hGet h $ fromInteger $ sz `div` 3 L.hGet h $ fromInteger $ sz `div` 3
liftIO $ F.writeFile tmp partial liftIO $ F.writeFile tmp partial
@ -272,8 +271,8 @@ test runannex mkr mkk =
get r k get r k
, check "fsck downloaded object" fsck , check "fsck downloaded object" fsck
, check "retrieveKeyFile resume from end" $ \r k -> do , check "retrieveKeyFile resume from end" $ \r k -> do
loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) loc <- Annex.calcRepo (gitAnnexLocation k)
tmp <- fromRawFilePath <$> prepTmp k tmp <- prepTmp k
void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp
lockContentForRemoval k noop removeAnnex lockContentForRemoval k noop removeAnnex
get r k get r k
@ -303,7 +302,7 @@ test runannex mkr mkk =
loc <- Annex.calcRepo (gitAnnexLocation k) loc <- Annex.calcRepo (gitAnnexLocation k)
verifier k loc verifier k loc
get r k = logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest -> get r k = logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest ->
tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) dest nullMeterUpdate (RemoteVerify r)) >>= \case
Right v -> return (True, v) Right v -> return (True, v)
Left _ -> return (False, UnVerified) Left _ -> return (False, UnVerified)
store r k = Remote.storeKey r k (AssociatedFile Nothing) Nothing nullMeterUpdate store r k = Remote.storeKey r k (AssociatedFile Nothing) Nothing nullMeterUpdate
@ -342,8 +341,8 @@ testExportTree runannex mkr mkk1 mkk2 =
-- renames are not tested because remotes do not need to support them -- renames are not tested because remotes do not need to support them
] ]
where where
testexportdirectory = "testremote-export" testexportdirectory = literalOsPath "testremote-export"
testexportlocation = mkExportLocation (toRawFilePath (testexportdirectory </> "location")) testexportlocation = mkExportLocation (testexportdirectory </> literalOsPath "location")
check desc a = testCase desc $ do check desc a = testCase desc $ do
let a' = mkr >>= \case let a' = mkr >>= \case
Just r -> do Just r -> do
@ -354,17 +353,17 @@ testExportTree runannex mkr mkk1 mkk2 =
Nothing -> return True Nothing -> return True
runannex a' @? "failed" runannex a' @? "failed"
storeexport ea k = do storeexport ea k = do
loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) loc <- Annex.calcRepo (gitAnnexLocation k)
Remote.storeExport ea loc k testexportlocation nullMeterUpdate Remote.storeExport ea loc k testexportlocation nullMeterUpdate
retrieveexport ea k = withTmpFile (toOsPath "exported") $ \tmp h -> do retrieveexport ea k = withTmpFile (literalOsPath "exported") $ \tmp h -> do
liftIO $ hClose h liftIO $ hClose h
tryNonAsync (Remote.retrieveExport ea k testexportlocation (fromRawFilePath (fromOsPath tmp)) nullMeterUpdate) >>= \case tryNonAsync (Remote.retrieveExport ea k testexportlocation tmp nullMeterUpdate) >>= \case
Left _ -> return False Left _ -> return False
Right v -> verifyKeyContentPostRetrieval RetrievalAllKeysSecure AlwaysVerify v k (fromOsPath tmp) Right v -> verifyKeyContentPostRetrieval RetrievalAllKeysSecure AlwaysVerify v k tmp
checkpresentexport ea k = Remote.checkPresentExport ea k testexportlocation checkpresentexport ea k = Remote.checkPresentExport ea k testexportlocation
removeexport ea k = Remote.removeExport ea k testexportlocation removeexport ea k = Remote.removeExport ea k testexportlocation
removeexportdirectory ea = case Remote.removeExportDirectory ea of removeexportdirectory ea = case Remote.removeExportDirectory ea of
Just a -> a (mkExportDirectory (toRawFilePath testexportdirectory)) Just a -> a (mkExportDirectory testexportdirectory)
Nothing -> noop Nothing -> noop
testUnavailable :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> [TestTree] testUnavailable :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> [TestTree]
@ -377,14 +376,14 @@ testUnavailable runannex mkr mkk =
Remote.checkPresent r k Remote.checkPresent r k
, check (== Right False) "retrieveKeyFile" $ \r k -> , check (== Right False) "retrieveKeyFile" $ \r k ->
logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest -> logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest ->
tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) dest nullMeterUpdate (RemoteVerify r)) >>= \case
Right v -> return (True, v) Right v -> return (True, v)
Left _ -> return (False, UnVerified) Left _ -> return (False, UnVerified)
, check (== Right False) "retrieveKeyFileCheap" $ \r k -> case Remote.retrieveKeyFileCheap r of , check (== Right False) "retrieveKeyFileCheap" $ \r k -> case Remote.retrieveKeyFileCheap r of
Nothing -> return False Nothing -> return False
Just a -> logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest -> Just a -> logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest ->
unVerified $ isRight unVerified $ isRight
<$> tryNonAsync (a k (AssociatedFile Nothing) (fromRawFilePath dest)) <$> tryNonAsync (a k (AssociatedFile Nothing) dest)
] ]
where where
check checkval desc a = testCase desc $ check checkval desc a = testCase desc $
@ -430,24 +429,24 @@ keySizes base fast = filter want
| otherwise = sz > 0 | otherwise = sz > 0
randKey :: Int -> Annex Key randKey :: Int -> Annex Key
randKey sz = withTmpFile (toOsPath "randkey") $ \f h -> do randKey sz = withTmpFile (literalOsPath "randkey") $ \f h -> do
gen <- liftIO (newGenIO :: IO SystemRandom) gen <- liftIO (newGenIO :: IO SystemRandom)
case genBytes sz gen of case genBytes sz gen of
Left e -> giveup $ "failed to generate random key: " ++ show e Left e -> giveup $ "failed to generate random key: " ++ show e
Right (rand, _) -> liftIO $ B.hPut h rand Right (rand, _) -> liftIO $ B.hPut h rand
liftIO $ hClose h liftIO $ hClose h
let ks = KeySource let ks = KeySource
{ keyFilename = fromOsPath f { keyFilename = f
, contentLocation = fromOsPath f , contentLocation = f
, inodeCache = Nothing , inodeCache = Nothing
} }
k <- case Types.Backend.genKey Backend.Hash.testKeyBackend of k <- case Types.Backend.genKey Backend.Hash.testKeyBackend of
Just a -> a ks nullMeterUpdate Just a -> a ks nullMeterUpdate
Nothing -> giveup "failed to generate random key (backend problem)" Nothing -> giveup "failed to generate random key (backend problem)"
_ <- moveAnnex k (AssociatedFile Nothing) (fromOsPath f) _ <- moveAnnex k (AssociatedFile Nothing) f
return k return k
getReadonlyKey :: Remote -> RawFilePath -> Annex Key getReadonlyKey :: Remote -> OsPath -> Annex Key
getReadonlyKey r f = do getReadonlyKey r f = do
qp <- coreQuotePath <$> Annex.getGitConfig qp <- coreQuotePath <$> Annex.getGitConfig
lookupKey f >>= \case lookupKey f >>= \case

4
Command/TransferKey.hs
View file

@ -30,7 +30,7 @@ optParser :: CmdParamsDesc -> Parser TransferKeyOptions
optParser desc = TransferKeyOptions optParser desc = TransferKeyOptions
<$> cmdParams desc <$> cmdParams desc
<*> parseFromToOptions <*> parseFromToOptions
<*> (AssociatedFile <$> optional (strOption <*> (AssociatedFile . fmap stringToOsPath <$> optional (strOption
( long "file" <> metavar paramFile ( long "file" <> metavar paramFile
<> help "the associated file" <> help "the associated file"
))) )))
@ -64,7 +64,7 @@ fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform
fromPerform key af remote = go Upload af $ fromPerform key af remote = go Upload af $
download' (uuid remote) key af Nothing stdRetry $ \p -> download' (uuid remote) key af Nothing stdRetry $ \p ->
logStatusAfter NoLiveUpdate key $ getViaTmp (retrievalSecurityPolicy remote) vc key af Nothing $ \t -> logStatusAfter NoLiveUpdate key $ getViaTmp (retrievalSecurityPolicy remote) vc key af Nothing $ \t ->
tryNonAsync (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p vc) >>= \case tryNonAsync (Remote.retrieveKeyFile remote key af t p vc) >>= \case
Right v -> return (True, v) Right v -> return (True, v)
Left e -> do Left e -> do
warning (UnquotedString (show e)) warning (UnquotedString (show e))

6
Command/TransferKeys.hs
View file

@ -51,7 +51,7 @@ start = do
| otherwise = notifyTransfer direction af $ | otherwise = notifyTransfer direction af $
download' (Remote.uuid remote) key af Nothing stdRetry $ \p -> download' (Remote.uuid remote) key af Nothing stdRetry $ \p ->
logStatusAfter NoLiveUpdate key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key af Nothing $ \t -> do logStatusAfter NoLiveUpdate key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key af Nothing $ \t -> do
r <- tryNonAsync (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p (RemoteVerify remote)) >>= \case r <- tryNonAsync (Remote.retrieveKeyFile remote key af t p (RemoteVerify remote)) >>= \case
Left e -> do Left e -> do
warning (UnquotedString (show e)) warning (UnquotedString (show e))
return (False, UnVerified) return (False, UnVerified)
@ -128,10 +128,10 @@ instance TCSerialized Direction where
deserialize _ = Nothing deserialize _ = Nothing
instance TCSerialized AssociatedFile where instance TCSerialized AssociatedFile where
serialize (AssociatedFile (Just f)) = fromRawFilePath f serialize (AssociatedFile (Just f)) = fromOsPath f
serialize (AssociatedFile Nothing) = "" serialize (AssociatedFile Nothing) = ""
deserialize "" = Just (AssociatedFile Nothing) deserialize "" = Just (AssociatedFile Nothing)
deserialize f = Just (AssociatedFile (Just (toRawFilePath f))) deserialize f = Just (AssociatedFile (Just (toOsPath f)))
instance TCSerialized RemoteName where instance TCSerialized RemoteName where
serialize n = n serialize n = n

4
Command/Transferrer.hs
View file

@ -56,7 +56,7 @@ start = do
-- and for retrying, and updating location log, -- and for retrying, and updating location log,
-- and stall canceling. -- and stall canceling.
let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key af Nothing $ \t -> do let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key af Nothing $ \t -> do
Remote.verifiedAction (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p (RemoteVerify remote)) Remote.verifiedAction (Remote.retrieveKeyFile remote key af t p (RemoteVerify remote))
in download' (Remote.uuid remote) key af Nothing noRetry go in download' (Remote.uuid remote) key af Nothing noRetry go
noNotification noNotification
runner (AssistantUploadRequest _ key (TransferAssociatedFile af)) remote = runner (AssistantUploadRequest _ key (TransferAssociatedFile af)) remote =
@ -73,7 +73,7 @@ start = do
notifyTransfer Download file $ notifyTransfer Download file $
download' (Remote.uuid remote) key file Nothing stdRetry $ \p -> download' (Remote.uuid remote) key file Nothing stdRetry $ \p ->
logStatusAfter NoLiveUpdate key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do logStatusAfter NoLiveUpdate key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do
r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case r <- tryNonAsync (Remote.retrieveKeyFile remote key file t p (RemoteVerify remote)) >>= \case
Left e -> do Left e -> do
warning (UnquotedString (show e)) warning (UnquotedString (show e))
return (False, UnVerified) return (False, UnVerified)

10
Utility/OsPath.hs
View file

@ -15,11 +15,12 @@ module Utility.OsPath (
OsString, OsString,
RawFilePath, RawFilePath,
literalOsPath, literalOsPath,
stringToOsPath,
toOsPath, toOsPath,
fromOsPath, fromOsPath,
module X, module X,
getSearchPath, getSearchPath,
unsafeFromChar unsafeFromChar,
) where ) where
import Utility.FileSystemEncoding import Utility.FileSystemEncoding
@ -101,7 +102,9 @@ bytesFromOsPath = getPosixString . getOsString
getSearchPath :: IO [OsPath] getSearchPath :: IO [OsPath]
getSearchPath = map toOsPath <$> PB.getSearchPath getSearchPath = map toOsPath <$> PB.getSearchPath
{- Used for string constants. -} {- Used for string constants. Note that when using OverloadedStrings,
- the IsString instance for ShortByteString only works properly with
- ASCII characters. -}
literalOsPath :: ShortByteString -> OsPath literalOsPath :: ShortByteString -> OsPath
literalOsPath = toOsPath literalOsPath = toOsPath
@ -130,3 +133,6 @@ unsafeFromChar = fromIntegral . ord
literalOsPath :: RawFilePath -> OsPath literalOsPath :: RawFilePath -> OsPath
literalOsPath = id literalOsPath = id
#endif #endif
stringToOsPath :: String -> OsPath
stringToOsPath = toOsPath