more RawFilePath conversion

Added a RawFilePath createDirectory and kept making stuff build.

Up to 296/645

This commit was sponsored by Mark Reidenbach on Patreon.
This commit is contained in:
Joey Hess 2020-10-28 17:25:59 -04:00
parent b8bd2e45e3
commit 8d66f7ba0f
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
18 changed files with 95 additions and 76 deletions

View file

@ -74,6 +74,7 @@ import qualified Database.Keys.Handle as Keys
import Utility.InodeCache
import Utility.Url
import Utility.ResourcePool
import Utility.Path.AbsRel
import "mtl" Control.Monad.Reader
import Control.Concurrent

View file

@ -25,6 +25,7 @@ import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.STM.TBMChan
import qualified Data.ByteString as S
import qualified System.FilePath.ByteString as P
newtype ChangedRefs = ChangedRefs [Git.Ref]
deriving (Show)
@ -77,8 +78,8 @@ watchChangedRefs = do
chan <- liftIO $ newTBMChanIO 100
g <- gitRepo
let gittop = fromRawFilePath (Git.localGitDir g)
let refdir = gittop </> "refs"
let gittop = Git.localGitDir g
let refdir = gittop P.</> "refs"
liftIO $ createDirectoryUnder gittop refdir
let notifyhook = Just $ notifyHook chan

View file

@ -26,7 +26,7 @@ annexAttrs =
, "annex.largefiles"
]
checkAttr :: Git.Attr -> FilePath -> Annex String
checkAttr :: Git.Attr -> RawFilePath -> Annex String
checkAttr attr file = withCheckAttrHandle $ \h ->
liftIO $ Git.checkAttr h attr file

View file

@ -33,7 +33,7 @@ hashObjectStop = maybe noop stop =<< Annex.getState Annex.hashobjecthandle
Annex.changeState $ \s -> s { Annex.hashobjecthandle = Nothing }
return ()
hashFile :: FilePath -> Annex Sha
hashFile :: RawFilePath -> Annex Sha
hashFile f = do
h <- hashObjectHandle
liftIO $ Git.HashObject.hashFile h f

View file

@ -78,7 +78,7 @@ createInodeSentinalFile :: Bool -> Annex ()
createInodeSentinalFile evenwithobjects =
unlessM (alreadyexists <||> hasobjects) $ do
s <- annexSentinalFile
createAnnexDirectory (parentDir (fromRawFilePath (sentinalFile s)))
createAnnexDirectory (parentDir (sentinalFile s))
liftIO $ writeSentinalFile s
where
alreadyexists = liftIO. sentinalFileExists =<< annexSentinalFile

View file

@ -425,9 +425,8 @@ gitAnnexScheduleState r = fromRawFilePath $ gitAnnexDir r P.</> "schedulestate"
{- .git/annex/creds/ is used to store credentials to access some special
- remotes. -}
gitAnnexCredsDir :: Git.Repo -> FilePath
gitAnnexCredsDir r = fromRawFilePath $
P.addTrailingPathSeparator $ gitAnnexDir r P.</> "creds"
gitAnnexCredsDir :: Git.Repo -> RawFilePath
gitAnnexCredsDir r = P.addTrailingPathSeparator $ gitAnnexDir r P.</> "creds"
{- .git/annex/certificate.pem and .git/annex/key.pem are used by the webapp
- when HTTPS is enabled -}
@ -545,8 +544,8 @@ gitAnnexSshDir r = fromRawFilePath $
P.addTrailingPathSeparator $ gitAnnexDir r P.</> "ssh"
{- .git/annex/remotes/ is used for remote-specific state. -}
gitAnnexRemotesDir :: Git.Repo -> FilePath
gitAnnexRemotesDir r = fromRawFilePath $
gitAnnexRemotesDir :: Git.Repo -> RawFilePath
gitAnnexRemotesDir r =
P.addTrailingPathSeparator $ gitAnnexDir r P.</> "remotes"
{- This is the base directory name used by the assistant when making

View file

@ -26,6 +26,7 @@ import Annex.Perms
import Annex.LockPool
import qualified Data.Map as M
import qualified System.FilePath.ByteString as P
{- Create a specified lock file, and takes a shared lock, which is retained
- in the cache. -}
@ -62,12 +63,12 @@ changeLockCache a = do
{- Runs an action with a shared lock held. If an exclusive lock is held,
- blocks until it becomes free. -}
withSharedLock :: (Git.Repo -> FilePath) -> Annex a -> Annex a
withSharedLock :: (Git.Repo -> RawFilePath) -> Annex a -> Annex a
withSharedLock getlockfile a = debugLocks $ do
lockfile <- fromRepo getlockfile
createAnnexDirectory $ takeDirectory lockfile
createAnnexDirectory $ P.takeDirectory lockfile
mode <- annexFileMode
bracket (lock mode lockfile) (liftIO . dropLock) (const a)
bracket (lock mode (fromRawFilePath lockfile)) (liftIO . dropLock) (const a)
where
#ifndef mingw32_HOST_OS
lock mode = noUmask mode . lockShared (Just mode)
@ -77,19 +78,19 @@ withSharedLock getlockfile a = debugLocks $ do
{- Runs an action with an exclusive lock held. If the lock is already
- held, blocks until it becomes free. -}
withExclusiveLock :: (Git.Repo -> FilePath) -> Annex a -> Annex a
withExclusiveLock :: (Git.Repo -> RawFilePath) -> Annex a -> Annex a
withExclusiveLock getlockfile a = bracket
(takeExclusiveLock getlockfile)
(liftIO . dropLock)
(const a)
{- Takes an exclusive lock, blocking until it's free. -}
takeExclusiveLock :: (Git.Repo -> FilePath) -> Annex LockHandle
takeExclusiveLock :: (Git.Repo -> RawFilePath) -> Annex LockHandle
takeExclusiveLock getlockfile = debugLocks $ do
lockfile <- fromRepo getlockfile
createAnnexDirectory $ takeDirectory lockfile
createAnnexDirectory $ P.takeDirectory lockfile
mode <- annexFileMode
lock mode lockfile
lock mode (fromRawFilePath lockfile)
where
#ifndef mingw32_HOST_OS
lock mode = noUmask mode . lockExclusive (Just mode)
@ -99,12 +100,12 @@ takeExclusiveLock getlockfile = debugLocks $ do
{- Tries to take an exclusive lock and run an action. If the lock is
- already held, returns Nothing. -}
tryExclusiveLock :: (Git.Repo -> FilePath) -> Annex a -> Annex (Maybe a)
tryExclusiveLock :: (Git.Repo -> RawFilePath) -> Annex a -> Annex (Maybe a)
tryExclusiveLock getlockfile a = debugLocks $ do
lockfile <- fromRepo getlockfile
createAnnexDirectory $ takeDirectory lockfile
createAnnexDirectory $ P.takeDirectory lockfile
mode <- annexFileMode
bracket (lock mode lockfile) (liftIO . unlock) go
bracket (lock mode (fromRawFilePath lockfile)) (liftIO . unlock) go
where
#ifndef mingw32_HOST_OS
lock mode = noUmask mode . tryLockExclusive (Just mode)

View file

@ -31,6 +31,8 @@ import Git
import Git.ConfigTypes
import qualified Annex
import Config
import Utility.Directory.Create
import qualified Utility.RawFilePath as R
withShared :: (SharedRepository -> Annex a) -> Annex a
withShared a = a =<< coreSharedRepository <$> Annex.getGitConfig
@ -97,24 +99,24 @@ annexFileMode = withShared $ return . go
{- Creates a directory inside the gitAnnexDir, creating any parent
- directories up to and including the gitAnnexDir.
- Makes directories with appropriate permissions. -}
createAnnexDirectory :: FilePath -> Annex ()
createAnnexDirectory :: RawFilePath -> Annex ()
createAnnexDirectory dir = do
top <- parentDir . fromRawFilePath <$> fromRepo gitAnnexDir
top <- parentDir <$> fromRepo gitAnnexDir
createDirectoryUnder' top dir createdir
where
createdir p = do
liftIO $ createDirectory p
setAnnexDirPerm p
liftIO $ R.createDirectory p
setAnnexDirPerm (fromRawFilePath p)
{- Create a directory in the git work tree, creating any parent
- directories up to the top of the work tree.
-
- Uses default permissions.
-}
createWorkTreeDirectory :: FilePath -> Annex ()
createWorkTreeDirectory :: RawFilePath -> Annex ()
createWorkTreeDirectory dir = do
fromRepo repoWorkTree >>= liftIO . \case
Just wt -> createDirectoryUnder (fromRawFilePath wt) dir
Just wt -> createDirectoryUnder wt dir
-- Should never happen, but let whatever tries to write
-- to the directory be what throws an exception, as that
-- will be clearer than an exception from here.
@ -190,34 +192,35 @@ thawPerms a = ifM crippledFileSystem
- is set, this is not done, since the group must be allowed to delete the
- file.
-}
freezeContentDir :: FilePath -> Annex ()
freezeContentDir :: RawFilePath -> Annex ()
freezeContentDir file = unlessM crippledFileSystem $
withShared go
where
dir = parentDir file
dir = fromRawFilePath $ parentDir file
go GroupShared = liftIO $ void $ tryIO $ groupWriteRead dir
go AllShared = liftIO $ void $ tryIO $ groupWriteRead dir
go _ = liftIO $ preventWrite dir
thawContentDir :: FilePath -> Annex ()
thawContentDir file = thawPerms $ liftIO $ allowWrite $ parentDir file
thawContentDir :: RawFilePath -> Annex ()
thawContentDir file =
thawPerms $ liftIO $ allowWrite . fromRawFilePath $ parentDir file
{- Makes the directory tree to store an annexed file's content,
- with appropriate permissions on each level. -}
createContentDir :: FilePath -> Annex ()
createContentDir :: RawFilePath -> Annex ()
createContentDir dest = do
unlessM (liftIO $ doesDirectoryExist dir) $
unlessM (liftIO $ R.doesPathExist dir) $
createAnnexDirectory dir
-- might have already existed with restricted perms
unlessM crippledFileSystem $
liftIO $ allowWrite dir
liftIO $ allowWrite $ fromRawFilePath dir
where
dir = parentDir dest
{- Creates the content directory for a file if it doesn't already exist,
- or thaws it if it does, then runs an action to modify the file, and
- finally, freezes the content directory. -}
modifyContent :: FilePath -> Annex a -> Annex a
modifyContent :: RawFilePath -> Annex a -> Annex a
modifyContent f a = do
createContentDir f -- also thaws it
v <- tryNonAsync a

View file

@ -18,6 +18,8 @@ module Annex.View.ViewedFile (
import Annex.Common
import qualified Data.ByteString as S
type FileName = String
type ViewedFile = FileName
@ -34,14 +36,14 @@ type MkViewedFile = FilePath -> ViewedFile
-}
viewedFileFromReference :: MkViewedFile
viewedFileFromReference f = concat
[ escape base
[ escape (fromRawFilePath base)
, if null dirs then "" else "_%" ++ intercalate "%" (map escape dirs) ++ "%"
, escape $ concat extensions
, escape $ fromRawFilePath $ S.concat extensions
]
where
(path, basefile) = splitFileName f
dirs = filter (/= ".") $ map dropTrailingPathSeparator (splitPath path)
(base, extensions) = splitShortExtensions basefile
(base, extensions) = splitShortExtensions (toRawFilePath basefile)
{- To avoid collisions with filenames or directories that contain
- '%', and to allow the original directories to be extracted

View file

@ -244,7 +244,8 @@ genSshKeyPair = withTmpDir "git-annex-keygen" $ \dir -> do
installSshKeyPair :: SshKeyPair -> SshData -> IO SshData
installSshKeyPair sshkeypair sshdata = do
sshdir <- sshDir
createDirectoryIfMissing True $ parentDir $ sshdir </> sshPrivKeyFile sshdata
createDirectoryIfMissing True $ fromRawFilePath $
parentDir $ toRawFilePath $ sshdir </> sshPrivKeyFile sshdata
unlessM (doesFileExist $ sshdir </> sshPrivKeyFile sshdata) $
writeFileProtected (sshdir </> sshPrivKeyFile sshdata) (sshPrivKey sshkeypair)

View file

@ -15,6 +15,9 @@ import qualified Git
import qualified Git.Command
import Git.Types
import Config
import Utility.Directory.Create
import qualified System.FilePath.ByteString as P
configureSmudgeFilter :: Annex ()
configureSmudgeFilter = unlessM (fromRepo Git.repoIsLocalBare) $ do
@ -33,12 +36,12 @@ configureSmudgeFilter = unlessM (fromRepo Git.repoIsLocalBare) $ do
gf <- Annex.fromRepo Git.attributes
lfs <- readattr lf
gfs <- readattr gf
gittop <- fromRawFilePath . Git.localGitDir <$> gitRepo
gittop <- Git.localGitDir <$> gitRepo
liftIO $ unless ("filter=annex" `isInfixOf` (lfs ++ gfs)) $ do
createDirectoryUnder gittop (takeDirectory lf)
writeFile lf (lfs ++ "\n" ++ unlines stdattr)
createDirectoryUnder gittop (P.takeDirectory lf)
writeFile (fromRawFilePath lf) (lfs ++ "\n" ++ unlines stdattr)
where
readattr = liftIO . catchDefaultIO "" . readFileStrict
readattr = liftIO . catchDefaultIO "" . readFileStrict . fromRawFilePath
stdattr :: [String]
stdattr =
@ -51,7 +54,7 @@ stdattr =
-- git-annex does not commit that.
deconfigureSmudgeFilter :: Annex ()
deconfigureSmudgeFilter = do
lf <- Annex.fromRepo Git.attributesLocal
lf <- fromRawFilePath <$> Annex.fromRepo Git.attributesLocal
ls <- liftIO $ catchDefaultIO [] $ lines <$> readFileStrict lf
liftIO $ writeFile lf $ unlines $
filter (\l -> l `notElem` stdattr && not (null l)) ls

View file

@ -190,14 +190,14 @@ writeCreds :: Creds -> FilePath -> Annex ()
writeCreds creds file = do
d <- fromRepo gitAnnexCredsDir
createAnnexDirectory d
liftIO $ writeFileProtected (d </> file) creds
liftIO $ writeFileProtected (fromRawFilePath d </> file) creds
readCreds :: FilePath -> Annex (Maybe Creds)
readCreds f = liftIO . catchMaybeIO . readFileStrict =<< credsFile f
credsFile :: FilePath -> Annex FilePath
credsFile basefile = do
d <- fromRepo gitAnnexCredsDir
d <- fromRawFilePath <$> fromRepo gitAnnexCredsDir
return $ d </> basefile
encodeCredPair :: CredPair -> Creds
@ -210,7 +210,7 @@ decodeCredPair creds = case lines creds of
removeCreds :: FilePath -> Annex ()
removeCreds file = do
d <- fromRepo gitAnnexCredsDir
d <- fromRawFilePath <$> fromRepo gitAnnexCredsDir
let f = d </> file
liftIO $ nukeFile f

View file

@ -10,6 +10,7 @@ module Database.Init where
import Annex.Common
import Annex.Perms
import Utility.FileMode
import Utility.Directory.Create
import Database.Persist.Sqlite
import qualified Data.Text as T
@ -29,9 +30,9 @@ initDb db migration = do
let tmpdbdir = dbdir ++ ".tmp"
let tmpdb = tmpdbdir </> "db"
let tdb = T.pack tmpdb
top <- parentDir . fromRawFilePath <$> fromRepo gitAnnexDir
top <- parentDir <$> fromRepo gitAnnexDir
liftIO $ do
createDirectoryUnder top tmpdbdir
createDirectoryUnder top (toRawFilePath tmpdbdir)
runSqliteInfo (enableWAL tdb) migration
setAnnexDirPerm tmpdbdir
-- Work around sqlite bug that prevents it from honoring

10
Git.hs
View file

@ -43,6 +43,7 @@ import Network.URI (uriPath, uriScheme, unEscapeString)
#ifndef mingw32_HOST_OS
import System.Posix.Files
#endif
import qualified System.FilePath.ByteString as P
import Common
import Git.Types
@ -133,14 +134,13 @@ assertLocal repo action
| otherwise = action
{- Path to a repository's gitattributes file. -}
attributes :: Repo -> FilePath
attributes :: Repo -> RawFilePath
attributes repo
| repoIsLocalBare repo = attributesLocal repo
| otherwise = fromRawFilePath (repoPath repo) </> ".gitattributes"
| otherwise = repoPath repo P.</> ".gitattributes"
attributesLocal :: Repo -> FilePath
attributesLocal repo = fromRawFilePath (localGitDir repo)
</> "info" </> "attributes"
attributesLocal :: Repo -> RawFilePath
attributesLocal repo = localGitDir repo P.</> "info" P.</> "attributes"
{- Path to a given hook script in a repository, only if the hook exists
- and is executable. -}

View file

@ -251,9 +251,7 @@ explodePackedRefsFile r = do
let gitd = localGitDir r
let dest = gitd P.</> fromRef' ref
let dest' = fromRawFilePath dest
createDirectoryUnder
(fromRawFilePath gitd)
(fromRawFilePath (parentDir dest))
createDirectoryUnder gitd (parentDir dest)
unlessM (doesFileExist dest') $
writeFile dest' (fromRef sha)

View file

@ -5,11 +5,13 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Remote.Helper.Hooks (addHooks) where
import qualified Data.Map as M
import qualified System.FilePath.ByteString as P
import Annex.Common
import Types.Remote
@ -46,7 +48,7 @@ addHooks' r starthook stophook = r'
runHooks :: Remote -> Maybe String -> Maybe String -> Annex a -> Annex a
runHooks r starthook stophook a = do
dir <- fromRepo gitAnnexRemotesDir
let lck = dir </> remoteid ++ ".lck"
let lck = dir P.</> remoteid <> ".lck"
whenM (notElem lck . M.keys <$> getLockCache) $ do
createAnnexDirectory dir
firstrun lck

View file

@ -5,6 +5,7 @@
- License: BSD-2-clause
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
@ -20,12 +21,14 @@ import Control.Monad.IO.Class
import Control.Monad.IfElse
import System.IO.Error
import Data.Maybe
import qualified System.FilePath.ByteString as P
import Prelude
import Utility.SystemDirectory
import Utility.Path.AbsRel
import Utility.Exception
import Utility.FileSystemEncoding
import qualified Utility.RawFilePath as R
import Utility.PartialPrelude
{- Like createDirectoryIfMissing True, but it will only create
@ -49,38 +52,36 @@ import Utility.PartialPrelude
- Note that, the second FilePath, if relative, is relative to the current
- working directory, not to the first FilePath.
-}
createDirectoryUnder :: FilePath -> FilePath -> IO ()
createDirectoryUnder :: RawFilePath -> RawFilePath -> IO ()
createDirectoryUnder topdir dir =
createDirectoryUnder' topdir dir createDirectory
createDirectoryUnder' topdir dir R.createDirectory
createDirectoryUnder'
:: (MonadIO m, MonadCatch m)
=> FilePath
-> FilePath
-> (FilePath -> m ())
=> RawFilePath
-> RawFilePath
-> (RawFilePath -> m ())
-> m ()
createDirectoryUnder' topdir dir0 mkdir = do
p <- liftIO $ fromRawFilePath <$> relPathDirToFile
(toRawFilePath topdir)
(toRawFilePath dir0)
let dirs = splitDirectories p
p <- liftIO $ relPathDirToFile topdir dir0
let dirs = P.splitDirectories p
-- Catch cases where the dir is not beneath the topdir.
-- If the relative path between them starts with "..",
-- it's not. And on Windows, if they are on different drives,
-- the path will not be relative.
if headMaybe dirs == Just ".." || isAbsolute p
if headMaybe dirs == Just ".." || P.isAbsolute p
then liftIO $ ioError $ customerror userErrorType
("createDirectoryFrom: not located in " ++ topdir)
("createDirectoryFrom: not located in " ++ fromRawFilePath topdir)
-- If dir0 is the same as the topdir, don't try to create
-- it, but make sure it does exist.
else if null dirs
then liftIO $ unlessM (doesDirectoryExist topdir) $
then liftIO $ unlessM (doesDirectoryExist (fromRawFilePath topdir)) $
ioError $ customerror doesNotExistErrorType
"createDirectoryFrom: does not exist"
else createdirs $
map (topdir </>) (reverse (scanl1 (</>) dirs))
map (topdir P.</>) (reverse (scanl1 (P.</>) dirs))
where
customerror t s = mkIOError t s Nothing (Just dir0)
customerror t s = mkIOError t s Nothing (Just (fromRawFilePath dir0))
createdirs [] = pure ()
createdirs (dir:[]) = createdir dir (liftIO . ioError)
@ -97,6 +98,6 @@ createDirectoryUnder' topdir dir0 mkdir = do
Left e
| isDoesNotExistError e -> notexisthandler e
| isAlreadyExistsError e || isPermissionError e ->
liftIO $ unlessM (doesDirectoryExist dir) $
liftIO $ unlessM (doesDirectoryExist (fromRawFilePath dir)) $
ioError e
| otherwise -> liftIO $ ioError e

View file

@ -1,5 +1,4 @@
{- Portability shim around System.Posix.Files.ByteString and
- System.Posix.Directory.ByteString
{- Portability shim for basic operations on RawFilePaths.
-
- On unix, this makes syscalls using RawFilesPaths as efficiently as
- possible.
@ -23,12 +22,13 @@ module Utility.RawFilePath (
getSymbolicLinkStatus,
doesPathExist,
getCurrentDirectory,
createDirectory,
) where
#ifndef mingw32_HOST_OS
import Utility.FileSystemEncoding (RawFilePath)
import System.Posix.Files.ByteString
import System.Posix.Directory.ByteString
import qualified System.Posix.Directory.ByteString as D
-- | Checks if a file or directoy exists. Note that a dangling symlink
-- will be false.
@ -36,7 +36,10 @@ doesPathExist :: RawFilePath -> IO Bool
doesPathExist = fileExist
getCurrentDirectory :: IO RawFilePath
getCurrentDirectory = getWorkingDirectory
getCurrentDirectory = D.getWorkingDirectory
createDirectory :: RawFilePath -> IO ()
createDirectory p = D.createDirectory p 0o777
#else
import qualified Data.ByteString as B
@ -64,4 +67,7 @@ doesPathExist = D.doesPathExist . fromRawFilePath
getCurrentDirectory :: IO RawFilePath
getCurrentDirectory = toRawFilePath <$> D.getCurrentDirectory
createDirectory :: RawFilePath -> IO ()
createDirectory = D.createDirectory . fromRawFilePath
#endif