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:
parent
b8bd2e45e3
commit
8d66f7ba0f
18 changed files with 95 additions and 76 deletions
1
Annex.hs
1
Annex.hs
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
6
Creds.hs
6
Creds.hs
|
@ -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
|
||||
|
||||
|
|
|
@ -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
10
Git.hs
|
@ -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. -}
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue