diff --git a/Annex/AdjustedBranch/Merge.hs b/Annex/AdjustedBranch/Merge.hs index 7817bdbeca..dd9ac19a0c 100644 --- a/Annex/AdjustedBranch/Merge.hs +++ b/Annex/AdjustedBranch/Merge.hs @@ -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 diff --git a/Annex/Init.hs b/Annex/Init.hs index ea7cd09765..43fbafe07d 100644 --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -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) diff --git a/Annex/Locations.hs b/Annex/Locations.hs index 40f7885733..94874e5d42 100644 --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -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. -} diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs index 1c1abf4fd5..aa04ff1a25 100644 --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -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 = diff --git a/P2P/Annex.hs b/P2P/Annex.hs index c4328547a2..a6beb64eb3 100644 --- a/P2P/Annex.hs +++ b/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) diff --git a/P2P/Http/Client.hs b/P2P/Http/Client.hs index 7e40419beb..bfaa14bc89 100644 --- a/P2P/Http/Client.hs +++ b/P2P/Http/Client.hs @@ -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 diff --git a/P2P/IO.hs b/P2P/IO.hs index 4959c4f1f2..611f6982cf 100644 --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -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 diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs index ea00fb3ebc..8eb602d00b 100644 --- a/P2P/Protocol.hs +++ b/P2P/Protocol.hs @@ -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 diff --git a/Remote/Bup.hs b/Remote/Bup.hs index c480d74dee..5003608acd 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -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 diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index ce8564bd76..a06ceb2c91 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -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' diff --git a/Remote/Git.hs b/Remote/Git.hs index c9108700e4..15e99be129 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -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 diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs index 841c51a1f5..4103309286 100644 --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -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 diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs index 0de6590d00..d7f4b1048b 100644 --- a/Remote/Helper/P2P.hs +++ b/Remote/Helper/P2P.hs @@ -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 diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs index 3832a88568..d279476488 100644 --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -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 diff --git a/RemoteDaemon/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs index 515e3d333b..550a9404dd 100644 --- a/RemoteDaemon/Transport/Tor.hs +++ b/RemoteDaemon/Transport/Tor.hs @@ -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