more OsPath conversion (502/749)

Sponsored-by: Kevin Mueller on Patreon
This commit is contained in:
Joey Hess 2025-02-05 13:29:58 -04:00
parent b28433072c
commit 0b9e9cbf70
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
15 changed files with 147 additions and 149 deletions

View file

@ -29,11 +29,8 @@ import Annex.GitOverlay
import Utility.Tmp.Dir
import Utility.CopyFile
import Utility.Directory.Create
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import qualified System.FilePath.ByteString as P
canMergeToAdjustedBranch :: Branch -> (OrigBranch, Adjustment) -> Annex Bool
canMergeToAdjustedBranch tomerge (origbranch, adj) =
inRepo $ Git.Branch.changed currbranch tomerge
@ -74,23 +71,24 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm
changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do
git_dir <- fromRepo Git.localGitDir
tmpwt <- fromRepo gitAnnexMergeDir
withTmpDirIn (fromRawFilePath othertmpdir) (toOsPath "git") $ \tmpgit -> withWorkTreeRelated tmpgit $
withTmpDirIn othertmpdir (literalOsPath "git") $ \tmpgit -> withWorkTreeRelated tmpgit $
withemptydir git_dir tmpwt $ withWorkTree tmpwt $ do
let tmpgit' = toRawFilePath tmpgit
liftIO $ writeFile (tmpgit </> "HEAD") (fromRef updatedorig)
liftIO $ F.writeFile'
(tmpgit </> literalOsPath "HEAD")
(fromRef' updatedorig)
-- Copy in refs and packed-refs, to work
-- around bug in git 2.13.0, which
-- causes it not to look in GIT_DIR for refs.
refs <- liftIO $ emptyWhenDoesNotExist $
dirContentsRecursive $
git_dir P.</> "refs"
let refs' = (git_dir P.</> "packed-refs") : refs
git_dir </> literalOsPath "refs"
let refs' = (git_dir </> literalOsPath "packed-refs") : refs
liftIO $ forM_ refs' $ \src -> do
whenM (R.doesPathExist src) $ do
whenM (doesFileExist src) $ do
dest <- relPathDirToFile git_dir src
let dest' = tmpgit' P.</> dest
let dest' = tmpgit </> dest
createDirectoryUnder [git_dir]
(P.takeDirectory dest')
(takeDirectory dest')
void $ createLinkOrCopy src dest'
-- This reset makes git merge not care
-- that the work tree is empty; otherwise
@ -107,7 +105,7 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm
if merged
then do
!mergecommit <- liftIO $ extractSha
<$> F.readFile' (toOsPath (tmpgit' P.</> "HEAD"))
<$> F.readFile' (tmpgit </> literalOsPath "HEAD")
-- This is run after the commit lock is dropped.
return $ postmerge mergecommit
else return $ return False
@ -118,7 +116,7 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm
setup = do
whenM (doesDirectoryExist d) $
removeDirectoryRecursive d
createDirectoryUnder [git_dir] (toRawFilePath d)
createDirectoryUnder [git_dir] d
cleanup _ = removeDirectoryRecursive d
{- A merge commit has been made between the basisbranch and

View file

@ -56,6 +56,7 @@ import Annex.Perms
#ifndef mingw32_HOST_OS
import Utility.ThreadScheduler
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import Utility.FileMode
import System.Posix.User
import qualified Utility.LockFile.Posix as Posix
@ -66,7 +67,6 @@ import Control.Monad.IO.Class (MonadIO)
#ifndef mingw32_HOST_OS
import System.PosixCompat.Files (ownerReadMode, isNamedPipe)
import Data.Either
import qualified System.FilePath.ByteString as P
import Control.Concurrent.Async
#endif
@ -99,13 +99,12 @@ initializeAllowed = noAnnexFileContent' >>= \case
Just _ -> return False
noAnnexFileContent' :: Annex (Maybe String)
noAnnexFileContent' = inRepo $
noAnnexFileContent . fmap fromRawFilePath . Git.repoWorkTree
noAnnexFileContent' = inRepo $ noAnnexFileContent . Git.repoWorkTree
genDescription :: Maybe String -> Annex UUIDDesc
genDescription (Just d) = return $ UUIDDesc $ encodeBS d
genDescription Nothing = do
reldir <- liftIO . relHome . fromRawFilePath
reldir <- liftIO . relHome
=<< liftIO . absPath
=<< fromRepo Git.repoPath
hostname <- fromMaybe "" <$> liftIO getHostname
@ -238,12 +237,12 @@ autoInitializeAllowed = Annex.Branch.hasSibling <&&> objectDirNotPresent
objectDirNotPresent :: Annex Bool
objectDirNotPresent = do
d <- fromRawFilePath <$> fromRepo gitAnnexObjectDir
d <- fromRepo gitAnnexObjectDir
exists <- liftIO $ doesDirectoryExist d
when exists $ guardSafeToUseRepo $
giveup $ unwords $
[ "This repository is not initialized for use"
, "by git-annex, but " ++ d ++ " exists,"
, "by git-annex, but " ++ fromOsPath d ++ " exists,"
, "which indicates this repository was used by"
, "git-annex before, and may have lost its"
, "annex.uuid and annex.version configs. Either"
@ -263,7 +262,7 @@ guardSafeToUseRepo a = ifM (inRepo Git.Config.checkRepoConfigInaccessible)
, ""
-- This mirrors git's wording.
, "To add an exception for this directory, call:"
, "\tgit config --global --add safe.directory " ++ fromRawFilePath p
, "\tgit config --global --add safe.directory " ++ fromOsPath p
]
, a
)
@ -301,40 +300,39 @@ probeCrippledFileSystem = withEventuallyCleanedOtherTmp $ \tmp -> do
probeCrippledFileSystem'
:: (MonadIO m, MonadCatch m)
=> RawFilePath
-> Maybe (RawFilePath -> m ())
-> Maybe (RawFilePath -> m ())
=> OsPath
-> Maybe (OsPath -> m ())
-> Maybe (OsPath -> m ())
-> Bool
-> m (Bool, [String])
#ifdef mingw32_HOST_OS
probeCrippledFileSystem' _ _ _ _ = return (True, [])
#else
probeCrippledFileSystem' tmp freezecontent thawcontent hasfreezehook = do
let f = tmp P.</> "gaprobe"
let f' = fromRawFilePath f
liftIO $ writeFile f' ""
r <- probe f'
let f = tmp </> literalOsPath "gaprobe"
liftIO $ F.writeFile' f ""
r <- probe f
void $ tryNonAsync $ (fromMaybe (liftIO . allowWrite) thawcontent) f
liftIO $ removeFile f'
liftIO $ removeFile f
return r
where
probe f = catchDefaultIO (True, []) $ do
let f2 = f ++ "2"
liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f2)
liftIO $ R.createSymbolicLink (toRawFilePath f) (toRawFilePath f2)
liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f2)
(fromMaybe (liftIO . preventWrite) freezecontent) (toRawFilePath f)
let f2 = f <> literalOsPath "2"
liftIO $ removeWhenExistsWith removeFile f2
liftIO $ R.createSymbolicLink (fromOsPath f) (fromOsPath f2)
liftIO $ removeWhenExistsWith removeFile f2
(fromMaybe (liftIO . preventWrite) freezecontent) f
-- Should be unable to write to the file (unless
-- running as root). But some crippled
-- filesystems ignore write bit removals or ignore
-- permissions entirely.
ifM ((== Just False) <$> liftIO (checkContentWritePerm' UnShared (toRawFilePath f) Nothing hasfreezehook))
ifM ((== Just False) <$> liftIO (checkContentWritePerm' UnShared f Nothing hasfreezehook))
( return (True, ["Filesystem does not allow removing write bit from files."])
, liftIO $ ifM ((== 0) <$> getRealUserID)
( return (False, [])
, do
r <- catchBoolIO $ do
writeFile f "2"
F.writeFile' f "2"
return True
if r
then return (True, ["Filesystem allows writing to files whose write bit is not set."])
@ -363,19 +361,19 @@ probeLockSupport :: Annex Bool
probeLockSupport = return True
#else
probeLockSupport = withEventuallyCleanedOtherTmp $ \tmp -> do
let f = tmp P.</> "lockprobe"
let f = tmp </> literalOsPath "lockprobe"
mode <- annexFileMode
annexrunner <- Annex.makeRunner
liftIO $ withAsync (warnstall annexrunner) (const (go f mode))
where
go f mode = do
removeWhenExistsWith R.removeLink f
removeWhenExistsWith removeFile f
let locktest = bracket
(Posix.lockExclusive (Just mode) f)
Posix.dropLock
(const noop)
ok <- isRight <$> tryNonAsync locktest
removeWhenExistsWith R.removeLink f
removeWhenExistsWith removeFile f
return ok
warnstall annexrunner = do
@ -391,17 +389,17 @@ probeFifoSupport = do
return False
#else
withEventuallyCleanedOtherTmp $ \tmp -> do
let f = tmp P.</> "gaprobe"
let f2 = tmp P.</> "gaprobe2"
let f = tmp </> literalOsPath "gaprobe"
let f2 = tmp </> literalOsPath "gaprobe2"
liftIO $ do
removeWhenExistsWith R.removeLink f
removeWhenExistsWith R.removeLink f2
removeWhenExistsWith removeFile f
removeWhenExistsWith removeFile f2
ms <- tryIO $ do
R.createNamedPipe f ownerReadMode
R.createLink f f2
R.getFileStatus f
removeWhenExistsWith R.removeLink f
removeWhenExistsWith R.removeLink f2
R.createNamedPipe (fromOsPath f) ownerReadMode
R.createLink (fromOsPath f) (fromOsPath f2)
R.getFileStatus (fromOsPath f)
removeWhenExistsWith removeFile f
removeWhenExistsWith removeFile f2
return $ either (const False) isNamedPipe ms
#endif
@ -473,14 +471,14 @@ autoEnableSpecialRemotes remotelist = do
-- could result in password prompts for http credentials,
-- which would then not end up cached in this process's state.
_ <- remotelist
rp <- fromRawFilePath <$> fromRepo Git.repoPath
rp <- fromRepo Git.repoPath
withNullHandle $ \nullh -> gitAnnexChildProcess "init"
[ Param "--autoenable" ]
(\p -> p
{ std_out = UseHandle nullh
, std_err = UseHandle nullh
, std_in = UseHandle nullh
, cwd = Just rp
, cwd = Just (fromOsPath rp)
}
)
(\_ _ _ pid -> void $ waitForProcess pid)

View file

@ -573,9 +573,9 @@ gitAnnexFeedState k r = gitAnnexFeedStateDir r </> keyFile k
{- .git/annex/merge/ is used as a empty work tree for merges in
- adjusted branches. -}
gitAnnexMergeDir :: Git.Repo -> FilePath
gitAnnexMergeDir r = fromOsPath $
addTrailingPathSeparator $ gitAnnexDir r </> literalOsPath "merge"
gitAnnexMergeDir :: Git.Repo -> OsPath
gitAnnexMergeDir r = addTrailingPathSeparator $
gitAnnexDir r </> literalOsPath "merge"
{- .git/annex/transfer/ is used to record keys currently
- being transferred, and other transfer bookkeeping info. -}

View file

@ -44,13 +44,11 @@ import Annex.TransferrerPool
import Annex.StallDetection
import Backend (isCryptographicallySecureKey)
import Types.StallDetection
import qualified Utility.RawFilePath as R
import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM hiding (retry)
import qualified Data.Map.Strict as M
import qualified System.FilePath.ByteString as P
import Data.Ord
-- Upload, supporting canceling detected stalls.
@ -83,7 +81,7 @@ download r key f d witness =
go sd = getViaTmp (Remote.retrievalSecurityPolicy r) vc key f Nothing $ \dest ->
download' (Remote.uuid r) key f sd d (go' dest) witness
go' dest p = verifiedAction $
Remote.retrieveKeyFile r key f (fromRawFilePath dest) p vc
Remote.retrieveKeyFile r key f dest p vc
vc = Remote.RemoteVerify r
-- Download, not supporting canceling detected stalls.
@ -146,10 +144,10 @@ runTransfer' ignorelock t eventualbackend afile stalldetection retrydecider tran
else recordFailedTransfer t info
return v
prep :: RawFilePath -> Maybe RawFilePath -> Annex () -> ModeSetter -> Annex (Maybe (LockHandle, Maybe LockHandle), Bool)
prep :: OsPath -> Maybe OsPath -> Annex () -> ModeSetter -> Annex (Maybe (LockHandle, Maybe LockHandle), Bool)
#ifndef mingw32_HOST_OS
prep lckfile moldlckfile createtfile mode = catchPermissionDenied (const prepfailed) $ do
createAnnexDirectory $ P.takeDirectory lckfile
createAnnexDirectory $ takeDirectory lckfile
tryLockExclusive (Just mode) lckfile >>= \case
Nothing -> return (Nothing, True)
-- Since the lock file is removed in cleanup,
@ -163,7 +161,7 @@ runTransfer' ignorelock t eventualbackend afile stalldetection retrydecider tran
createtfile
return (Just (lockhandle, Nothing), False)
Just oldlckfile -> do
createAnnexDirectory $ P.takeDirectory oldlckfile
createAnnexDirectory oldlckfile
tryLockExclusive (Just mode) oldlckfile >>= \case
Nothing -> do
liftIO $ dropLock lockhandle
@ -183,14 +181,14 @@ runTransfer' ignorelock t eventualbackend afile stalldetection retrydecider tran
)
#else
prep lckfile moldlckfile createtfile _mode = catchPermissionDenied (const prepfailed) $ do
createAnnexDirectory $ P.takeDirectory lckfile
createAnnexDirectory lckfile
catchMaybeIO (liftIO $ lockExclusive lckfile) >>= \case
Just (Just lockhandle) -> case moldlckfile of
Nothing -> do
createtfile
return (Just (lockhandle, Nothing), False)
Just oldlckfile -> do
createAnnexDirectory $ P.takeDirectory oldlckfile
createAnnexDirectory oldlckfile
catchMaybeIO (liftIO $ lockExclusive oldlckfile) >>= \case
Just (Just oldlockhandle) -> do
createtfile
@ -204,10 +202,10 @@ runTransfer' ignorelock t eventualbackend afile stalldetection retrydecider tran
cleanup _ _ _ Nothing = noop
cleanup tfile lckfile moldlckfile (Just (lockhandle, moldlockhandle)) = do
void $ tryIO $ R.removeLink tfile
void $ tryIO $ removeFile tfile
#ifndef mingw32_HOST_OS
void $ tryIO $ R.removeLink lckfile
maybe noop (void . tryIO . R.removeLink) moldlckfile
void $ tryIO $ removeFile lckfile
maybe noop (void . tryIO . removeFile) moldlckfile
maybe noop dropLock moldlockhandle
dropLock lockhandle
#else
@ -219,7 +217,7 @@ runTransfer' ignorelock t eventualbackend afile stalldetection retrydecider tran
maybe noop dropLock moldlockhandle
dropLock lockhandle
void $ tryIO $ R.removeLink lckfile
maybe noop (void . tryIO . R.removeLink) moldlckfile
maybe noop (void . tryIO . removeFile) moldlckfile
#endif
retry numretries oldinfo metervar run =

View file

@ -18,13 +18,14 @@ import Annex.Common
import Annex.Content
import Annex.Transfer
import Annex.ChangedRefs
import Annex.Verify
import P2P.Protocol
import P2P.IO
import Logs.Location
import Types.NumCopies
import Utility.Metered
import Utility.MonotonicClock
import Annex.Verify
import qualified Utility.FileIO as F
import Control.Monad.Free
import Control.Concurrent.STM
@ -46,7 +47,7 @@ runLocal runst runner a = case a of
size <- liftIO $ catchDefaultIO 0 $ getFileSize tmp
runner (next (Len size))
FileSize f next -> do
size <- liftIO $ catchDefaultIO 0 $ getFileSize (toRawFilePath f)
size <- liftIO $ catchDefaultIO 0 $ getFileSize f
runner (next (Len size))
ContentSize k next -> do
let getsize = liftIO . catchMaybeIO . getFileSize
@ -81,7 +82,7 @@ runLocal runst runner a = case a of
let runtransfer ti =
Right <$> transfer download' k af Nothing (\p ->
logStatusAfter NoLiveUpdate k $ getViaTmp rsp DefaultVerify k af Nothing $ \tmp ->
storefile (fromRawFilePath tmp) o l getb iv validitycheck p ti)
storefile tmp o l getb iv validitycheck p ti)
let fallback = return $ Left $
ProtoFailureMessage "transfer already in progress, or unable to take transfer lock"
checktransfer runtransfer fallback
@ -194,13 +195,13 @@ runLocal runst runner a = case a of
v <- runner getb
case v of
Right b -> do
liftIO $ withBinaryFile dest ReadWriteMode $ \h -> do
liftIO $ F.withBinaryFile dest ReadWriteMode $ \h -> do
p' <- resumeVerifyFromOffset o incrementalverifier p h
meteredWrite p' (writeVerifyChunk incrementalverifier h) b
indicatetransferred ti
rightsize <- do
sz <- liftIO $ getFileSize (toRawFilePath dest)
sz <- liftIO $ getFileSize dest
return (toInteger sz == l + o)
runner validitycheck >>= \case
@ -210,7 +211,7 @@ runLocal runst runner a = case a of
Nothing -> return (True, UnVerified)
Just True -> return (True, Verified)
Just False -> do
verificationOfContentFailed (toRawFilePath dest)
verificationOfContentFailed dest
return (False, UnVerified)
| otherwise -> return (False, UnVerified)
Nothing -> return (rightsize, UnVerified)
@ -232,7 +233,7 @@ runLocal runst runner a = case a of
sinkfile f (Offset o) checkchanged sender p ti = bracket setup cleanup go
where
setup = liftIO $ openBinaryFile f ReadMode
setup = liftIO $ F.openBinaryFile f ReadMode
cleanup = liftIO . hClose
go h = do
let p' = offsetMeterUpdate p (toBytesProcessed o)

View file

@ -37,6 +37,7 @@ import Annex.Concurrent
import Utility.Url (BasicAuth(..))
import Utility.HumanTime
import Utility.STM
import qualified Utility.FileIO as F
import qualified Git.Credential as Git
import Servant hiding (BasicAuthData(..))
@ -340,7 +341,7 @@ clientPut
-> Key
-> Maybe Offset
-> AssociatedFile
-> FilePath
-> OsPath
-> FileSize
-> Annex Bool
-- ^ Called after sending the file to check if it's valid.
@ -358,7 +359,7 @@ clientPut meterupdate k moffset af contentfile contentfilesize validitycheck dat
liftIO $ atomically $ takeTMVar checkv
validitycheck >>= liftIO . atomically . putTMVar checkresultv
checkerthread <- liftIO . async =<< forkState checker
v <- liftIO $ withBinaryFile contentfile ReadMode $ \h -> do
v <- liftIO $ F.withBinaryFile contentfile ReadMode $ \h -> do
when (offset /= 0) $
hSeek h AbsoluteSeek offset
withClientM (cli (stream h checkv checkresultv)) clientenv return

View file

@ -42,7 +42,6 @@ import Utility.Debug
import Utility.MonotonicClock
import Types.UUID
import Annex.ChangedRefs
import qualified Utility.RawFilePath as R
import Control.Monad.Free
import Control.Monad.IO.Class
@ -162,11 +161,11 @@ closeConnection conn = do
-- Note that while the callback is running, other connections won't be
-- processed, so longterm work should be run in a separate thread by
-- the callback.
serveUnixSocket :: FilePath -> (Handle -> IO ()) -> IO ()
serveUnixSocket :: OsPath -> (Handle -> IO ()) -> IO ()
serveUnixSocket unixsocket serveconn = do
removeWhenExistsWith R.removeLink (toRawFilePath unixsocket)
removeWhenExistsWith removeFile unixsocket
soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
S.bind soc (S.SockAddrUnix unixsocket)
S.bind soc (S.SockAddrUnix (fromOsPath unixsocket))
-- Allow everyone to read and write to the socket,
-- so a daemon like tor, that is probably running as a different
-- de sock $ addModes
@ -175,7 +174,7 @@ serveUnixSocket unixsocket serveconn = do
-- Connections have to authenticate to do anything,
-- so it's fine that other local users can connect to the
-- socket.
modifyFileMode (toOsPath unixsocket) $ addModes
modifyFileMode unixsocket $ addModes
[groupReadMode, groupWriteMode, otherReadMode, otherWriteMode]
S.listen soc 2
forever $ do

View file

@ -293,12 +293,12 @@ data LocalF c
= TmpContentSize Key (Len -> c)
-- ^ Gets size of the temp file where received content may have
-- been stored. If not present, returns 0.
| FileSize FilePath (Len -> c)
| FileSize OsPath (Len -> c)
-- ^ Gets size of the content of a file. If not present, returns 0.
| ContentSize Key (Maybe Len -> c)
-- ^ Gets size of the content of a key, when the full content is
-- present.
| ReadContent Key AssociatedFile (Maybe FilePath) Offset (L.ByteString -> Proto Validity -> Proto (Maybe [UUID])) (Maybe [UUID] -> c)
| ReadContent Key AssociatedFile (Maybe OsPath) Offset (L.ByteString -> Proto Validity -> Proto (Maybe [UUID])) (Maybe [UUID] -> c)
-- ^ Reads the content of a key and sends it to the callback.
-- Must run the callback, or terminate the protocol connection.
--
@ -323,7 +323,7 @@ data LocalF c
-- Note: The ByteString may not contain the entire remaining content
-- of the key. Only once the temp file size == Len has the whole
-- content been transferred.
| StoreContentTo FilePath (Maybe IncrementalVerifier) Offset Len (Proto L.ByteString) (Proto (Maybe Validity)) ((Bool, Verification) -> c)
| StoreContentTo OsPath (Maybe IncrementalVerifier) Offset Len (Proto L.ByteString) (Proto (Maybe Validity)) ((Bool, Verification) -> c)
-- ^ Like StoreContent, but stores the content to a temp file.
| SendContentWith (L.ByteString -> Annex (Maybe Validity -> Annex Bool)) (Proto L.ByteString) (Proto (Maybe Validity)) (Bool -> c)
-- ^ Reads content from the Proto L.ByteString and sends it to the
@ -481,7 +481,7 @@ removeBeforeRemoteEndTime remoteendtime key = do
REMOVE_BEFORE remoteendtime key
checkSuccessFailurePlus
get :: FilePath -> Key -> Maybe IncrementalVerifier -> AssociatedFile -> Meter -> MeterUpdate -> Proto (Bool, Verification)
get :: OsPath -> Key -> Maybe IncrementalVerifier -> AssociatedFile -> Meter -> MeterUpdate -> Proto (Bool, Verification)
get dest key iv af m p =
receiveContent (Just m) p sizer storer noothermessages $ \offset ->
GET offset (ProtoAssociatedFile af) key
@ -727,7 +727,7 @@ checkCONNECTServerMode service servermode a =
(ServeReadOnly, UploadPack) -> a Nothing
(ServeReadOnly, ReceivePack) -> a (Just sendReadOnlyError)
sendContent :: Key -> AssociatedFile -> Maybe FilePath -> Offset -> MeterUpdate -> Proto (Maybe [UUID])
sendContent :: Key -> AssociatedFile -> Maybe OsPath -> Offset -> MeterUpdate -> Proto (Maybe [UUID])
sendContent key af o offset@(Offset n) p = go =<< local (contentSize key)
where
go (Just (Len totallen)) = do

View file

@ -12,7 +12,6 @@ module Remote.Bup (remote) where
import qualified Data.Map as M
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified System.FilePath.ByteString as P
import Data.ByteString.Lazy.UTF8 (fromString)
import Control.Concurrent.Async
@ -96,12 +95,12 @@ gen r u rc gc rs = do
, getRepo = return r
, gitconfig = gc
, localpath = if bupLocal buprepo && not (null buprepo)
then Just buprepo
then Just (toOsPath buprepo)
else Nothing
, remotetype = remote
, availability = if null buprepo
then pure LocallyAvailable
else checkPathAvailability (bupLocal buprepo) buprepo
else checkPathAvailability (bupLocal buprepo) (toOsPath buprepo)
, readonly = False
, appendonly = False
, untrustworthy = False
@ -270,7 +269,7 @@ onBupRemote r runner command params = do
(sshcmd, sshparams) <- Ssh.toRepo NoConsumeStdin r c remotecmd
liftIO $ runner sshcmd sshparams
where
path = fromRawFilePath $ Git.repoPath r
path = fromOsPath $ Git.repoPath r
base = fromMaybe path (stripPrefix "/~/" path)
dir = shellEscape base
@ -299,11 +298,11 @@ bup2GitRemote :: BupRepo -> IO Git.Repo
bup2GitRemote "" = do
-- bup -r "" operates on ~/.bup
h <- myHomeDir
Git.Construct.fromPath $ toRawFilePath $ h </> ".bup"
Git.Construct.fromPath $ toOsPath h </> literalOsPath ".bup"
bup2GitRemote r
| bupLocal r =
if "/" `isPrefixOf` r
then Git.Construct.fromPath (toRawFilePath r)
then Git.Construct.fromPath (toOsPath r)
else giveup "please specify an absolute path"
| otherwise = Git.Construct.fromUrl $ "ssh://" ++ host ++ slash dir
where
@ -335,10 +334,10 @@ bupLocal = notElem ':'
lockBup :: Bool -> Remote -> Annex a -> Annex a
lockBup writer r a = do
dir <- fromRepo gitAnnexRemotesDir
unlessM (liftIO $ doesDirectoryExist (fromRawFilePath dir)) $
unlessM (liftIO $ doesDirectoryExist dir) $
createAnnexDirectory dir
let remoteid = fromUUID (uuid r)
let lck = dir P.</> remoteid <> ".lck"
let lck = dir </> remoteid <> literalOsPath ".lck"
if writer
then withExclusiveLock lck a
else withSharedLock lck a

View file

@ -20,8 +20,6 @@ module Remote.GCrypt (
import qualified Data.Map as M
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified System.FilePath.ByteString as P
import Data.Default
import Annex.Common
@ -51,16 +49,17 @@ import Utility.Metered
import Annex.UUID
import Annex.Ssh
import Annex.Perms
import Messages.Progress
import Types.ProposedAccepted
import Logs.Remote
import qualified Remote.Rsync
import qualified Remote.Directory
import Utility.Rsync
import Utility.Tmp
import Logs.Remote
import Utility.Gpg
import Utility.SshHost
import Utility.Directory.Create
import Messages.Progress
import Types.ProposedAccepted
import qualified Utility.FileIO as F
remote :: RemoteType
remote = specialRemoteType $ RemoteType
@ -304,10 +303,10 @@ setupRepo gcryptid r
- which is needed for rsync of objects to it to work.
-}
rsyncsetup = Remote.Rsync.withRsyncScratchDir $ \tmp -> do
createAnnexDirectory (toRawFilePath tmp P.</> objectDir)
createAnnexDirectory (tmp </> objectDir)
dummycfg <- liftIO dummyRemoteGitConfig
let (rsynctransport, rsyncurl, _) = rsyncTransport r dummycfg
let tmpconfig = tmp </> "config"
let tmpconfig = fromOsPath $ tmp </> literalOsPath "config"
opts <- rsynctransport
void $ liftIO $ rsync $ opts ++
[ Param $ rsyncurl ++ "/config"
@ -318,7 +317,7 @@ setupRepo gcryptid r
void $ Git.Config.changeFile tmpconfig denyNonFastForwards (Git.Config.boolConfig' False)
ok <- liftIO $ rsync $ opts ++
[ Param "--recursive"
, Param $ tmp ++ "/"
, Param $ fromOsPath tmp ++ "/"
, Param rsyncurl
]
unless ok $
@ -388,17 +387,18 @@ store' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> Storer
store' repo r rsyncopts accessmethod
| not $ Git.repoIsUrl repo =
byteStorer $ \k b p -> guardUsable repo (giveup "cannot access remote") $ liftIO $ do
let tmpdir = Git.repoPath repo P.</> "tmp" P.</> keyFile k
let tmpdir = Git.repoPath repo </> literalOsPath "tmp" </> keyFile k
void $ tryIO $ createDirectoryUnder [Git.repoPath repo] tmpdir
let tmpf = tmpdir P.</> keyFile k
meteredWriteFile p (fromRawFilePath tmpf) b
let destdir = parentDir $ toRawFilePath $ gCryptLocation repo k
let tmpf = tmpdir </> keyFile k
meteredWriteFile p tmpf b
let destdir = parentDir $ gCryptLocation repo k
Remote.Directory.finalizeStoreGeneric (Git.repoPath repo) tmpdir destdir
| Git.repoIsSsh repo = if accessShell r
then fileStorer $ \k f p -> do
oh <- mkOutputHandler
ok <- Ssh.rsyncHelper oh (Just p)
=<< Ssh.rsyncParamsRemote r Upload k f
=<< Ssh.rsyncParamsRemote r Upload k
(fromOsPath f)
unless ok $
giveup "rsync failed"
else storersync
@ -416,11 +416,11 @@ retrieve' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> Ret
retrieve' repo r rsyncopts accessmethod
| not $ Git.repoIsUrl repo = byteRetriever $ \k sink ->
guardUsable repo (giveup "cannot access remote") $
sink =<< liftIO (L.readFile $ gCryptLocation repo k)
sink =<< liftIO (F.readFile $ gCryptLocation repo k)
| Git.repoIsSsh repo = if accessShell r
then fileRetriever $ \f k p -> do
ps <- Ssh.rsyncParamsRemote r Download k
(fromRawFilePath f)
(fromOsPath f)
oh <- mkOutputHandler
unlessM (Ssh.rsyncHelper oh (Just p) ps) $
giveup "rsync failed"
@ -439,8 +439,8 @@ remove' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> Remov
remove' repo r rsyncopts accessmethod proof k
| not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $
liftIO $ Remote.Directory.removeDirGeneric True
(toRawFilePath (gCryptTopDir repo))
(parentDir (toRawFilePath (gCryptLocation repo k)))
(gCryptTopDir repo)
(parentDir (gCryptLocation repo k))
| Git.repoIsSsh repo = shellOrRsync r removeshell removersync
| accessmethod == AccessRsyncOverSsh = removersync
| otherwise = unsupportedUrl
@ -465,14 +465,14 @@ checkKey' repo r rsyncopts accessmethod k
checkrsync = Remote.Rsync.checkKey rsyncopts k
checkshell = Ssh.inAnnex repo k
gCryptTopDir :: Git.Repo -> FilePath
gCryptTopDir repo = Git.repoLocation repo </> fromRawFilePath objectDir
gCryptTopDir :: Git.Repo -> OsPath
gCryptTopDir repo = toOsPath (Git.repoLocation repo) </> objectDir
{- Annexed objects are hashed using lower-case directories for max
- portability. -}
gCryptLocation :: Git.Repo -> Key -> FilePath
gCryptLocation :: Git.Repo -> Key -> OsPath
gCryptLocation repo key = gCryptTopDir repo
</> fromRawFilePath (keyPath key (hashDirLower def))
</> keyPath key (hashDirLower def)
data AccessMethod = AccessRsyncOverSsh | AccessGitAnnexShell
deriving (Eq)
@ -529,8 +529,8 @@ getConfigViaRsync r gc = do
let (rsynctransport, rsyncurl, _) = rsyncTransport r gc
opts <- rsynctransport
liftIO $ do
withTmpFile (toOsPath "tmpconfig") $ \tmpconfig _ -> do
let tmpconfig' = fromRawFilePath $ fromOsPath tmpconfig
withTmpFile (literalOsPath "tmpconfig") $ \tmpconfig _ -> do
let tmpconfig' = fromOsPath tmpconfig
void $ rsync $ opts ++
[ Param $ rsyncurl ++ "/config"
, Param tmpconfig'

View file

@ -49,6 +49,7 @@ import Logs.Cluster.Basic
import Utility.Metered
import Utility.Env
import Utility.Batch
import qualified Utility.FileIO as F
import Remote.Helper.Git
import Remote.Helper.Messages
import Remote.Helper.ExportImport
@ -324,10 +325,9 @@ tryGitConfigRead autoinit r hasuuid
geturlconfig = Url.withUrlOptionsPromptingCreds $ \uo -> do
let url = Git.repoLocation r ++ "/config"
v <- withTmpFile (toOsPath "git-annex.tmp") $ \tmpfile h -> do
v <- withTmpFile (literalOsPath "git-annex.tmp") $ \tmpfile h -> do
liftIO $ hClose h
let tmpfile' = fromRawFilePath $ fromOsPath tmpfile
Url.download' nullMeterUpdate Nothing url tmpfile' uo >>= \case
Url.download' nullMeterUpdate Nothing url tmpfile uo >>= \case
Right () ->
pipedconfig Git.Config.ConfigNullList
False url "git"
@ -335,7 +335,7 @@ tryGitConfigRead autoinit r hasuuid
, Param "--null"
, Param "--list"
, Param "--file"
, File tmpfile'
, File (fromOsPath tmpfile)
] >>= return . \case
Right r' -> Right r'
Left exitcode -> Left $ "git config exited " ++ show exitcode
@ -470,9 +470,9 @@ keyUrls gc repo r key = map tourl locs'
| remoteAnnexBare remoteconfig == Just False = annexLocationsNonBare gc key
| otherwise = annexLocationsBare gc key
#ifndef mingw32_HOST_OS
locs' = map fromRawFilePath locs
locs' = map fromOsPath locs
#else
locs' = map (replace "\\" "/" . fromRawFilePath) locs
locs' = map (replace "\\" "/" . fromOsPath) locs
#endif
remoteconfig = gitconfig r
@ -560,12 +560,12 @@ lockKey' repo r st@(State connpool duc _ _ _) key callback
failedlock = giveup "can't lock content"
{- Tries to copy a key's content from a remote's annex to a file. -}
copyFromRemote :: Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
copyFromRemote :: Remote -> State -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification
copyFromRemote r st key file dest meterupdate vc = do
repo <- getRepo r
copyFromRemote'' repo r st key file dest meterupdate vc
copyFromRemote'' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
copyFromRemote'' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification
copyFromRemote'' repo r st@(State connpool _ _ _ _) key af dest meterupdate vc
| isP2PHttp r = copyp2phttp
| Git.repoIsHttp repo = verifyKeyContentIncrementally vc key $ \iv -> do
@ -603,9 +603,8 @@ copyFromRemote'' repo r st@(State connpool _ _ _ _) key af dest meterupdate vc
<|> remoteAnnexBwLimit (gitconfig r)
copyp2phttp = verifyKeyContentIncrementally vc key $ \iv -> do
startsz <- liftIO $ tryWhenExists $
getFileSize (toRawFilePath dest)
bracketIO (openBinaryFile dest ReadWriteMode) (hClose) $ \h -> do
startsz <- liftIO $ tryWhenExists $ getFileSize dest
bracketIO (F.openBinaryFile dest ReadWriteMode) (hClose) $ \h -> do
metered (Just meterupdate) key bwlimit $ \_ p -> do
p' <- case startsz of
Just startsz' -> liftIO $ do
@ -617,16 +616,18 @@ copyFromRemote'' repo r st@(State connpool _ _ _ _) key af dest meterupdate vc
Valid -> return ()
Invalid -> giveup "Transfer failed"
copyFromRemoteCheap :: State -> Git.Repo -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ())
copyFromRemoteCheap :: State -> Git.Repo -> Maybe (Key -> AssociatedFile -> OsPath -> Annex ())
#ifndef mingw32_HOST_OS
copyFromRemoteCheap st repo
| not $ Git.repoIsUrl repo = Just $ \key _af file -> guardUsable repo (giveup "cannot access remote") $ do
gc <- getGitConfigFromState st
loc <- liftIO $ gitAnnexLocation key repo gc
liftIO $ ifM (R.doesPathExist loc)
liftIO $ ifM (doesFileExist loc)
( do
absloc <- absPath loc
R.createSymbolicLink absloc (toRawFilePath file)
R.createSymbolicLink
(fromOsPath absloc)
(fromOsPath file)
, giveup "remote does not contain key"
)
| otherwise = Nothing
@ -635,12 +636,12 @@ copyFromRemoteCheap _ _ = Nothing
#endif
{- Tries to copy a key's content to a remote's annex. -}
copyToRemote :: Remote -> State -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
copyToRemote :: Remote -> State -> Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex ()
copyToRemote r st key af o meterupdate = do
repo <- getRepo r
copyToRemote' repo r st key af o meterupdate
copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex ()
copyToRemote' repo r st@(State connpool duc _ _ _) key af o meterupdate
| isP2PHttp r = prepsendwith copyp2phttp
| not $ Git.repoIsUrl repo = ifM duc
@ -683,7 +684,7 @@ copyToRemote' repo r st@(State connpool duc _ _ _) key af o meterupdate
Nothing -> return True
logStatusAfter NoLiveUpdate key $ Annex.Content.getViaTmp rsp verify key af (Just sz) $ \dest ->
metered (Just (combineMeterUpdate meterupdate p)) key bwlimit $ \_ p' ->
copier object (fromRawFilePath dest) key p' checksuccess verify
copier object dest key p' checksuccess verify
)
unless res $
failedsend
@ -719,10 +720,12 @@ fsckOnRemote r params
r' <- Git.Config.read r
environ <- getEnvironment
let environ' = addEntries
[ ("GIT_WORK_TREE", fromRawFilePath $ Git.repoPath r')
, ("GIT_DIR", fromRawFilePath $ Git.localGitDir r')
[ ("GIT_WORK_TREE", fromOsPath $ Git.repoPath r')
, ("GIT_DIR", fromOsPath $ Git.localGitDir r')
] environ
batchCommandEnv program (Param "fsck" : params) (Just environ')
batchCommandEnv (fromOsPath program)
(Param "fsck" : params)
(Just environ')
{- The passed repair action is run in the Annex monad of the remote. -}
repairRemote :: Git.Repo -> Annex Bool -> Annex (IO Bool)
@ -816,7 +819,7 @@ wantHardLink = (annexHardLink <$> Annex.getGitConfig)
-- because they can be modified at any time.
<&&> (not <$> annexThin <$> Annex.getGitConfig)
type FileCopier = FilePath -> FilePath -> Key -> MeterUpdate -> Annex Bool -> VerifyConfig -> Annex (Bool, Verification)
type FileCopier = OsPath -> OsPath -> Key -> MeterUpdate -> Annex Bool -> VerifyConfig -> Annex (Bool, Verification)
-- If either the remote or local repository wants to use hard links,
-- the copier will do so (falling back to copying if a hard link cannot be
@ -829,14 +832,14 @@ type FileCopier = FilePath -> FilePath -> Key -> MeterUpdate -> Annex Bool -> Ve
mkFileCopier :: Bool -> State -> Annex FileCopier
mkFileCopier remotewanthardlink (State _ _ copycowtried _ _) = do
localwanthardlink <- wantHardLink
let linker = \src dest -> R.createLink (toRawFilePath src) (toRawFilePath dest) >> return True
let linker = \src dest -> R.createLink (fromOsPath src) (fromOsPath dest) >> return True
if remotewanthardlink || localwanthardlink
then return $ \src dest k p check verifyconfig ->
ifM (liftIO (catchBoolIO (linker src dest)))
( ifM check
( return (True, Verified)
, do
verificationOfContentFailed (toRawFilePath dest)
verificationOfContentFailed dest
return (False, UnVerified)
)
, copier src dest k p check verifyconfig
@ -845,11 +848,11 @@ mkFileCopier remotewanthardlink (State _ _ copycowtried _ _) = do
where
copier src dest k p check verifyconfig = do
iv <- startVerifyKeyContentIncrementally verifyconfig k
liftIO (fileCopier copycowtried src dest p iv) >>= \case
liftIO (fileCopier copycowtried (fromOsPath src) (fromOsPath dest) p iv) >>= \case
Copied -> ifM check
( finishVerifyKeyContentIncrementally iv
, do
verificationOfContentFailed (toRawFilePath dest)
verificationOfContentFailed dest
return (False, UnVerified)
)
CopiedCoW -> unVerified check

View file

@ -20,6 +20,7 @@ import Types.NumCopies
import qualified Annex
import qualified Git
import qualified Git.Types as Git
import qualified Git.Config
import qualified Git.Url
import qualified Git.Remote
import qualified Git.GCrypt
@ -36,12 +37,12 @@ import Annex.Ssh
import Annex.UUID
import Crypto
import Backend.Hash
import Logs.Remote
import Logs.RemoteState
import Utility.Hash
import Utility.SshHost
import Utility.Url
import Logs.Remote
import Logs.RemoteState
import qualified Git.Config
import qualified Utility.FileIO as F
import qualified Network.GitLFS as LFS
import Control.Concurrent.STM
@ -380,7 +381,7 @@ extractKeySize k
| isEncKey k = Nothing
| otherwise = fromKey keySize k
mkUploadRequest :: RemoteStateHandle -> Key -> FilePath -> Annex (LFS.TransferRequest, LFS.SHA256, Integer)
mkUploadRequest :: RemoteStateHandle -> Key -> OsPath -> Annex (LFS.TransferRequest, LFS.SHA256, Integer)
mkUploadRequest rs k content = case (extractKeySha256 k, extractKeySize k) of
(Just sha256, Just size) ->
ret sha256 size
@ -390,11 +391,11 @@ mkUploadRequest rs k content = case (extractKeySha256 k, extractKeySize k) of
ret sha256 size
_ -> do
sha256 <- calcsha256
size <- liftIO $ getFileSize (toRawFilePath content)
size <- liftIO $ getFileSize content
rememberboth sha256 size
ret sha256 size
where
calcsha256 = liftIO $ T.pack . show . sha2_256 <$> L.readFile content
calcsha256 = liftIO $ T.pack . show . sha2_256 <$> F.readFile content
ret sha256 size = do
let obj = LFS.TransferRequestObject
{ LFS.req_oid = sha256
@ -497,7 +498,7 @@ retrieve rs h = fileRetriever' $ \dest k p iv -> getLFSEndpoint LFS.RequestDownl
Nothing -> giveup "unable to parse git-lfs server download url"
Just req -> do
uo <- getUrlOptions
liftIO $ downloadConduit p iv req (fromRawFilePath dest) uo
liftIO $ downloadConduit p iv req dest uo
-- Since git-lfs does not support removing content, nothing needs to be
-- done to lock content in the remote, except for checking that the content

View file

@ -53,7 +53,7 @@ storeFanout lu k logstatus remoteuuid us =
when (u /= remoteuuid) $
logChange lu k u logstatus
retrieve :: RemoteGitConfig -> (ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
retrieve :: RemoteGitConfig -> (ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification
retrieve gc runner k af dest p verifyconfig = do
iv <- startVerifyKeyContentIncrementally verifyconfig k
let bwlimit = remoteAnnexBwLimitDownload gc <|> remoteAnnexBwLimit gc

View file

@ -66,7 +66,7 @@ git_annex_shell cs r command params fields
let params' = case (debugenabled, debugselector) of
(True, NoDebugSelector) -> Param "--debug" : params
_ -> params
return (Param command : File (fromRawFilePath dir) : params')
return (Param command : File (fromOsPath dir) : params')
uuidcheck NoUUID = []
uuidcheck u@(UUID _) = ["--uuid", fromUUID u]
fieldopts

View file

@ -191,7 +191,7 @@ transport (RemoteRepo r gc) url@(RemoteURI uri) th ichan ochan =
runBool [Param "fetch", Param $ Git.repoDescribe r]
send (DONESYNCING url ok)
torSocketFile :: Annex.Annex (Maybe FilePath)
torSocketFile :: Annex.Annex (Maybe OsPath)
torSocketFile = do
u <- getUUID
let ident = fromUUID u