Converted file mode setting to it, and follow-on changes.
Compiles up through 369/646.
This commit was sponsored by Ethan Aubin.
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
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
module Annex.Content.LowLevel where
-import System.PosixCompat.Files
-
import Annex.Common
import Logs.Transfer
import qualified Annex
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. -}
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
- 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
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
_ -> 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 " ++
(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)
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
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"
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
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.
-
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
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
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,
- 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
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.
- 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
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
{- 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
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. -}
createAnnexDirectory dir
-- might have already existed with restricted perms
unlessM crippledFileSystem $
- liftIO $ allowWrite $ fromRawFilePath dir
+ liftIO $ allowWrite dir
where
dir = parentDir dest
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)
, "Host " ++ mangledhost
] ++ map (\(k, v) -> "\t" ++ k ++ " " ++ v)
(settings ++ config)
- setSshConfigMode configfile
+ setSshConfigMode (toRawFilePath configfile)
return $ sshdata
{ sshHostName = T.pack mangledhost
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
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
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
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
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 */
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
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"
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
-}
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"
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
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)
{- 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
- 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.
- 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.
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
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
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
) where
import Utility.Monad
+import Utility.RawFilePath
import Database.Handle
import Database.Persist.Sqlite
{- 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)
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Git.Index where
import Common
import Utility.Env
import Utility.Env.Set
+import qualified System.FilePath.ByteString as P
+
indexEnv :: String
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.
-
-
- Warning: Not thread safe.
-}
-override :: FilePath -> Repo -> IO (IO ())
+override :: RawFilePath -> Repo -> IO (IO ())
override index _r = do
res <- getEnv var
val <- indexEnvVal index
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"
- 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
+
+objectsDir :: Repo -> RawFilePath
+objectsDir r = localGitDir r P.</> "objects"
-packDir :: Repo -> FilePath
-packDir r = objectsDir r </> "pack"
+packDir :: Repo -> RawFilePath
+packDir r = objectsDir r P.</> "pack"
-packIdxFile :: FilePath -> FilePath
-packIdxFile = flip replaceExtension "idx"
+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. -}
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
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 ->
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
| 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
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
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
safeReadFile :: FilePath -> IO String
safeReadFile f = do
- allowRead f
+ allowRead (toRawFilePath f)
readFileStrict f
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.
bracket (setup tmp) cleanup a
where
setup tmp = do
- setAnnexFilePerm tmp
+ setAnnexFilePerm (toRawFilePath tmp)
liftIO $ openFile tmp WriteMode
cleanup h = liftIO $ hClose h
withExclusiveLock lck $ do
liftIO $ withFile f' AppendMode $
\h -> L8.hPutStrLn h c
- setAnnexFilePerm f'
+ setAnnexFilePerm (toRawFilePath f')
where
f' = fromRawFilePath f
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.
--
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
-- 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
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
=<< 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.
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
]
{- 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. -}
, ownerReadMode, groupReadMode
]
-groupWriteRead :: FilePath -> IO ()
+groupWriteRead :: RawFilePath -> IO ()
groupWriteRead f = modifyFileMode f $ addModes groupSharedModes
checkMode :: FileMode -> FileMode -> Bool
stickyMode :: FileMode
stickyMode = 512
-setSticky :: FilePath -> IO ()
+setSticky :: RawFilePath -> IO ()
setSticky f = modifyFileMode f $ addModes [stickyMode]
#endif
- 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
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.
--- /dev/null
+{- 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
doesPathExist,
getCurrentDirectory,
createDirectory,
+ setFileMode,
) where
#ifndef mingw32_HOST_OS
#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
createDirectory :: RawFilePath -> IO ()
createDirectory = D.createDirectory . fromRawFilePath
+
+setFileMode :: RawFilePath -> FileMode -> IO ()
+setFileMode = F.setFileMode
#endif
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
- 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]
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
{- 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
Utility.Metered
Utility.Misc
Utility.Monad
+ Utility.MoveFile
Utility.Network
Utility.NotificationBroadcaster
Utility.OptParse
projects / git-annex.git / commitdiff