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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -293,12 +293,12 @@ data LocalF c
= TmpContentSize Key (Len -> c) = TmpContentSize Key (Len -> c)
-- ^ Gets size of the temp file where received content may have -- ^ Gets size of the temp file where received content may have
-- been stored. If not present, returns 0. -- 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. -- ^ Gets size of the content of a file. If not present, returns 0.
| ContentSize Key (Maybe Len -> c) | ContentSize Key (Maybe Len -> c)
-- ^ Gets size of the content of a key, when the full content is -- ^ Gets size of the content of a key, when the full content is
-- present. -- 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. -- ^ Reads the content of a key and sends it to the callback.
-- Must run the callback, or terminate the protocol connection. -- 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 -- Note: The ByteString may not contain the entire remaining content
-- of the key. Only once the temp file size == Len has the whole -- of the key. Only once the temp file size == Len has the whole
-- content been transferred. -- 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. -- ^ 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) | 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 -- ^ Reads content from the Proto L.ByteString and sends it to the
@ -481,7 +481,7 @@ removeBeforeRemoteEndTime remoteendtime key = do
REMOVE_BEFORE remoteendtime key REMOVE_BEFORE remoteendtime key
checkSuccessFailurePlus 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 = get dest key iv af m p =
receiveContent (Just m) p sizer storer noothermessages $ \offset -> receiveContent (Just m) p sizer storer noothermessages $ \offset ->
GET offset (ProtoAssociatedFile af) key GET offset (ProtoAssociatedFile af) key
@ -727,7 +727,7 @@ checkCONNECTServerMode service servermode a =
(ServeReadOnly, UploadPack) -> a Nothing (ServeReadOnly, UploadPack) -> a Nothing
(ServeReadOnly, ReceivePack) -> a (Just sendReadOnlyError) (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) sendContent key af o offset@(Offset n) p = go =<< local (contentSize key)
where where
go (Just (Len totallen)) = do 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.Map as M
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified System.FilePath.ByteString as P
import Data.ByteString.Lazy.UTF8 (fromString) import Data.ByteString.Lazy.UTF8 (fromString)
import Control.Concurrent.Async import Control.Concurrent.Async
@ -96,12 +95,12 @@ gen r u rc gc rs = do
, getRepo = return r , getRepo = return r
, gitconfig = gc , gitconfig = gc
, localpath = if bupLocal buprepo && not (null buprepo) , localpath = if bupLocal buprepo && not (null buprepo)
then Just buprepo then Just (toOsPath buprepo)
else Nothing else Nothing
, remotetype = remote , remotetype = remote
, availability = if null buprepo , availability = if null buprepo
then pure LocallyAvailable then pure LocallyAvailable
else checkPathAvailability (bupLocal buprepo) buprepo else checkPathAvailability (bupLocal buprepo) (toOsPath buprepo)
, readonly = False , readonly = False
, appendonly = False , appendonly = False
, untrustworthy = False , untrustworthy = False
@ -270,7 +269,7 @@ onBupRemote r runner command params = do
(sshcmd, sshparams) <- Ssh.toRepo NoConsumeStdin r c remotecmd (sshcmd, sshparams) <- Ssh.toRepo NoConsumeStdin r c remotecmd
liftIO $ runner sshcmd sshparams liftIO $ runner sshcmd sshparams
where where
path = fromRawFilePath $ Git.repoPath r path = fromOsPath $ Git.repoPath r
base = fromMaybe path (stripPrefix "/~/" path) base = fromMaybe path (stripPrefix "/~/" path)
dir = shellEscape base dir = shellEscape base
@ -299,11 +298,11 @@ bup2GitRemote :: BupRepo -> IO Git.Repo
bup2GitRemote "" = do bup2GitRemote "" = do
-- bup -r "" operates on ~/.bup -- bup -r "" operates on ~/.bup
h <- myHomeDir h <- myHomeDir
Git.Construct.fromPath $ toRawFilePath $ h </> ".bup" Git.Construct.fromPath $ toOsPath h </> literalOsPath ".bup"
bup2GitRemote r bup2GitRemote r
| bupLocal r = | bupLocal r =
if "/" `isPrefixOf` r if "/" `isPrefixOf` r
then Git.Construct.fromPath (toRawFilePath r) then Git.Construct.fromPath (toOsPath r)
else giveup "please specify an absolute path" else giveup "please specify an absolute path"
| otherwise = Git.Construct.fromUrl $ "ssh://" ++ host ++ slash dir | otherwise = Git.Construct.fromUrl $ "ssh://" ++ host ++ slash dir
where where
@ -335,10 +334,10 @@ bupLocal = notElem ':'
lockBup :: Bool -> Remote -> Annex a -> Annex a lockBup :: Bool -> Remote -> Annex a -> Annex a
lockBup writer r a = do lockBup writer r a = do
dir <- fromRepo gitAnnexRemotesDir dir <- fromRepo gitAnnexRemotesDir
unlessM (liftIO $ doesDirectoryExist (fromRawFilePath dir)) $ unlessM (liftIO $ doesDirectoryExist dir) $
createAnnexDirectory dir createAnnexDirectory dir
let remoteid = fromUUID (uuid r) let remoteid = fromUUID (uuid r)
let lck = dir P.</> remoteid <> ".lck" let lck = dir </> remoteid <> literalOsPath ".lck"
if writer if writer
then withExclusiveLock lck a then withExclusiveLock lck a
else withSharedLock lck a else withSharedLock lck a

View file

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

View file

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

View file

@ -20,6 +20,7 @@ import Types.NumCopies
import qualified Annex import qualified Annex
import qualified Git import qualified Git
import qualified Git.Types as Git import qualified Git.Types as Git
import qualified Git.Config
import qualified Git.Url import qualified Git.Url
import qualified Git.Remote import qualified Git.Remote
import qualified Git.GCrypt import qualified Git.GCrypt
@ -36,12 +37,12 @@ import Annex.Ssh
import Annex.UUID import Annex.UUID
import Crypto import Crypto
import Backend.Hash import Backend.Hash
import Logs.Remote
import Logs.RemoteState
import Utility.Hash import Utility.Hash
import Utility.SshHost import Utility.SshHost
import Utility.Url import Utility.Url
import Logs.Remote import qualified Utility.FileIO as F
import Logs.RemoteState
import qualified Git.Config
import qualified Network.GitLFS as LFS import qualified Network.GitLFS as LFS
import Control.Concurrent.STM import Control.Concurrent.STM
@ -380,7 +381,7 @@ extractKeySize k
| isEncKey k = Nothing | isEncKey k = Nothing
| otherwise = fromKey keySize k | 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 mkUploadRequest rs k content = case (extractKeySha256 k, extractKeySize k) of
(Just sha256, Just size) -> (Just sha256, Just size) ->
ret sha256 size ret sha256 size
@ -390,11 +391,11 @@ mkUploadRequest rs k content = case (extractKeySha256 k, extractKeySize k) of
ret sha256 size ret sha256 size
_ -> do _ -> do
sha256 <- calcsha256 sha256 <- calcsha256
size <- liftIO $ getFileSize (toRawFilePath content) size <- liftIO $ getFileSize content
rememberboth sha256 size rememberboth sha256 size
ret sha256 size ret sha256 size
where 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 ret sha256 size = do
let obj = LFS.TransferRequestObject let obj = LFS.TransferRequestObject
{ LFS.req_oid = sha256 { 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" Nothing -> giveup "unable to parse git-lfs server download url"
Just req -> do Just req -> do
uo <- getUrlOptions 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 -- 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 -- 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) $ when (u /= remoteuuid) $
logChange lu k u logstatus 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 retrieve gc runner k af dest p verifyconfig = do
iv <- startVerifyKeyContentIncrementally verifyconfig k iv <- startVerifyKeyContentIncrementally verifyconfig k
let bwlimit = remoteAnnexBwLimitDownload gc <|> remoteAnnexBwLimit gc 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 let params' = case (debugenabled, debugselector) of
(True, NoDebugSelector) -> Param "--debug" : params (True, NoDebugSelector) -> Param "--debug" : params
_ -> params _ -> params
return (Param command : File (fromRawFilePath dir) : params') return (Param command : File (fromOsPath dir) : params')
uuidcheck NoUUID = [] uuidcheck NoUUID = []
uuidcheck u@(UUID _) = ["--uuid", fromUUID u] uuidcheck u@(UUID _) = ["--uuid", fromUUID u]
fieldopts fieldopts

View file

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