more OsPath conversion (502/749)
Sponsored-by: Kevin Mueller on Patreon
This commit is contained in:
Joey Hess
parent
b28433072c
commit
0b9e9cbf70
15 changed files with 147 additions and 149 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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. -}
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
15
P2P/Annex.hs
15
P2P/Annex.hs
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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'
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue