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
parent
9b0dde834e
commit
2c8cf06e75
31 changed files with 239 additions and 182 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 " ++
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
3
Creds.hs
3
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
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
22
Git/Index.hs
22
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"
|
||||
|
|
|
|||
|
|
@ -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. -}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
14
Logs/File.hs
14
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
74
Utility/MoveFile.hs
Normal 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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1090,6 +1090,7 @@ Executable git-annex
|
|||
Utility.Metered
|
||||
Utility.Misc
|
||||
Utility.Monad
|
||||
Utility.MoveFile
|
||||
Utility.Network
|
||||
Utility.NotificationBroadcaster
|
||||
Utility.OptParse
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue