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.
This commit is contained in:
Joey Hess 2020-11-05 18:45:37 -04:00
parent 9b0dde834e
commit 2c8cf06e75
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
31 changed files with 239 additions and 182 deletions

View file

@ -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

View file

@ -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 " ++

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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 */

View file

@ -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"

View file

@ -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"

View file

@ -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)

View file

@ -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

View file

@ -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.

View file

@ -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

View file

@ -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)

View file

@ -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"

View file

@ -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. -}

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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.

View file

@ -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

View file

@ -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.

74
Utility/MoveFile.hs Normal file
View file

@ -0,0 +1,74 @@
{- moving files
-
- Copyright 2011-2020 Joey Hess <id@joeyh.name>
-
- 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

View file

@ -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

View file

@ -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]

View file

@ -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

View file

@ -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

View file

@ -1090,6 +1090,7 @@ Executable git-annex
Utility.Metered
Utility.Misc
Utility.Monad
Utility.MoveFile
Utility.Network
Utility.NotificationBroadcaster
Utility.OptParse