From 2c8cf06e7523683a02c759bc7fff25c8178c4c0b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 5 Nov 2020 18:45:37 -0400 Subject: [PATCH] more RawFilePath conversion Converted file mode setting to it, and follow-on changes. Compiles up through 369/646. This commit was sponsored by Ethan Aubin. --- Annex/Branch.hs | 3 +- Annex/Content/LowLevel.hs | 31 +++++++-------- Annex/Content/PointerFile.hs | 2 +- Annex/Link.hs | 10 ++--- Annex/Locations.hs | 8 ++-- Annex/Perms.hs | 26 ++++++------ Assistant/Ssh.hs | 4 +- Common.hs | 1 + Creds.hs | 3 +- Database/Benchmark.hs | 9 +++-- Database/ContentIdentifier.hs | 6 ++- Database/Export.hs | 8 ++-- Database/Fsck.hs | 6 ++- Database/Handle.hs | 4 +- Database/Init.hs | 24 +++++++----- Database/Keys.hs | 7 ++-- Database/Queue.hs | 3 +- Git/Index.hs | 22 ++++++----- Git/Objects.hs | 32 +++++++++------ Git/Repair.hs | 24 ++++++------ Logs/File.hs | 14 +++---- P2P/IO.hs | 2 +- Utility/Directory.hs | 51 ------------------------ Utility/FileMode.hs | 28 +++++++------ Utility/Gpg.hs | 2 +- Utility/MoveFile.hs | 74 +++++++++++++++++++++++++++++++++++ Utility/RawFilePath.hs | 7 +++- Utility/SshConfig.hs | 4 +- Utility/Tor.hs | 2 +- Utility/WebApp.hs | 3 +- git-annex.cabal | 1 + 31 files changed, 239 insertions(+), 182 deletions(-) create mode 100644 Utility/MoveFile.hs diff --git a/Annex/Branch.hs b/Annex/Branch.hs index df949e968c..415980447b 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -77,6 +77,7 @@ import Annex.Branch.Transitions import qualified Annex import Annex.Hook import Utility.Directory.Stream +import qualified Utility.RawFilePath as R {- Name of the branch that is used to store git-annex's information. -} name :: Git.Ref @@ -447,7 +448,7 @@ mergeIndex jl branches = do prepareModifyIndex :: JournalLocked -> Annex () prepareModifyIndex _jl = do index <- fromRepo gitAnnexIndex - void $ liftIO $ tryIO $ removeFile $ index ++ ".lock" + void $ liftIO $ tryIO $ R.removeLink (index <> ".lock") {- Runs an action using the branch's index file. -} withIndex :: Annex a -> Annex a diff --git a/Annex/Content/LowLevel.hs b/Annex/Content/LowLevel.hs index b8e2bd847a..f202e6e8cf 100644 --- a/Annex/Content/LowLevel.hs +++ b/Annex/Content/LowLevel.hs @@ -9,8 +9,6 @@ module Annex.Content.LowLevel where -import System.PosixCompat.Files - import Annex.Common import Logs.Transfer import qualified Annex @@ -20,6 +18,9 @@ import Utility.DataUnits import Utility.CopyFile import qualified Utility.RawFilePath as R +import System.PosixCompat.Files +import qualified System.FilePath.ByteString as P + {- Runs the secure erase command if set, otherwise does nothing. - File may or may not be deleted at the end; caller is responsible for - making sure it's deleted. -} @@ -59,32 +60,30 @@ linkOrCopy' canhardlink key src dest destmode = catchDefaultIO Nothing $ s <- getstat if linkCount s > 1 then copy s - else liftIO (R.createLink src dest >> preserveGitMode dest' destmode >> return (Just Linked)) + else liftIO (R.createLink src dest >> preserveGitMode dest destmode >> return (Just Linked)) `catchIO` const (copy s) - copy s = ifM (checkedCopyFile' key src' dest' destmode s) + copy s = ifM (checkedCopyFile' key src dest destmode s) ( return (Just Copied) , return Nothing ) getstat = liftIO $ R.getFileStatus src - src' = fromRawFilePath src - dest' = fromRawFilePath dest {- Checks disk space before copying. -} -checkedCopyFile :: Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool +checkedCopyFile :: Key -> RawFilePath -> RawFilePath -> Maybe FileMode -> Annex Bool checkedCopyFile key src dest destmode = catchBoolIO $ checkedCopyFile' key src dest destmode - =<< liftIO (getFileStatus src) + =<< liftIO (R.getFileStatus src) -checkedCopyFile' :: Key -> FilePath -> FilePath -> Maybe FileMode -> FileStatus -> Annex Bool +checkedCopyFile' :: Key -> RawFilePath -> RawFilePath -> Maybe FileMode -> FileStatus -> Annex Bool checkedCopyFile' key src dest destmode s = catchBoolIO $ - ifM (checkDiskSpace' (fromIntegral $ fileSize s) (Just $ takeDirectory dest) key 0 True) + ifM (checkDiskSpace' (fromIntegral $ fileSize s) (Just $ P.takeDirectory dest) key 0 True) ( liftIO $ - copyFileExternal CopyAllMetaData src dest + copyFileExternal CopyAllMetaData (fromRawFilePath src) (fromRawFilePath dest) <&&> preserveGitMode dest destmode , return False ) -preserveGitMode :: FilePath -> Maybe FileMode -> IO Bool +preserveGitMode :: RawFilePath -> Maybe FileMode -> IO Bool preserveGitMode f (Just mode) | isExecutable mode = catchBoolIO $ do modifyFileMode f $ addModes executeModes @@ -102,12 +101,12 @@ preserveGitMode _ _ = return True - to be downloaded from the free space. This way, we avoid overcommitting - when doing concurrent downloads. -} -checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Bool -> Annex Bool +checkDiskSpace :: Maybe RawFilePath -> Key -> Integer -> Bool -> Annex Bool checkDiskSpace destdir key = checkDiskSpace' (fromMaybe 1 (fromKey keySize key)) destdir key {- Allows specifying the size of the key, if it's known, which is useful - as not all keys know their size. -} -checkDiskSpace' :: Integer -> Maybe FilePath -> Key -> Integer -> Bool -> Annex Bool +checkDiskSpace' :: Integer -> Maybe RawFilePath -> Key -> Integer -> Bool -> Annex Bool checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getState Annex.force) ( return True , do @@ -120,7 +119,7 @@ checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getSta inprogress <- if samefilesystem then sizeOfDownloadsInProgress (/= key) else pure 0 - dir >>= liftIO . getDiskFree >>= \case + dir >>= liftIO . getDiskFree . fromRawFilePath >>= \case Just have -> do reserve <- annexDiskReserve <$> Annex.getGitConfig let delta = need + reserve - have - alreadythere + inprogress @@ -131,7 +130,7 @@ checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getSta _ -> return True ) where - dir = maybe (fromRawFilePath <$> fromRepo gitAnnexDir) return destdir + dir = maybe (fromRepo gitAnnexDir) return destdir needMoreDiskSpace :: Integer -> String needMoreDiskSpace n = "not enough free space, need " ++ diff --git a/Annex/Content/PointerFile.hs b/Annex/Content/PointerFile.hs index e13f2ad1ae..1e23167a42 100644 --- a/Annex/Content/PointerFile.hs +++ b/Annex/Content/PointerFile.hs @@ -43,7 +43,7 @@ populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f) (ic, populated) <- replaceWorkTreeFile f' $ \tmp -> do let tmp' = toRawFilePath tmp ok <- linkOrCopy k obj tmp' destmode >>= \case - Just _ -> thawContent tmp >> return True + Just _ -> thawContent tmp' >> return True Nothing -> liftIO (writePointerFile tmp' k destmode) >> return False ic <- withTSDelta (liftIO . genInodeCache tmp') return (ic, ok) diff --git a/Annex/Link.hs b/Annex/Link.hs index b9f6a662df..d7353d7889 100644 --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -203,7 +203,7 @@ restagePointerFile (Restage True) f orig = withTSDelta $ \tsd -> runner :: Git.Queue.InternalActionRunner Annex runner = Git.Queue.InternalActionRunner "restagePointerFile" $ \r l -> do realindex <- liftIO $ Git.Index.currentIndexFile r - let lock = Git.Index.indexFileLock realindex + let lock = fromRawFilePath (Git.Index.indexFileLock realindex) lockindex = liftIO $ catchMaybeIO $ Git.LockFile.openLock' lock unlockindex = liftIO . maybe noop Git.LockFile.closeLock showwarning = warning $ unableToRestage Nothing @@ -211,8 +211,8 @@ restagePointerFile (Restage True) f orig = withTSDelta $ \tsd -> go (Just _) = withTmpDirIn (fromRawFilePath $ Git.localGitDir r) "annexindex" $ \tmpdir -> do let tmpindex = tmpdir "index" let updatetmpindex = do - r' <- liftIO $ Git.Env.addGitEnv r Git.Index.indexEnv - =<< Git.Index.indexEnvVal tmpindex + r' <- liftIO $ Git.Env.addGitEnv r Git.Index.indexEnv + =<< Git.Index.indexEnvVal (toRawFilePath tmpindex) -- Avoid git warning about CRLF munging. let r'' = r' { gitGlobalOpts = gitGlobalOpts r' ++ [ Param "-c" @@ -224,9 +224,9 @@ restagePointerFile (Restage True) f orig = withTSDelta $ \tsd -> whenM checkunmodified $ feed f' let replaceindex = catchBoolIO $ do - moveFile tmpindex realindex + moveFile tmpindex (fromRawFilePath realindex) return True - ok <- liftIO (createLinkOrCopy realindex tmpindex) + ok <- liftIO (createLinkOrCopy (fromRawFilePath realindex) tmpindex) <&&> updatetmpindex <&&> liftIO replaceindex unless ok showwarning diff --git a/Annex/Locations.hs b/Annex/Locations.hs index e1e7000637..99ba18d542 100644 --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -471,8 +471,8 @@ gitAnnexMergeLock :: Git.Repo -> FilePath gitAnnexMergeLock r = fromRawFilePath $ gitAnnexDir r P. "merge.lck" {- .git/annex/index is used to stage changes to the git-annex branch -} -gitAnnexIndex :: Git.Repo -> FilePath -gitAnnexIndex r = fromRawFilePath $ gitAnnexDir r P. "index" +gitAnnexIndex :: Git.Repo -> RawFilePath +gitAnnexIndex r = gitAnnexDir r P. "index" {- Holds the ref of the git-annex branch that the index was last updated to. - @@ -482,8 +482,8 @@ gitAnnexIndexStatus :: Git.Repo -> RawFilePath gitAnnexIndexStatus r = gitAnnexDir r P. "index.lck" {- The index file used to generate a filtered branch view._-} -gitAnnexViewIndex :: Git.Repo -> FilePath -gitAnnexViewIndex r = fromRawFilePath $ gitAnnexDir r P. "viewindex" +gitAnnexViewIndex :: Git.Repo -> RawFilePath +gitAnnexViewIndex r = gitAnnexDir r P. "viewindex" {- File containing a log of recently accessed views. -} gitAnnexViewLog :: Git.Repo -> RawFilePath diff --git a/Annex/Perms.hs b/Annex/Perms.hs index 26e30a1470..7af05044c4 100644 --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -37,20 +37,20 @@ import qualified Utility.RawFilePath as R withShared :: (SharedRepository -> Annex a) -> Annex a withShared a = a =<< coreSharedRepository <$> Annex.getGitConfig -setAnnexFilePerm :: FilePath -> Annex () +setAnnexFilePerm :: RawFilePath -> Annex () setAnnexFilePerm = setAnnexPerm False -setAnnexDirPerm :: FilePath -> Annex () +setAnnexDirPerm :: RawFilePath -> Annex () setAnnexDirPerm = setAnnexPerm True {- Sets appropriate file mode for a file or directory in the annex, - other than the content files and content directory. Normally, - don't change the mode, but with core.sharedRepository set, - allow the group to write, etc. -} -setAnnexPerm :: Bool -> FilePath -> Annex () +setAnnexPerm :: Bool -> RawFilePath -> Annex () setAnnexPerm = setAnnexPerm' Nothing -setAnnexPerm' :: Maybe ([FileMode] -> FileMode -> FileMode) -> Bool -> FilePath -> Annex () +setAnnexPerm' :: Maybe ([FileMode] -> FileMode -> FileMode) -> Bool -> RawFilePath -> Annex () setAnnexPerm' modef isdir file = unlessM crippledFileSystem $ withShared $ liftIO . go where @@ -67,7 +67,7 @@ setAnnexPerm' modef isdir file = unlessM crippledFileSystem $ modifyFileMode file $ f [] modef' = fromMaybe addModes modef -resetAnnexFilePerm :: FilePath -> Annex () +resetAnnexFilePerm :: RawFilePath -> Annex () resetAnnexFilePerm = resetAnnexPerm False {- Like setAnnexPerm, but ignores the current mode of the file entirely, @@ -78,7 +78,7 @@ resetAnnexFilePerm = resetAnnexPerm False - which is going to be moved to a non-temporary location and needs - usual modes. -} -resetAnnexPerm :: Bool -> FilePath -> Annex () +resetAnnexPerm :: Bool -> RawFilePath -> Annex () resetAnnexPerm isdir file = unlessM crippledFileSystem $ do defmode <- liftIO defaultFileMode let modef moremodes _oldmode = addModes moremodes defmode @@ -106,7 +106,7 @@ createAnnexDirectory dir = do where createdir p = do liftIO $ R.createDirectory p - setAnnexDirPerm (fromRawFilePath p) + setAnnexDirPerm p {- Create a directory in the git work tree, creating any parent - directories up to the top of the work tree. @@ -131,7 +131,7 @@ createWorkTreeDirectory dir = do - shared repository, the current user may not be able to change a file - owned by another user, so failure to set this mode is ignored. -} -freezeContent :: FilePath -> Annex () +freezeContent :: RawFilePath -> Annex () freezeContent file = unlessM crippledFileSystem $ withShared go where @@ -158,7 +158,7 @@ isContentWritePermOk file = ifM crippledFileSystem Just havemode -> havemode == combineModes (havemode:wantmode) {- Adjusts read mode of annexed file per core.sharedRepository setting. -} -chmodContent :: FilePath -> Annex () +chmodContent :: RawFilePath -> Annex () chmodContent file = unlessM crippledFileSystem $ withShared go where @@ -171,7 +171,7 @@ chmodContent file = unlessM crippledFileSystem $ {- Allows writing to an annexed file that freezeContent was called on - before. -} -thawContent :: FilePath -> Annex () +thawContent :: RawFilePath -> Annex () thawContent file = thawPerms $ withShared go where go GroupShared = liftIO $ void $ tryIO $ groupWriteRead file @@ -196,14 +196,14 @@ freezeContentDir :: RawFilePath -> Annex () freezeContentDir file = unlessM crippledFileSystem $ withShared go where - dir = fromRawFilePath $ parentDir file + dir = parentDir file go GroupShared = liftIO $ void $ tryIO $ groupWriteRead dir go AllShared = liftIO $ void $ tryIO $ groupWriteRead dir go _ = liftIO $ preventWrite dir thawContentDir :: RawFilePath -> Annex () thawContentDir file = - thawPerms $ liftIO $ allowWrite . fromRawFilePath $ parentDir file + thawPerms $ liftIO $ allowWrite $ parentDir file {- Makes the directory tree to store an annexed file's content, - with appropriate permissions on each level. -} @@ -213,7 +213,7 @@ createContentDir dest = do createAnnexDirectory dir -- might have already existed with restricted perms unlessM crippledFileSystem $ - liftIO $ allowWrite $ fromRawFilePath dir + liftIO $ allowWrite dir where dir = parentDir dest diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs index 09c3323609..3826f5e70e 100644 --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -248,7 +248,7 @@ installSshKeyPair sshkeypair sshdata = do parentDir $ toRawFilePath $ sshdir sshPrivKeyFile sshdata unlessM (doesFileExist $ sshdir sshPrivKeyFile sshdata) $ - writeFileProtected (sshdir sshPrivKeyFile sshdata) (sshPrivKey sshkeypair) + writeFileProtected (toRawFilePath (sshdir sshPrivKeyFile sshdata)) (sshPrivKey sshkeypair) unlessM (doesFileExist $ sshdir sshPubKeyFile sshdata) $ writeFile (sshdir sshPubKeyFile sshdata) (sshPubKey sshkeypair) @@ -331,7 +331,7 @@ setSshConfig sshdata config = do , "Host " ++ mangledhost ] ++ map (\(k, v) -> "\t" ++ k ++ " " ++ v) (settings ++ config) - setSshConfigMode configfile + setSshConfigMode (toRawFilePath configfile) return $ sshdata { sshHostName = T.pack mangledhost diff --git a/Common.hs b/Common.hs index e741c81517..6069614e6e 100644 --- a/Common.hs +++ b/Common.hs @@ -25,6 +25,7 @@ import Utility.Process as X import Utility.Path as X import Utility.Path.AbsRel as X import Utility.Directory as X +import Utility.MoveFile as X import Utility.Monad as X import Utility.Data as X import Utility.Applicative as X diff --git a/Creds.hs b/Creds.hs index 6ab3b81925..58f1ca1165 100644 --- a/Creds.hs +++ b/Creds.hs @@ -36,6 +36,7 @@ import Utility.Env (getEnv) import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as S import qualified Data.Map as M +import qualified System.FilePath.ByteString as P import Utility.Base64 {- A CredPair can be stored in a file, or in the environment, or @@ -190,7 +191,7 @@ writeCreds :: Creds -> FilePath -> Annex () writeCreds creds file = do d <- fromRepo gitAnnexCredsDir createAnnexDirectory d - liftIO $ writeFileProtected (fromRawFilePath d file) creds + liftIO $ writeFileProtected (d P. toRawFilePath file) creds readCreds :: FilePath -> Annex (Maybe Creds) readCreds f = liftIO . catchMaybeIO . readFileStrict =<< credsFile f diff --git a/Database/Benchmark.hs b/Database/Benchmark.hs index 5a59ac4164..9174ac7f09 100644 --- a/Database/Benchmark.hs +++ b/Database/Benchmark.hs @@ -25,12 +25,13 @@ import Criterion.Main import qualified Data.ByteString.Char8 as B8 import System.Random import Control.Concurrent +import qualified System.FilePath.ByteString as P #endif benchmarkDbs :: CriterionMode -> Integer -> Annex () #ifdef WITH_BENCHMARK benchmarkDbs mode n = withTmpDirIn "." "benchmark" $ \tmpdir -> do - db <- benchDb tmpdir n + db <- benchDb (toRawFilePath tmpdir) n liftIO $ runMode mode [ bgroup "keys database" [ getAssociatedFilesHitBench db @@ -101,18 +102,18 @@ fileMiss = fileN 0 -- 0 is never stored data BenchDb = BenchDb H.DbQueue Integer (MVar Integer) -benchDb :: FilePath -> Integer -> Annex BenchDb +benchDb :: RawFilePath -> Integer -> Annex BenchDb benchDb tmpdir num = do liftIO $ putStrLn $ "setting up database with " ++ show num ++ " items" initDb db SQL.createTables h <- liftIO $ H.openDbQueue H.MultiWriter db SQL.containedTable liftIO $ populateAssociatedFiles h num - sz <- liftIO $ getFileSize (toRawFilePath db) + sz <- liftIO $ getFileSize db liftIO $ putStrLn $ "size of database on disk: " ++ roughSize storageUnits False sz mv <- liftIO $ newMVar 1 return (BenchDb h num mv) where - db = tmpdir show num "db" + db = tmpdir P. toRawFilePath (show num "db") #endif /* WITH_BENCHMARK */ diff --git a/Database/ContentIdentifier.hs b/Database/ContentIdentifier.hs index a58ebed5bb..10f97172ac 100644 --- a/Database/ContentIdentifier.hs +++ b/Database/ContentIdentifier.hs @@ -47,9 +47,11 @@ import qualified Git.Ref import qualified Git.DiffTree as DiffTree import Logs import qualified Logs.ContentIdentifier as Log +import qualified Utility.RawFilePath as R import Database.Persist.Sql hiding (Key) import Database.Persist.TH +import qualified System.FilePath.ByteString as P data ContentIdentifierHandle = ContentIdentifierHandle H.DbQueue @@ -75,8 +77,8 @@ AnnexBranch openDb :: Annex ContentIdentifierHandle openDb = do dbdir <- fromRawFilePath <$> fromRepo gitAnnexContentIdentifierDbDir - let db = dbdir "db" - unlessM (liftIO $ doesFileExist db) $ do + let db = dbdir P. "db" + unlessM (liftIO $ R.doesPathExist db) $ do initDb db $ void $ runMigrationSilent migrateContentIdentifier h <- liftIO $ H.openDbQueue H.SingleWriter db "content_identifiers" diff --git a/Database/Export.hs b/Database/Export.hs index 3400bfaf03..1eba4dd401 100644 --- a/Database/Export.hs +++ b/Database/Export.hs @@ -59,9 +59,11 @@ import Git.Types import Git.Sha import Git.FilePath import qualified Git.DiffTree +import qualified Utility.RawFilePath as R import Database.Persist.Sql hiding (Key) import Database.Persist.TH +import qualified System.FilePath.ByteString as P data ExportHandle = ExportHandle H.DbQueue UUID @@ -96,9 +98,9 @@ ExportTreeCurrent -} openDb :: UUID -> Annex ExportHandle openDb u = do - dbdir <- fromRawFilePath <$> fromRepo (gitAnnexExportDbDir u) - let db = dbdir "db" - unlessM (liftIO $ doesFileExist db) $ do + dbdir <- fromRepo (gitAnnexExportDbDir u) + let db = dbdir P. "db" + unlessM (liftIO $ R.doesPathExist db) $ do initDb db $ void $ runMigrationSilent migrateExport h <- liftIO $ H.openDbQueue H.SingleWriter db "exported" diff --git a/Database/Fsck.hs b/Database/Fsck.hs index fb1a2791a8..528f3a0078 100644 --- a/Database/Fsck.hs +++ b/Database/Fsck.hs @@ -33,10 +33,12 @@ import Annex.Locations import Utility.Exception import Annex.Common import Annex.LockFile +import qualified Utility.RawFilePath as R import Database.Persist.Sql hiding (Key) import Database.Persist.TH import Data.Time.Clock +import qualified System.FilePath.ByteString as P data FsckHandle = FsckHandle H.DbQueue UUID @@ -68,8 +70,8 @@ newPass u = isJust <$> tryExclusiveLock (gitAnnexFsckDbLock u) go openDb :: UUID -> Annex FsckHandle openDb u = do dbdir <- fromRepo (gitAnnexFsckDbDir u) - let db = fromRawFilePath dbdir "db" - unlessM (liftIO $ doesFileExist db) $ do + let db = dbdir P. "db" + unlessM (liftIO $ R.doesPathExist db) $ do initDb db $ void $ runMigrationSilent migrateFsck lockFileCached =<< fromRepo (gitAnnexFsckDbLock u) diff --git a/Database/Handle.hs b/Database/Handle.hs index 4422d9e756..2109ad9ac5 100644 --- a/Database/Handle.hs +++ b/Database/Handle.hs @@ -63,10 +63,10 @@ data DbConcurrency = SingleWriter | MultiWriter {- Opens the database, but does not perform any migrations. Only use - once the database is known to exist and have the right tables. -} -openDb :: DbConcurrency -> FilePath -> TableName -> IO DbHandle +openDb :: DbConcurrency -> RawFilePath -> TableName -> IO DbHandle openDb dbconcurrency db tablename = do jobs <- newEmptyMVar - worker <- async (workerThread (T.pack db) tablename jobs) + worker <- async (workerThread (T.pack (fromRawFilePath db)) tablename jobs) -- work around https://github.com/yesodweb/persistent/issues/474 liftIO $ fileEncoding stderr diff --git a/Database/Init.hs b/Database/Init.hs index c610d24aa3..3f67093bd5 100644 --- a/Database/Init.hs +++ b/Database/Init.hs @@ -5,16 +5,20 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Database.Init where import Annex.Common import Annex.Perms import Utility.FileMode import Utility.Directory.Create +import qualified Utility.RawFilePath as R import Database.Persist.Sqlite -import qualified Data.Text as T import Lens.Micro +import qualified Data.Text as T +import qualified System.FilePath.ByteString as P {- Ensures that the database is freshly initialized. Deletes any - existing database. Pass the migration action for the database. @@ -24,24 +28,24 @@ import Lens.Micro - file causes Sqlite to always use the same permissions for additional - files it writes later on -} -initDb :: FilePath -> SqlPersistM () -> Annex () +initDb :: P.RawFilePath -> SqlPersistM () -> Annex () initDb db migration = do - let dbdir = takeDirectory db - let tmpdbdir = dbdir ++ ".tmp" - let tmpdb = tmpdbdir "db" - let tdb = T.pack tmpdb + let dbdir = P.takeDirectory db + let tmpdbdir = dbdir <> ".tmp" + let tmpdb = tmpdbdir P. "db" + let tdb = T.pack (fromRawFilePath tmpdb) top <- parentDir <$> fromRepo gitAnnexDir liftIO $ do - createDirectoryUnder top (toRawFilePath tmpdbdir) + createDirectoryUnder top tmpdbdir runSqliteInfo (enableWAL tdb) migration setAnnexDirPerm tmpdbdir -- Work around sqlite bug that prevents it from honoring -- less restrictive umasks. - liftIO $ setFileMode tmpdb =<< defaultFileMode + liftIO $ R.setFileMode tmpdb =<< defaultFileMode setAnnexFilePerm tmpdb liftIO $ do - void $ tryIO $ removeDirectoryRecursive dbdir - rename tmpdbdir dbdir + void $ tryIO $ removeDirectoryRecursive (fromRawFilePath dbdir) + rename (fromRawFilePath tmpdbdir) (fromRawFilePath dbdir) {- Make sure that the database uses WAL mode, to prevent readers - from blocking writers, and prevent a writer from blocking readers. diff --git a/Database/Keys.hs b/Database/Keys.hs index 27834af611..6b305f060c 100644 --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -43,6 +43,7 @@ import Git.FilePath import Git.Command import Git.Types import Git.Index +import qualified Utility.RawFilePath as R import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 @@ -114,8 +115,8 @@ openDb _ st@(DbOpen _) = return st openDb False DbUnavailable = return DbUnavailable openDb createdb _ = catchPermissionDenied permerr $ withExclusiveLock gitAnnexKeysDbLock $ do dbdir <- fromRepo gitAnnexKeysDb - let db = fromRawFilePath dbdir "db" - dbexists <- liftIO $ doesFileExist db + let db = dbdir P. "db" + dbexists <- liftIO $ R.doesPathExist db case (dbexists, createdb) of (True, _) -> open db (False, True) -> do @@ -215,7 +216,7 @@ reconcileStaged :: H.DbQueue -> Annex () reconcileStaged qh = do gitindex <- inRepo currentIndexFile indexcache <- fromRawFilePath <$> fromRepo gitAnnexKeysDbIndexCache - withTSDelta (liftIO . genInodeCache (toRawFilePath gitindex)) >>= \case + withTSDelta (liftIO . genInodeCache gitindex) >>= \case Just cur -> liftIO (maybe Nothing readInodeCache <$> catchMaybeIO (readFile indexcache)) >>= \case Nothing -> go cur indexcache diff --git a/Database/Queue.hs b/Database/Queue.hs index 0ed4d161a4..68e3e42f87 100644 --- a/Database/Queue.hs +++ b/Database/Queue.hs @@ -19,6 +19,7 @@ module Database.Queue ( ) where import Utility.Monad +import Utility.RawFilePath import Database.Handle import Database.Persist.Sqlite @@ -36,7 +37,7 @@ data DbQueue = DQ DbHandle (MVar Queue) {- Opens the database queue, but does not perform any migrations. Only use - if the database is known to exist and have the right tables; ie after - running initDb. -} -openDbQueue :: DbConcurrency -> FilePath -> TableName -> IO DbQueue +openDbQueue :: DbConcurrency -> RawFilePath -> TableName -> IO DbQueue openDbQueue dbconcurrency db tablename = DQ <$> openDb dbconcurrency db tablename <*> (newMVar =<< emptyQueue) diff --git a/Git/Index.hs b/Git/Index.hs index c946015cfe..b55fc04b99 100644 --- a/Git/Index.hs +++ b/Git/Index.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Index where import Common @@ -12,6 +14,8 @@ import Git import Utility.Env import Utility.Env.Set +import qualified System.FilePath.ByteString as P + indexEnv :: String indexEnv = "GIT_INDEX_FILE" @@ -26,8 +30,8 @@ indexEnv = "GIT_INDEX_FILE" - - So, an absolute path is the only safe option for this to return. -} -indexEnvVal :: FilePath -> IO String -indexEnvVal p = fromRawFilePath <$> absPath (toRawFilePath p) +indexEnvVal :: RawFilePath -> IO String +indexEnvVal p = fromRawFilePath <$> absPath p {- Forces git to use the specified index file. - @@ -36,7 +40,7 @@ indexEnvVal p = fromRawFilePath <$> absPath (toRawFilePath p) - - Warning: Not thread safe. -} -override :: FilePath -> Repo -> IO (IO ()) +override :: RawFilePath -> Repo -> IO (IO ()) override index _r = do res <- getEnv var val <- indexEnvVal index @@ -48,13 +52,13 @@ override index _r = do reset _ = unsetEnv var {- The normal index file. Does not check GIT_INDEX_FILE. -} -indexFile :: Repo -> FilePath -indexFile r = fromRawFilePath (localGitDir r) "index" +indexFile :: Repo -> RawFilePath +indexFile r = localGitDir r P. "index" {- The index file git will currently use, checking GIT_INDEX_FILE. -} -currentIndexFile :: Repo -> IO FilePath -currentIndexFile r = fromMaybe (indexFile r) <$> getEnv indexEnv +currentIndexFile :: Repo -> IO RawFilePath +currentIndexFile r = maybe (indexFile r) toRawFilePath <$> getEnv indexEnv {- Git locks the index by creating this file. -} -indexFileLock :: FilePath -> FilePath -indexFileLock f = f ++ ".lock" +indexFileLock :: RawFilePath -> RawFilePath +indexFileLock f = f <> ".lock" diff --git a/Git/Objects.hs b/Git/Objects.hs index 6a240875e0..9b7165c0ad 100644 --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -5,39 +5,45 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Objects where import Common import Git import Git.Sha -objectsDir :: Repo -> FilePath -objectsDir r = fromRawFilePath (localGitDir r) "objects" +import qualified Data.ByteString as B +import qualified System.FilePath.ByteString as P -packDir :: Repo -> FilePath -packDir r = objectsDir r "pack" +objectsDir :: Repo -> RawFilePath +objectsDir r = localGitDir r P. "objects" -packIdxFile :: FilePath -> FilePath -packIdxFile = flip replaceExtension "idx" +packDir :: Repo -> RawFilePath +packDir r = objectsDir r P. "pack" + +packIdxFile :: RawFilePath -> RawFilePath +packIdxFile = flip P.replaceExtension "idx" listPackFiles :: Repo -> IO [FilePath] listPackFiles r = filter (".pack" `isSuffixOf`) - <$> catchDefaultIO [] (dirContents $ packDir r) + <$> catchDefaultIO [] (dirContents $ fromRawFilePath $ packDir r) listLooseObjectShas :: Repo -> IO [Sha] listLooseObjectShas r = catchDefaultIO [] $ mapMaybe (extractSha . encodeBS . concat . reverse . take 2 . reverse . splitDirectories) - <$> dirContentsRecursiveSkipping (== "pack") True (objectsDir r) + <$> dirContentsRecursiveSkipping (== "pack") True (fromRawFilePath (objectsDir r)) -looseObjectFile :: Repo -> Sha -> FilePath -looseObjectFile r sha = objectsDir r prefix rest +looseObjectFile :: Repo -> Sha -> RawFilePath +looseObjectFile r sha = objectsDir r P. prefix P. rest where - (prefix, rest) = splitAt 2 (fromRef sha) + (prefix, rest) = B.splitAt 2 (fromRef' sha) listAlternates :: Repo -> IO [FilePath] -listAlternates r = catchDefaultIO [] (lines <$> readFile alternatesfile) +listAlternates r = catchDefaultIO [] $ + lines <$> readFile (fromRawFilePath alternatesfile) where - alternatesfile = objectsDir r "info" "alternates" + alternatesfile = objectsDir r P. "info" P. "alternates" {- A repository recently cloned with --shared will have one or more - alternates listed, and contain no loose objects or packs. -} diff --git a/Git/Repair.hs b/Git/Repair.hs index eb8736a011..45d9d7c489 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -53,9 +53,9 @@ cleanCorruptObjects fsckresults r = do mapM_ removeLoose (S.toList $ knownMissing fsckresults) mapM_ removeBad =<< listLooseObjectShas r where - removeLoose s = removeWhenExistsWith removeLink (looseObjectFile r s) + removeLoose s = removeWhenExistsWith R.removeLink (looseObjectFile r s) removeBad s = do - void $ tryIO $ allowRead $ looseObjectFile r s + void $ tryIO $ allowRead $ looseObjectFile r s whenM (isMissing s r) $ removeLoose s @@ -79,10 +79,11 @@ explodePacks r = go =<< listPackFiles r putStrLn "Unpacking all pack files." forM_ packs $ \packfile -> do moveFile packfile (tmpdir takeFileName packfile) - removeWhenExistsWith removeLink $ packIdxFile packfile + removeWhenExistsWith R.removeLink + (packIdxFile (toRawFilePath packfile)) forM_ packs $ \packfile -> do let tmp = tmpdir takeFileName packfile - allowRead tmp + allowRead (toRawFilePath tmp) -- May fail, if pack file is corrupt. void $ tryIO $ pipeWrite [Param "unpack-objects", Param "-r"] r $ \h -> @@ -163,8 +164,8 @@ retrieveMissingObjects missing referencerepo r copyObjects :: Repo -> Repo -> IO Bool copyObjects srcr destr = rsync [ Param "-qr" - , File $ addTrailingPathSeparator $ objectsDir srcr - , File $ addTrailingPathSeparator $ objectsDir destr + , File $ addTrailingPathSeparator $ fromRawFilePath $ objectsDir srcr + , File $ addTrailingPathSeparator $ fromRawFilePath $ objectsDir destr ] {- To deal with missing objects that cannot be recovered, resets any @@ -395,7 +396,7 @@ rewriteIndex r | otherwise = do (bad, good, cleanup) <- partitionIndex r unless (null bad) $ do - removeWhenExistsWith removeLink (indexFile r) + removeWhenExistsWith R.removeLink (indexFile r) UpdateIndex.streamUpdateIndex r =<< (catMaybes <$> mapM reinject good) void cleanup @@ -446,9 +447,8 @@ preRepair g = do removeWhenExistsWith removeLink headfile writeFile headfile "ref: refs/heads/master" explodePackedRefsFile g - unless (repoIsLocalBare g) $ do - let f = indexFile g - void $ tryIO $ allowWrite f + unless (repoIsLocalBare g) $ + void $ tryIO $ allowWrite $ indexFile g where headfile = fromRawFilePath (localGitDir g) "HEAD" validhead s = "ref: refs/" `isPrefixOf` s @@ -572,7 +572,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do else successfulfinish modifiedbranches corruptedindex = do - removeWhenExistsWith removeLink (indexFile g) + removeWhenExistsWith R.removeLink (indexFile g) -- The corrupted index can prevent fsck from finding other -- problems, so re-run repair. fsckresult' <- findBroken False g @@ -618,5 +618,5 @@ successfulRepair = fst safeReadFile :: FilePath -> IO String safeReadFile f = do - allowRead f + allowRead (toRawFilePath f) readFileStrict f diff --git a/Logs/File.hs b/Logs/File.hs index 32162f7525..c62f16ce6d 100644 --- a/Logs/File.hs +++ b/Logs/File.hs @@ -32,9 +32,9 @@ import qualified Data.ByteString.Lazy.Char8 as L8 writeLogFile :: RawFilePath -> String -> Annex () writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog (fromRawFilePath f) c where - writelog f' c' = do - liftIO $ writeFile f' c' - setAnnexFilePerm f' + writelog tmp c' = do + liftIO $ writeFile tmp c' + setAnnexFilePerm (toRawFilePath tmp) -- | Runs the action with a handle connected to a temp file. -- The temp file replaces the log file once the action succeeds. @@ -45,7 +45,7 @@ withLogHandle f a = do bracket (setup tmp) cleanup a where setup tmp = do - setAnnexFilePerm tmp + setAnnexFilePerm (toRawFilePath tmp) liftIO $ openFile tmp WriteMode cleanup h = liftIO $ hClose h @@ -57,7 +57,7 @@ appendLogFile f lck c = withExclusiveLock lck $ do liftIO $ withFile f' AppendMode $ \h -> L8.hPutStrLn h c - setAnnexFilePerm f' + setAnnexFilePerm (toRawFilePath f') where f' = fromRawFilePath f @@ -81,7 +81,7 @@ modifyLogFile f lck modf = withExclusiveLock lck $ do f' = fromRawFilePath f writelog lf b = do liftIO $ L.writeFile lf b - setAnnexFilePerm lf + setAnnexFilePerm (toRawFilePath lf) -- | Checks the content of a log file to see if any line matches. -- @@ -134,7 +134,7 @@ streamLogFile f lck a = withExclusiveLock lck $ bracketOnError setup cleanup go mapM_ a =<< liftIO (lines <$> hGetContents h) liftIO $ hClose h liftIO $ writeFile f "" - setAnnexFilePerm f + setAnnexFilePerm (toRawFilePath f) createDirWhenNeeded :: RawFilePath -> Annex () -> Annex () createDirWhenNeeded f a = a `catchNonAsync` \_e -> do diff --git a/P2P/IO.hs b/P2P/IO.hs index 43075546bc..11aa8deca0 100644 --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -135,7 +135,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 unixsocket $ addModes + modifyFileMode (toRawFilePath unixsocket) $ addModes [groupReadMode, groupWriteMode, otherReadMode, otherWriteMode] S.listen soc 2 forever $ do diff --git a/Utility/Directory.hs b/Utility/Directory.hs index b839352e24..54ca7186b6 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -18,18 +18,11 @@ import Control.Monad import System.FilePath import System.PosixCompat.Files import Control.Applicative -import Control.Monad.IfElse import System.IO.Unsafe (unsafeInterleaveIO) -import System.IO.Error import Data.Maybe import Prelude -#ifndef mingw32_HOST_OS -import Utility.SafeCommand -#endif - import Utility.SystemDirectory -import Utility.Tmp import Utility.Exception import Utility.Monad import Utility.Applicative @@ -98,50 +91,6 @@ dirTreeRecursiveSkipping skipdir topdir = go [] [topdir] =<< catchDefaultIO [] (dirContents dir) go (subdirs++dir:c) dirs -{- Moves one filename to another. - - First tries a rename, but falls back to moving across devices if needed. -} -moveFile :: FilePath -> FilePath -> IO () -moveFile src dest = tryIO (rename src dest) >>= onrename - where - onrename (Right _) = noop - onrename (Left e) - | isPermissionError e = rethrow - | isDoesNotExistError e = rethrow - | otherwise = viaTmp mv dest () - where - rethrow = throwM e - - mv tmp () = do - -- copyFile is likely not as optimised as - -- the mv command, so we'll use the command. - -- - -- But, while Windows has a "mv", it does not seem very - -- reliable, so use copyFile there. -#ifndef mingw32_HOST_OS - -- If dest is a directory, mv would move the file - -- into it, which is not desired. - whenM (isdir dest) rethrow - ok <- boolSystem "mv" [Param "-f", Param src, Param tmp] - let e' = e -#else - r <- tryIO $ copyFile src tmp - let (ok, e') = case r of - Left err -> (False, err) - Right _ -> (True, e) -#endif - unless ok $ do - -- delete any partial - _ <- tryIO $ removeFile tmp - throwM e' - -#ifndef mingw32_HOST_OS - isdir f = do - r <- tryIO $ getFileStatus f - case r of - (Left _) -> return False - (Right s) -> return $ isDirectory s -#endif - {- Use with an action that removes something, which may or may not exist. - - If an exception is thrown due to it not existing, it is ignored. diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index 352c3c19a5..03e838e8a5 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -22,22 +22,24 @@ import Foreign (complement) import Control.Monad.Catch import Utility.Exception +import Utility.FileSystemEncoding +import qualified Utility.RawFilePath as R {- Applies a conversion function to a file's mode. -} -modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO () +modifyFileMode :: RawFilePath -> (FileMode -> FileMode) -> IO () modifyFileMode f convert = void $ modifyFileMode' f convert -modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode +modifyFileMode' :: RawFilePath -> (FileMode -> FileMode) -> IO FileMode modifyFileMode' f convert = do - s <- getFileStatus f + s <- R.getFileStatus f let old = fileMode s let new = convert old when (new /= old) $ - setFileMode f new + R.setFileMode f new return old {- Runs an action after changing a file's mode, then restores the old mode. -} -withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a +withModifiedFileMode :: RawFilePath -> (FileMode -> FileMode) -> IO a -> IO a withModifiedFileMode file convert a = bracket setup cleanup go where setup = modifyFileMode' file convert @@ -70,15 +72,15 @@ otherGroupModes = ] {- Removes the write bits from a file. -} -preventWrite :: FilePath -> IO () +preventWrite :: RawFilePath -> IO () preventWrite f = modifyFileMode f $ removeModes writeModes {- Turns a file's owner write bit back on. -} -allowWrite :: FilePath -> IO () +allowWrite :: RawFilePath -> IO () allowWrite f = modifyFileMode f $ addModes [ownerWriteMode] {- Turns a file's owner read bit back on. -} -allowRead :: FilePath -> IO () +allowRead :: RawFilePath -> IO () allowRead f = modifyFileMode f $ addModes [ownerReadMode] {- Allows owner and group to read and write to a file. -} @@ -88,7 +90,7 @@ groupSharedModes = , ownerReadMode, groupReadMode ] -groupWriteRead :: FilePath -> IO () +groupWriteRead :: RawFilePath -> IO () groupWriteRead f = modifyFileMode f $ addModes groupSharedModes checkMode :: FileMode -> FileMode -> Bool @@ -149,7 +151,7 @@ isSticky = checkMode stickyMode stickyMode :: FileMode stickyMode = 512 -setSticky :: FilePath -> IO () +setSticky :: RawFilePath -> IO () setSticky f = modifyFileMode f $ addModes [stickyMode] #endif @@ -162,13 +164,13 @@ setSticky f = modifyFileMode f $ addModes [stickyMode] - On a filesystem that does not support file permissions, this is the same - as writeFile. -} -writeFileProtected :: FilePath -> String -> IO () +writeFileProtected :: RawFilePath -> String -> IO () writeFileProtected file content = writeFileProtected' file (\h -> hPutStr h content) -writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO () +writeFileProtected' :: RawFilePath -> (Handle -> IO ()) -> IO () writeFileProtected' file writer = protectedOutput $ - withFile file WriteMode $ \h -> do + withFile (fromRawFilePath file) WriteMode $ \h -> do void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes writer h diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index e5796dd55a..b705bb599a 100644 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -422,7 +422,7 @@ testHarness tmpdir cmd a = ifM (inPath (unGpgCmd cmd)) orig <- getEnv var subdir <- makenewdir (1 :: Integer) -- gpg is picky about permissions on its home dir - liftIO $ void $ tryIO $ modifyFileMode subdir $ + liftIO $ void $ tryIO $ modifyFileMode (toRawFilePath subdir) $ removeModes $ otherGroupModes setEnv var subdir True -- For some reason, recent gpg needs a trustdb to be set up. diff --git a/Utility/MoveFile.hs b/Utility/MoveFile.hs new file mode 100644 index 0000000000..695ed03f57 --- /dev/null +++ b/Utility/MoveFile.hs @@ -0,0 +1,74 @@ +{- moving files + - + - Copyright 2011-2020 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.MoveFile ( + moveFile, +) where + +import Control.Monad +import System.FilePath +import System.PosixCompat.Files +import Control.Monad.IfElse +import System.IO.Error +import Prelude + +#ifndef mingw32_HOST_OS +import Utility.SafeCommand +#endif + +import Utility.SystemDirectory +import Utility.Tmp +import Utility.Exception +import Utility.Monad + +{- Moves one filename to another. + - First tries a rename, but falls back to moving across devices if needed. -} +moveFile :: FilePath -> FilePath -> IO () +moveFile src dest = tryIO (rename src dest) >>= onrename + where + onrename (Right _) = noop + onrename (Left e) + | isPermissionError e = rethrow + | isDoesNotExistError e = rethrow + | otherwise = viaTmp mv dest () + where + rethrow = throwM e + + mv tmp () = do + -- copyFile is likely not as optimised as + -- the mv command, so we'll use the command. + -- + -- But, while Windows has a "mv", it does not seem very + -- reliable, so use copyFile there. +#ifndef mingw32_HOST_OS + -- If dest is a directory, mv would move the file + -- into it, which is not desired. + whenM (isdir dest) rethrow + ok <- boolSystem "mv" [Param "-f", Param src, Param tmp] + let e' = e +#else + r <- tryIO $ copyFile src tmp + let (ok, e') = case r of + Left err -> (False, err) + Right _ -> (True, e) +#endif + unless ok $ do + -- delete any partial + _ <- tryIO $ removeFile tmp + throwM e' + +#ifndef mingw32_HOST_OS + isdir f = do + r <- tryIO $ getFileStatus f + case r of + (Left _) -> return False + (Right s) -> return $ isDirectory s +#endif diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs index f5fff2a40e..79b0545f48 100644 --- a/Utility/RawFilePath.hs +++ b/Utility/RawFilePath.hs @@ -25,6 +25,7 @@ module Utility.RawFilePath ( doesPathExist, getCurrentDirectory, createDirectory, + setFileMode, ) where #ifndef mingw32_HOST_OS @@ -45,8 +46,9 @@ createDirectory p = D.createDirectory p 0o777 #else import qualified Data.ByteString as B -import System.PosixCompat (FileStatus) +import System.PosixCompat (FileStatus, FileMode) import qualified System.PosixCompat as P +import qualified System.PosixCompat.Files as F import qualified System.Directory as D import Utility.FileSystemEncoding @@ -80,4 +82,7 @@ getCurrentDirectory = toRawFilePath <$> D.getCurrentDirectory createDirectory :: RawFilePath -> IO () createDirectory = D.createDirectory . fromRawFilePath + +setFileMode :: RawFilePath -> FileMode -> IO () +setFileMode = F.setFileMode #endif diff --git a/Utility/SshConfig.hs b/Utility/SshConfig.hs index 111d73ec44..bac38c530f 100644 --- a/Utility/SshConfig.hs +++ b/Utility/SshConfig.hs @@ -144,7 +144,7 @@ changeUserSshConfig modifier = do writeSshConfig :: FilePath -> String -> IO () writeSshConfig f s = do writeFile f s - setSshConfigMode f + setSshConfigMode (toRawFilePath f) {- Ensure that the ssh config file lacks any group or other write bits, - since ssh is paranoid about not working if other users can write @@ -153,7 +153,7 @@ writeSshConfig f s = do - If the chmod fails, ignore the failure, as it might be a filesystem like - Android's that does not support file modes. -} -setSshConfigMode :: FilePath -> IO () +setSshConfigMode :: RawFilePath -> IO () setSshConfigMode f = void $ tryIO $ modifyFileMode f $ removeModes [groupWriteMode, otherWriteMode] diff --git a/Utility/Tor.hs b/Utility/Tor.hs index 168e6448dc..13a019e2b6 100644 --- a/Utility/Tor.hs +++ b/Utility/Tor.hs @@ -166,7 +166,7 @@ prepHiddenServiceSocketDir :: AppName -> UserID -> UniqueIdent -> IO () prepHiddenServiceSocketDir appname uid ident = do createDirectoryIfMissing True d setOwnerAndGroup d uid (-1) - modifyFileMode d $ + modifyFileMode (toRawFilePath d) $ addModes [ownerReadMode, ownerExecuteMode, ownerWriteMode] where d = takeDirectory $ hiddenServiceSocketFile appname uid ident diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs index 8e89517a6c..4bbec201a9 100644 --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -189,7 +189,8 @@ insertAuthToken extractAuthToken predicate webapp root pathbits params = {- Creates a html shim file that's used to redirect into the webapp, - to avoid exposing the secret token when launching the web browser. -} writeHtmlShim :: String -> String -> FilePath -> IO () -writeHtmlShim title url file = viaTmp writeFileProtected file $ genHtmlShim title url +writeHtmlShim title url file = + viaTmp writeFileProtected (toRawFilePath file) $ genHtmlShim title url genHtmlShim :: String -> String -> String genHtmlShim title url = unlines diff --git a/git-annex.cabal b/git-annex.cabal index ed0cef06cd..3ed8619145 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1090,6 +1090,7 @@ Executable git-annex Utility.Metered Utility.Misc Utility.Monad + Utility.MoveFile Utility.Network Utility.NotificationBroadcaster Utility.OptParse