more OsPath conversion (572/749)
Sponsored-by: Jack Hill
This commit is contained in:
Joey Hess
parent
cb2c069ad1
commit
2d1db7986c
18 changed files with 99 additions and 96 deletions
|
|
@ -25,7 +25,6 @@ import Utility.Tmp.Dir
|
|||
import Utility.FileMode
|
||||
import Utility.ThreadScheduler
|
||||
import Utility.SafeOutput
|
||||
import qualified Utility.RawFilePath as R
|
||||
import qualified Utility.FileIO as F
|
||||
import qualified Utility.MagicWormhole as Wormhole
|
||||
|
||||
|
|
@ -220,12 +219,12 @@ wormholePairing remotename ouraddrs ui = do
|
|||
-- files. Permissions of received files may allow others
|
||||
-- to read them. So, set up a temp directory that only
|
||||
-- we can read.
|
||||
withTmpDir (toOsPath "pair") $ \tmp -> do
|
||||
liftIO $ void $ tryIO $ modifyFileMode (toRawFilePath tmp) $
|
||||
withTmpDir (literalOsPath "pair") $ \tmp -> do
|
||||
liftIO $ void $ tryIO $ modifyFileMode tmp $
|
||||
removeModes otherGroupModes
|
||||
let sendf = tmp </> "send"
|
||||
let recvf = tmp </> "recv"
|
||||
liftIO $ writeFileProtected (toRawFilePath sendf) $
|
||||
let sendf = tmp </> literalOsPath "send"
|
||||
let recvf = tmp </> literalOsPath "recv"
|
||||
liftIO $ writeFileProtected sendf $
|
||||
serializePairData ourpairdata
|
||||
|
||||
observer <- liftIO Wormhole.mkCodeObserver
|
||||
|
|
@ -235,18 +234,18 @@ wormholePairing remotename ouraddrs ui = do
|
|||
-- the same channels that other wormhole users use.
|
||||
let appid = Wormhole.appId "git-annex.branchable.com/p2p-setup"
|
||||
(sendres, recvres) <- liftIO $
|
||||
Wormhole.sendFile sendf observer appid
|
||||
Wormhole.sendFile (fromOsPath sendf) observer appid
|
||||
`concurrently`
|
||||
Wormhole.receiveFile recvf producer appid
|
||||
liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath sendf)
|
||||
Wormhole.receiveFile (fromOsPath recvf) producer appid
|
||||
liftIO $ removeWhenExistsWith removeFile sendf
|
||||
if sendres /= True
|
||||
then return SendFailed
|
||||
else if recvres /= True
|
||||
then return ReceiveFailed
|
||||
else do
|
||||
r <- liftIO $ tryIO $
|
||||
map decodeBS . fileLines' <$> F.readFile'
|
||||
(toOsPath (toRawFilePath recvf))
|
||||
map decodeBS . fileLines'
|
||||
<$> F.readFile' recvf
|
||||
case r of
|
||||
Left _e -> return ReceiveFailed
|
||||
Right ls -> maybe
|
||||
|
|
|
|||
|
|
@ -267,7 +267,7 @@ getAuthEnv = do
|
|||
findRepos :: Options -> IO [Git.Repo]
|
||||
findRepos o = do
|
||||
files <- concat
|
||||
<$> mapM (dirContents . toRawFilePath) (directoryOption o)
|
||||
<$> mapM (dirContents . toOsPath) (directoryOption o)
|
||||
map Git.Construct.newFrom . catMaybes
|
||||
<$> mapM Git.Construct.checkForRepo files
|
||||
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@ optParser desc = ReKeyOptions
|
|||
|
||||
-- Split on the last space, since a FilePath can contain whitespace,
|
||||
-- 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
|
||||
(rk, rf)
|
||||
| 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"
|
||||
Just k -> do
|
||||
let f = reverse rf
|
||||
f' <- liftIO $ relPathCwdToFile (toRawFilePath f)
|
||||
f' <- liftIO $ relPathCwdToFile (toOsPath f)
|
||||
return $ Right (f', k)
|
||||
|
||||
seek :: ReKeyOptions -> CommandSeek
|
||||
|
|
@ -65,9 +65,9 @@ seek o = case batchOption o of
|
|||
(reKeyThese o)
|
||||
where
|
||||
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
|
||||
Just k -> go k
|
||||
Nothing -> stop
|
||||
|
|
@ -79,7 +79,7 @@ start si (file, newkey) = lookupKey file >>= \case
|
|||
|
||||
ai = ActionItemTreeFile file
|
||||
|
||||
perform :: RawFilePath -> Key -> Key -> CommandPerform
|
||||
perform :: OsPath -> Key -> Key -> CommandPerform
|
||||
perform file oldkey newkey = do
|
||||
ifM (inAnnex oldkey)
|
||||
( 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),
|
||||
- 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' DefaultVerify oldkey newkey
|
||||
, 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. -}
|
||||
oldobj <- calcRepo (gitAnnexLocation oldkey)
|
||||
v <- tryNonAsync $ do
|
||||
st <- liftIO $ R.getFileStatus file
|
||||
st <- liftIO $ R.getFileStatus (fromOsPath file)
|
||||
when (linkCount st > 1) $ do
|
||||
freezeContent oldobj
|
||||
replaceWorkTreeFile file $ \tmp -> do
|
||||
|
|
@ -132,7 +132,7 @@ linkKey' v oldkey newkey =
|
|||
oldobj <- calcRepo (gitAnnexLocation oldkey)
|
||||
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
|
||||
newkeyrec <- ifM (isJust <$> isAnnexLink file)
|
||||
( do
|
||||
|
|
@ -141,7 +141,8 @@ cleanup file newkey a = do
|
|||
stageSymlink file sha
|
||||
return (MigrationRecord sha)
|
||||
, do
|
||||
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
|
||||
mode <- liftIO $ catchMaybeIO $
|
||||
fileMode <$> R.getFileStatus (fromOsPath file)
|
||||
liftIO $ whenM (isJust <$> isPointerFile file) $
|
||||
writePointerFile file newkey mode
|
||||
sha <- hashPointerFile newkey
|
||||
|
|
|
|||
|
|
@ -39,4 +39,4 @@ start (_, key) = fieldTransfer Download key $ \_p -> do
|
|||
go tmp = unVerified $ do
|
||||
opts <- filterRsyncSafeOptions . maybe [] words
|
||||
<$> getField "RsyncOptions"
|
||||
liftIO $ rsyncServerReceive (map Param opts) (fromRawFilePath tmp)
|
||||
liftIO $ rsyncServerReceive (map Param opts) (fromOsPath tmp)
|
||||
|
|
|
|||
|
|
@ -57,26 +57,26 @@ startSrcDest :: (SeekInput, (String, String)) -> CommandStart
|
|||
startSrcDest (si, (src, dest))
|
||||
| src == dest = stop
|
||||
| otherwise = starting "reinject" ai si $ notAnnexed src' $
|
||||
lookupKey (toRawFilePath dest) >>= \case
|
||||
lookupKey (toOsPath dest) >>= \case
|
||||
Just key -> ifM (verifyKeyContent key src')
|
||||
( perform src' key
|
||||
, do
|
||||
qp <- coreQuotePath <$> Annex.getGitConfig
|
||||
giveup $ decodeBS $ quote qp $ QuotedPath src'
|
||||
<> " does not have expected content of "
|
||||
<> QuotedPath (toRawFilePath dest)
|
||||
<> QuotedPath (toOsPath dest)
|
||||
)
|
||||
Nothing -> do
|
||||
qp <- coreQuotePath <$> Annex.getGitConfig
|
||||
giveup $ decodeBS $ quote qp $ QuotedPath src'
|
||||
<> " is not an annexed file"
|
||||
where
|
||||
src' = toRawFilePath src
|
||||
src' = toOsPath src
|
||||
ai = ActionItemOther (Just (QuotedPath src'))
|
||||
|
||||
startGuessKeys :: FilePath -> CommandStart
|
||||
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')
|
||||
( perform src' key
|
||||
, do
|
||||
|
|
@ -88,7 +88,7 @@ startGuessKeys src = starting "reinject" ai si $ notAnnexed src' $
|
|||
warning "Not named like an object file; skipping"
|
||||
next $ return True
|
||||
where
|
||||
src' = toRawFilePath src
|
||||
src' = toOsPath src
|
||||
ai = ActionItemOther (Just (QuotedPath src'))
|
||||
si = SeekInput [src]
|
||||
|
||||
|
|
@ -102,12 +102,12 @@ startKnown src = starting "reinject" ai si $ notAnnexed src' $ do
|
|||
next $ return True
|
||||
)
|
||||
where
|
||||
src' = toRawFilePath src
|
||||
src' = toOsPath src
|
||||
ks = KeySource src' src' Nothing
|
||||
ai = ActionItemOther (Just (QuotedPath src'))
|
||||
si = SeekInput [src]
|
||||
|
||||
notAnnexed :: RawFilePath -> CommandPerform -> CommandPerform
|
||||
notAnnexed :: OsPath -> CommandPerform -> CommandPerform
|
||||
notAnnexed src a =
|
||||
ifM (fromRepo Git.repoIsLocalBare)
|
||||
( a
|
||||
|
|
@ -120,7 +120,7 @@ notAnnexed src a =
|
|||
Nothing -> a
|
||||
)
|
||||
|
||||
perform :: RawFilePath -> Key -> CommandPerform
|
||||
perform :: OsPath -> Key -> CommandPerform
|
||||
perform src key = do
|
||||
maybeAddJSONField "key" (serializeKey key)
|
||||
ifM move
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ run o
|
|||
| foregroundDaemonOption o = liftIO runInteractive
|
||||
| otherwise = do
|
||||
#ifndef mingw32_HOST_OS
|
||||
git_annex <- liftIO programPath
|
||||
git_annex <- fromOsPath <$> liftIO programPath
|
||||
ps <- gitAnnexDaemonizeParams
|
||||
let logfd = openFdWithMode (toRawFilePath "/dev/null") ReadOnly Nothing defaultFileFlags
|
||||
liftIO $ daemonize git_annex ps logfd Nothing False runNonInteractive
|
||||
|
|
|
|||
|
|
@ -14,7 +14,6 @@ import qualified Annex.Branch
|
|||
import qualified Git.Ref
|
||||
import Git.Types
|
||||
import Annex.Version
|
||||
import qualified Utility.RawFilePath as R
|
||||
|
||||
cmd :: Command
|
||||
cmd = noCommit $ dontCheck repoExists $
|
||||
|
|
@ -76,7 +75,7 @@ repairAnnexBranch modifiedbranches
|
|||
Annex.Branch.forceCommit "committing index after git repository repair"
|
||||
liftIO $ putStrLn "Successfully recovered the git-annex branch using .git/annex/index"
|
||||
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."
|
||||
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"
|
||||
|
||||
|
|
|
|||
|
|
@ -16,8 +16,6 @@ import qualified Git.Branch
|
|||
import Annex.AutoMerge
|
||||
import qualified Utility.FileIO as F
|
||||
|
||||
import qualified System.FilePath.ByteString as P
|
||||
|
||||
cmd :: Command
|
||||
cmd = command "resolvemerge" SectionPlumbing
|
||||
"resolve merge conflicts"
|
||||
|
|
@ -30,7 +28,7 @@ start :: CommandStart
|
|||
start = starting "resolvemerge" (ActionItemOther Nothing) (SeekInput []) $ do
|
||||
us <- fromMaybe nobranch <$> inRepo Git.Branch.current
|
||||
d <- fromRepo Git.localGitDir
|
||||
let merge_head = toOsPath $ d P.</> "MERGE_HEAD"
|
||||
let merge_head = d </> literalOsPath "MERGE_HEAD"
|
||||
them <- fromMaybe (giveup nomergehead) . extractSha
|
||||
<$> liftIO (F.readFile' merge_head)
|
||||
ifM (resolveMerge (Just us) them False)
|
||||
|
|
@ -41,4 +39,4 @@ start = starting "resolvemerge" (ActionItemOther Nothing) (SeekInput []) $ do
|
|||
)
|
||||
where
|
||||
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"
|
||||
|
|
|
|||
|
|
@ -32,29 +32,28 @@ seek :: RmUrlOptions -> CommandSeek
|
|||
seek o = case batchOption o of
|
||||
Batch fmt -> batchOnly Nothing (rmThese o) $
|
||||
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.
|
||||
batchParser :: String -> Annex (Either String (FilePath, URLString))
|
||||
batchParser :: String -> Annex (Either String (OsPath, URLString))
|
||||
batchParser s = case separate (== ' ') (reverse s) of
|
||||
(ru, rf)
|
||||
| null ru || null rf -> return $ Left "Expected: \"file url\""
|
||||
| otherwise -> do
|
||||
let f = reverse rf
|
||||
f' <- liftIO $ fromRawFilePath
|
||||
<$> relPathCwdToFile (toRawFilePath f)
|
||||
let f = toOsPath (reverse rf)
|
||||
f' <- liftIO $ relPathCwdToFile f
|
||||
return $ Right (f', reverse ru)
|
||||
|
||||
start :: (SeekInput, (FilePath, URLString)) -> CommandStart
|
||||
start (si, (file, url)) = lookupKeyStaged file' >>= \case
|
||||
start :: (SeekInput, (OsPath, URLString)) -> CommandStart
|
||||
start (si, (file, url)) = lookupKeyStaged file >>= \case
|
||||
Nothing -> stop
|
||||
Just key -> do
|
||||
let ai = mkActionItem (key, AssociatedFile (Just file'))
|
||||
let ai = mkActionItem (key, AssociatedFile (Just file))
|
||||
starting "rmurl" ai si $
|
||||
next $ cleanup url key
|
||||
where
|
||||
file' = toRawFilePath file
|
||||
|
||||
cleanup :: String -> Key -> CommandCleanup
|
||||
cleanup url key = do
|
||||
|
|
|
|||
|
|
@ -33,7 +33,9 @@ start (_, key) = do
|
|||
ifM (inAnnex key)
|
||||
( fieldTransfer Upload key $ \_p ->
|
||||
sendAnnex key Nothing rollback $ \f _sz ->
|
||||
liftIO $ rsyncServerSend (map Param opts) f
|
||||
liftIO $ rsyncServerSend
|
||||
(map Param opts)
|
||||
(fromOsPath f)
|
||||
, do
|
||||
warning "requested key is not present"
|
||||
liftIO exitFailure
|
||||
|
|
|
|||
|
|
@ -25,13 +25,13 @@ start ps@(keyname:file:[]) = starting "setkey" ai si $
|
|||
where
|
||||
ai = ActionItemOther (Just (QuotedPath file'))
|
||||
si = SeekInput ps
|
||||
file' = toRawFilePath file
|
||||
file' = toOsPath file
|
||||
start _ = giveup "specify a key and a content file"
|
||||
|
||||
keyOpt :: String -> Key
|
||||
keyOpt = fromMaybe (giveup "bad key") . deserializeKey
|
||||
|
||||
perform :: RawFilePath -> Key -> CommandPerform
|
||||
perform :: OsPath -> Key -> CommandPerform
|
||||
perform file key = do
|
||||
-- the file might be on a different filesystem, so moveFile is used
|
||||
-- rather than simply calling moveAnnex; disk space is also
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@ cmd = noCommit $ noMessages $
|
|||
paramFile (seek <$$> optParser)
|
||||
|
||||
data SmudgeOptions = UpdateOption | SmudgeOptions
|
||||
{ smudgeFile :: FilePath
|
||||
{ smudgeFile :: OsPath
|
||||
, cleanOption :: Bool
|
||||
}
|
||||
|
||||
|
|
@ -52,14 +52,14 @@ optParser :: CmdParamsDesc -> Parser SmudgeOptions
|
|||
optParser desc = smudgeoptions <|> updateoption
|
||||
where
|
||||
smudgeoptions = SmudgeOptions
|
||||
<$> argument str ( metavar desc )
|
||||
<$> (stringToOsPath <$> argument str ( metavar desc ))
|
||||
<*> switch ( long "clean" <> help "clean filter" )
|
||||
updateoption = flag' UpdateOption
|
||||
( long "update" <> help "populate annexed worktree files" )
|
||||
|
||||
seek :: SmudgeOptions -> CommandSeek
|
||||
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
|
||||
|
||||
-- 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
|
||||
-- * Because git currently buffers the whole object received from the
|
||||
-- smudge filter in memory, which is a problem with large files.
|
||||
smudge :: FilePath -> CommandStart
|
||||
smudge :: OsPath -> CommandStart
|
||||
smudge file = do
|
||||
b <- liftIO $ L.hGetContents stdin
|
||||
smudge' file b
|
||||
|
|
@ -81,18 +81,18 @@ smudge file = do
|
|||
stop
|
||||
|
||||
-- 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
|
||||
Nothing -> noop
|
||||
Just k -> do
|
||||
topfile <- inRepo (toTopFilePath (toRawFilePath file))
|
||||
topfile <- inRepo (toTopFilePath file)
|
||||
Database.Keys.addAssociatedFile k topfile
|
||||
void $ smudgeLog k topfile
|
||||
|
||||
-- Clean filter is fed file content on stdin, decides if a file
|
||||
-- should be stored in the annex, and outputs a pointer to its
|
||||
-- injested content if so. Otherwise, the original content.
|
||||
clean :: RawFilePath -> CommandStart
|
||||
clean :: OsPath -> CommandStart
|
||||
clean file = do
|
||||
Annex.BranchState.disableUpdate -- optimisation
|
||||
b <- liftIO $ L.hGetContents stdin
|
||||
|
|
@ -116,7 +116,7 @@ clean file = do
|
|||
|
||||
-- Handles everything except the IO of the file content.
|
||||
clean'
|
||||
:: RawFilePath
|
||||
:: OsPath
|
||||
-> Either InvalidAppendedPointerFile (Maybe Key)
|
||||
-- ^ If the content provided by git is an annex pointer,
|
||||
-- this is the key it points to.
|
||||
|
|
@ -188,7 +188,7 @@ clean' file mk passthrough discardreststdin emitpointer =
|
|||
emitpointer
|
||||
=<< postingest
|
||||
=<< (\ld -> ingest' preferredbackend nullMeterUpdate ld Nothing norestage)
|
||||
=<< lockDown cfg (fromRawFilePath file)
|
||||
=<< lockDown cfg file
|
||||
|
||||
postingest (Just k, _) = do
|
||||
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
|
||||
-- repository; can't annex those
|
||||
fileOutsideRepo :: RawFilePath -> Annex Bool
|
||||
fileOutsideRepo :: OsPath -> Annex Bool
|
||||
fileOutsideRepo file = do
|
||||
repopath <- liftIO . absPath =<< fromRepo Git.repoPath
|
||||
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.
|
||||
-- This handles cases such as renaming a file followed by git add,
|
||||
-- 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
|
||||
ifM (annexGitAddToAnnex <$> Annex.getGitConfig)
|
||||
( 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,
|
||||
-- then git-annex gets the content, and later git add is run on
|
||||
-- the pointer copy. It will then be populated with the content.
|
||||
getMoveRaceRecovery :: Key -> RawFilePath -> Annex ()
|
||||
getMoveRaceRecovery :: Key -> OsPath -> Annex ()
|
||||
getMoveRaceRecovery k file = void $ tryNonAsync $
|
||||
whenM (inAnnex k) $ do
|
||||
obj <- calcRepo (gitAnnexLocation k)
|
||||
|
|
|
|||
|
|
@ -66,6 +66,6 @@ displayStatus s = do
|
|||
absf <- fromRepo $ fromTopFilePath (statusFile s)
|
||||
f <- liftIO $ relPathCwdToFile absf
|
||||
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 $
|
||||
UnquotedString (c : " ") <> QuotedPath f
|
||||
|
|
|
|||
|
|
@ -87,8 +87,7 @@ start o = starting "testremote" (ActionItemOther (Just (UnquotedString (testRemo
|
|||
showAction "generating test keys"
|
||||
NE.fromList
|
||||
<$> mapM randKey (keySizes basesz fast)
|
||||
fs -> NE.fromList
|
||||
<$> mapM (getReadonlyKey r . toRawFilePath) fs
|
||||
fs -> NE.fromList <$> mapM (getReadonlyKey r . toOsPath) fs
|
||||
let r' = if null (testReadonlyFile o)
|
||||
then r
|
||||
else r { Remote.readonly = True }
|
||||
|
|
@ -256,15 +255,15 @@ test runannex mkr mkk =
|
|||
get r k
|
||||
, check "fsck downloaded object" fsck
|
||||
, check "retrieveKeyFile resume from 0" $ \r k -> do
|
||||
tmp <- toOsPath <$> prepTmp k
|
||||
tmp <- prepTmp k
|
||||
liftIO $ F.writeFile' tmp mempty
|
||||
lockContentForRemoval k noop removeAnnex
|
||||
get r k
|
||||
, check "fsck downloaded object" fsck
|
||||
, check "retrieveKeyFile resume from 33%" $ \r k -> do
|
||||
loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k)
|
||||
tmp <- toOsPath <$> prepTmp k
|
||||
partial <- liftIO $ bracket (openBinaryFile loc ReadMode) hClose $ \h -> do
|
||||
loc <- Annex.calcRepo (gitAnnexLocation k)
|
||||
tmp <- prepTmp k
|
||||
partial <- liftIO $ bracket (F.openBinaryFile loc ReadMode) hClose $ \h -> do
|
||||
sz <- hFileSize h
|
||||
L.hGet h $ fromInteger $ sz `div` 3
|
||||
liftIO $ F.writeFile tmp partial
|
||||
|
|
@ -272,8 +271,8 @@ test runannex mkr mkk =
|
|||
get r k
|
||||
, check "fsck downloaded object" fsck
|
||||
, check "retrieveKeyFile resume from end" $ \r k -> do
|
||||
loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k)
|
||||
tmp <- fromRawFilePath <$> prepTmp k
|
||||
loc <- Annex.calcRepo (gitAnnexLocation k)
|
||||
tmp <- prepTmp k
|
||||
void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp
|
||||
lockContentForRemoval k noop removeAnnex
|
||||
get r k
|
||||
|
|
@ -303,7 +302,7 @@ test runannex mkr mkk =
|
|||
loc <- Annex.calcRepo (gitAnnexLocation k)
|
||||
verifier k loc
|
||||
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)
|
||||
Left _ -> return (False, UnVerified)
|
||||
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
|
||||
]
|
||||
where
|
||||
testexportdirectory = "testremote-export"
|
||||
testexportlocation = mkExportLocation (toRawFilePath (testexportdirectory </> "location"))
|
||||
testexportdirectory = literalOsPath "testremote-export"
|
||||
testexportlocation = mkExportLocation (testexportdirectory </> literalOsPath "location")
|
||||
check desc a = testCase desc $ do
|
||||
let a' = mkr >>= \case
|
||||
Just r -> do
|
||||
|
|
@ -354,17 +353,17 @@ testExportTree runannex mkr mkk1 mkk2 =
|
|||
Nothing -> return True
|
||||
runannex a' @? "failed"
|
||||
storeexport ea k = do
|
||||
loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k)
|
||||
loc <- Annex.calcRepo (gitAnnexLocation k)
|
||||
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
|
||||
tryNonAsync (Remote.retrieveExport ea k testexportlocation (fromRawFilePath (fromOsPath tmp)) nullMeterUpdate) >>= \case
|
||||
tryNonAsync (Remote.retrieveExport ea k testexportlocation tmp nullMeterUpdate) >>= \case
|
||||
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
|
||||
removeexport ea k = Remote.removeExport ea k testexportlocation
|
||||
removeexportdirectory ea = case Remote.removeExportDirectory ea of
|
||||
Just a -> a (mkExportDirectory (toRawFilePath testexportdirectory))
|
||||
Just a -> a (mkExportDirectory testexportdirectory)
|
||||
Nothing -> noop
|
||||
|
||||
testUnavailable :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> [TestTree]
|
||||
|
|
@ -377,14 +376,14 @@ testUnavailable runannex mkr mkk =
|
|||
Remote.checkPresent r k
|
||||
, check (== Right False) "retrieveKeyFile" $ \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)
|
||||
Left _ -> return (False, UnVerified)
|
||||
, check (== Right False) "retrieveKeyFileCheap" $ \r k -> case Remote.retrieveKeyFileCheap r of
|
||||
Nothing -> return False
|
||||
Just a -> logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest ->
|
||||
unVerified $ isRight
|
||||
<$> tryNonAsync (a k (AssociatedFile Nothing) (fromRawFilePath dest))
|
||||
<$> tryNonAsync (a k (AssociatedFile Nothing) dest)
|
||||
]
|
||||
where
|
||||
check checkval desc a = testCase desc $
|
||||
|
|
@ -430,24 +429,24 @@ keySizes base fast = filter want
|
|||
| otherwise = sz > 0
|
||||
|
||||
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)
|
||||
case genBytes sz gen of
|
||||
Left e -> giveup $ "failed to generate random key: " ++ show e
|
||||
Right (rand, _) -> liftIO $ B.hPut h rand
|
||||
liftIO $ hClose h
|
||||
let ks = KeySource
|
||||
{ keyFilename = fromOsPath f
|
||||
, contentLocation = fromOsPath f
|
||||
{ keyFilename = f
|
||||
, contentLocation = f
|
||||
, inodeCache = Nothing
|
||||
}
|
||||
k <- case Types.Backend.genKey Backend.Hash.testKeyBackend of
|
||||
Just a -> a ks nullMeterUpdate
|
||||
Nothing -> giveup "failed to generate random key (backend problem)"
|
||||
_ <- moveAnnex k (AssociatedFile Nothing) (fromOsPath f)
|
||||
_ <- moveAnnex k (AssociatedFile Nothing) f
|
||||
return k
|
||||
|
||||
getReadonlyKey :: Remote -> RawFilePath -> Annex Key
|
||||
getReadonlyKey :: Remote -> OsPath -> Annex Key
|
||||
getReadonlyKey r f = do
|
||||
qp <- coreQuotePath <$> Annex.getGitConfig
|
||||
lookupKey f >>= \case
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ optParser :: CmdParamsDesc -> Parser TransferKeyOptions
|
|||
optParser desc = TransferKeyOptions
|
||||
<$> cmdParams desc
|
||||
<*> parseFromToOptions
|
||||
<*> (AssociatedFile <$> optional (strOption
|
||||
<*> (AssociatedFile . fmap stringToOsPath <$> optional (strOption
|
||||
( long "file" <> metavar paramFile
|
||||
<> help "the associated file"
|
||||
)))
|
||||
|
|
@ -64,7 +64,7 @@ fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform
|
|||
fromPerform key af remote = go Upload af $
|
||||
download' (uuid remote) key af Nothing stdRetry $ \p ->
|
||||
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)
|
||||
Left e -> do
|
||||
warning (UnquotedString (show e))
|
||||
|
|
|
|||
|
|
@ -51,7 +51,7 @@ start = do
|
|||
| otherwise = notifyTransfer direction af $
|
||||
download' (Remote.uuid remote) key af Nothing stdRetry $ \p ->
|
||||
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
|
||||
warning (UnquotedString (show e))
|
||||
return (False, UnVerified)
|
||||
|
|
@ -128,10 +128,10 @@ instance TCSerialized Direction where
|
|||
deserialize _ = Nothing
|
||||
|
||||
instance TCSerialized AssociatedFile where
|
||||
serialize (AssociatedFile (Just f)) = fromRawFilePath f
|
||||
serialize (AssociatedFile (Just f)) = fromOsPath f
|
||||
serialize (AssociatedFile Nothing) = ""
|
||||
deserialize "" = Just (AssociatedFile Nothing)
|
||||
deserialize f = Just (AssociatedFile (Just (toRawFilePath f)))
|
||||
deserialize f = Just (AssociatedFile (Just (toOsPath f)))
|
||||
|
||||
instance TCSerialized RemoteName where
|
||||
serialize n = n
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@ start = do
|
|||
-- and for retrying, and updating location log,
|
||||
-- and stall canceling.
|
||||
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
|
||||
noNotification
|
||||
runner (AssistantUploadRequest _ key (TransferAssociatedFile af)) remote =
|
||||
|
|
@ -73,7 +73,7 @@ start = do
|
|||
notifyTransfer Download file $
|
||||
download' (Remote.uuid remote) key file Nothing stdRetry $ \p ->
|
||||
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
|
||||
warning (UnquotedString (show e))
|
||||
return (False, UnVerified)
|
||||
|
|
|
|||
|
|
@ -15,11 +15,12 @@ module Utility.OsPath (
|
|||
OsString,
|
||||
RawFilePath,
|
||||
literalOsPath,
|
||||
stringToOsPath,
|
||||
toOsPath,
|
||||
fromOsPath,
|
||||
module X,
|
||||
getSearchPath,
|
||||
unsafeFromChar
|
||||
unsafeFromChar,
|
||||
) where
|
||||
|
||||
import Utility.FileSystemEncoding
|
||||
|
|
@ -101,7 +102,9 @@ bytesFromOsPath = getPosixString . getOsString
|
|||
getSearchPath :: IO [OsPath]
|
||||
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 = toOsPath
|
||||
|
||||
|
|
@ -130,3 +133,6 @@ unsafeFromChar = fromIntegral . ord
|
|||
literalOsPath :: RawFilePath -> OsPath
|
||||
literalOsPath = id
|
||||
#endif
|
||||
|
||||
stringToOsPath :: String -> OsPath
|
||||
stringToOsPath = toOsPath
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue