From f3539efc1604259ebadf59d87ce28a8e78453f67 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 24 Jan 2025 16:31:14 -0400 Subject: [PATCH] more OsPath conversion Sponsored-by: Leon Schuermann --- Git.hs | 2 - Git/Repair.hs | 43 +++++++++++----------- Git/UnionMerge.hs | 4 +- Utility/DirWatcher.hs | 9 +++-- Utility/DirWatcher/INotify.hs | 38 ++++++++----------- Utility/DirWatcher/Types.hs | 10 ++--- Utility/Directory/Create.hs | 4 +- Utility/Gpg.hs | 4 +- Utility/LinuxMkLibs.hs | 2 +- Utility/LockFile/PidLock.hs | 31 ++++++++-------- Utility/LockFile/Posix.hs | 10 +++-- Utility/LockPool/STM.hs | 4 +- Utility/Path/Tests.hs | 54 ++++++++++++++------------- Utility/Path/Windows.hs | 7 ++-- Utility/SshConfig.hs | 10 ++--- Utility/StatelessOpenPGP.hs | 6 +-- Utility/Su.hs | 2 +- Utility/Tor.hs | 69 ++++++++++++++++++++--------------- 18 files changed, 156 insertions(+), 153 deletions(-) diff --git a/Git.hs b/Git.hs index 74207c2589..32d37b1987 100644 --- a/Git.hs +++ b/Git.hs @@ -38,12 +38,10 @@ module Git ( relPath, ) where -import qualified Data.ByteString as B 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 diff --git a/Git/Repair.hs b/Git/Repair.hs index 1eb4e29b7c..2ea0b10bee 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -49,7 +49,6 @@ import qualified Utility.FileIO as F import qualified Data.Set as S import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L -import qualified System.FilePath.ByteString as P {- Given a set of bad objects found by git fsck, which may not - be complete, finds and removes all corrupt objects. -} @@ -59,9 +58,10 @@ cleanCorruptObjects fsckresults r = do mapM_ removeLoose (S.toList $ knownMissing fsckresults) mapM_ removeBad =<< listLooseObjectShas r where - removeLoose s = removeWhenExistsWith R.removeLink (looseObjectFile r s) + removeLoose s = removeWhenExistsWith R.removeLink $ + fromOsPath $ looseObjectFile r s removeBad s = do - void $ tryIO $ allowRead $ looseObjectFile r s + void $ tryIO $ allowRead $ fromOsPath $ looseObjectFile r s whenM (isMissing s r) $ removeLoose s @@ -85,20 +85,20 @@ explodePacks r = go =<< listPackFiles r putStrLn "Unpacking all pack files." forM_ packs $ \packfile -> do -- Just in case permissions are messed up. - allowRead packfile + allowRead (fromOsPath packfile) -- May fail, if pack file is corrupt. void $ tryIO $ pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h -> - L.hPut h =<< F.readFile (toOsPath packfile) + L.hPut h =<< F.readFile packfile objs <- emptyWhenDoesNotExist (dirContentsRecursive tmpdir) forM_ objs $ \objfile -> do f <- relPathDirToFile tmpdir objfile - let dest = objectsDir r P. f + let dest = objectsDir r f createDirectoryIfMissing True (parentDir dest) - moveFile objfile dest + moveFile (fromOsPath objfile) (fromOsPath dest) forM_ packs $ \packfile -> do - removeWhenExistsWith R.removeLink packfile - removeWhenExistsWith R.removeLink (packIdxFile packfile) + removeWhenExistsWith R.removeLink (fromOsPath packfile) + removeWhenExistsWith R.removeLink (fromOsPath (packIdxFile packfile)) return True {- Try to retrieve a set of missing objects, from the remotes of a @@ -115,7 +115,7 @@ retrieveMissingObjects missing referencerepo r unlessM (boolSystem "git" [Param "init", File (fromOsPath tmpdir)]) $ giveup $ "failed to create temp repository in " ++ fromOsPath tmpdir tmpr <- Config.read =<< Construct.fromPath tmpdir - let repoconfig r' = localGitDir r' "config" + let repoconfig r' = localGitDir r' literalOsPath "config" whenM (doesFileExist (repoconfig r)) $ F.readFile (repoconfig r) >>= F.writeFile (repoconfig tmpr) rs <- Construct.fromRemotes r @@ -251,7 +251,7 @@ getAllRefs r = getAllRefs' (localGitDir r literalOsPath "refs") getAllRefs' :: OsPath -> IO [Ref] getAllRefs' refdir = do let topsegs = length (splitPath refdir) - 1 - let toref = Ref . toInternalGitPath + let toref = Ref . fromOsPath . toInternalGitPath . joinPath . drop topsegs . splitPath map toref <$> emptyWhenDoesNotExist (dirContentsRecursive refdir) @@ -274,7 +274,7 @@ explodePackedRefsFile r = do writeFile (fromOsPath dest) (fromRef sha) packedRefsFile :: Repo -> OsPath -packedRefsFile r = localGitDir r "packed-refs" +packedRefsFile r = localGitDir r literalOsPath "packed-refs" parsePacked :: String -> Maybe (Sha, Ref) parsePacked l = case words l of @@ -286,7 +286,8 @@ parsePacked l = case words l of {- git-branch -d cannot be used to remove a branch that is directly - pointing to a corrupt commit. -} nukeBranchRef :: Branch -> Repo -> IO () -nukeBranchRef b r = removeWhenExistsWith R.removeLink $ localGitDir r P. fromRef' b +nukeBranchRef b r = removeWhenExistsWith R.removeLink $ fromOsPath $ + localGitDir r toOsPath (fromRef' b) {- Finds the most recent commit to a branch that does not need any - of the missing objects. If the input branch is good as-is, returns it. @@ -405,7 +406,7 @@ checkIndexFast r = do length indexcontents `seq` cleanup missingIndex :: Repo -> IO Bool -missingIndex r = not <$> doesFileExist (localGitDir r "index") +missingIndex r = not <$> doesFileExist (localGitDir r literalOsPath "index") {- Finds missing and ok files staged in the index. -} partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool) @@ -424,11 +425,11 @@ rewriteIndex r | otherwise = do (bad, good, cleanup) <- partitionIndex r unless (null bad) $ do - removeWhenExistsWith R.removeLink (indexFile r) + removeWhenExistsWith R.removeLink (fromOsPath (indexFile r)) UpdateIndex.streamUpdateIndex r =<< (catMaybes <$> mapM reinject good) void cleanup - return $ map (\(file,_, _, _) -> fromRawFilePath file) bad + return $ map (\(file,_, _, _) -> fromOsPath file) bad where reinject (file, sha, mode, _) = case toTreeItemType mode of Nothing -> return Nothing @@ -472,13 +473,13 @@ displayList items header preRepair :: Repo -> IO () preRepair g = do unlessM (validhead <$> catchDefaultIO "" (decodeBS <$> safeReadFile headfile)) $ do - removeWhenExistsWith R.removeLink headfile - writeFile (fromRawFilePath headfile) "ref: refs/heads/master" + removeWhenExistsWith R.removeLink (fromOsPath headfile) + writeFile (fromOsPath headfile) "ref: refs/heads/master" explodePackedRefsFile g unless (repoIsLocalBare g) $ - void $ tryIO $ allowWrite $ indexFile g + void $ tryIO $ allowWrite $ fromOsPath $ indexFile g where - headfile = localGitDir g P. "HEAD" + headfile = localGitDir g literalOsPath "HEAD" validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha (encodeBS s)) @@ -605,7 +606,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do else successfulfinish modifiedbranches corruptedindex = do - removeWhenExistsWith R.removeLink (indexFile g) + removeWhenExistsWith R.removeLink (fromOsPath (indexFile g)) -- The corrupted index can prevent fsck from finding other -- problems, so re-run repair. fsckresult' <- findBroken False False g diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs index a6bc469f66..bf171ae60e 100644 --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -76,14 +76,14 @@ doMerge hashhandle ch differ repo streamer = do void $ cleanup where go [] = noop - go (info:file:rest) = mergeFile info file hashhandle ch >>= + go (info:file:rest) = mergeFile info (toOsPath file) hashhandle ch >>= maybe (go rest) (\l -> streamer l >> go rest) go (_:[]) = giveup $ "parse error " ++ show differ {- Given an info line from a git raw diff, and the filename, generates - a line suitable for update-index that union merges the two sides of the - diff. -} -mergeFile :: S.ByteString -> RawFilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString) +mergeFile :: S.ByteString -> OsPath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString) mergeFile info file hashhandle h = case S8.words info of [_colonmode, _bmode, asha, bsha, _status] -> case filter (`notElem` nullShas) [Ref asha, Ref bsha] of diff --git a/Utility/DirWatcher.hs b/Utility/DirWatcher.hs index 99eede4173..f0805aa2c0 100644 --- a/Utility/DirWatcher.hs +++ b/Utility/DirWatcher.hs @@ -22,6 +22,7 @@ module Utility.DirWatcher ( ) where import Utility.DirWatcher.Types +import Utility.OsPath #if WITH_INOTIFY import qualified Utility.DirWatcher.INotify as INotify @@ -40,7 +41,7 @@ import qualified Utility.DirWatcher.Win32Notify as Win32Notify import qualified System.Win32.Notify as Win32Notify #endif -type Pruner = FilePath -> Bool +type Pruner = OsPath -> Bool canWatch :: Bool #if (WITH_INOTIFY || WITH_KQUEUE || WITH_FSEVENTS || WITH_WIN32NOTIFY) @@ -112,7 +113,7 @@ modifyTracked = error "modifyTracked not defined" - to shutdown later. -} #if WITH_INOTIFY type DirWatcherHandle = INotify.INotify -watchDir :: FilePath -> Pruner -> Bool -> WatchHooks -> (IO () -> IO ()) -> IO DirWatcherHandle +watchDir :: OsPath -> Pruner -> Bool -> WatchHooks -> (IO () -> IO ()) -> IO DirWatcherHandle watchDir dir prune scanevents hooks runstartup = do i <- INotify.initINotify runstartup $ INotify.watchDir i dir prune scanevents hooks @@ -120,14 +121,14 @@ watchDir dir prune scanevents hooks runstartup = do #else #if WITH_KQUEUE type DirWatcherHandle = ThreadId -watchDir :: FilePath -> Pruner -> Bool -> WatchHooks -> (IO Kqueue.Kqueue -> IO Kqueue.Kqueue) -> IO DirWatcherHandle +watchDir :: OsPath -> Pruner -> Bool -> WatchHooks -> (IO Kqueue.Kqueue -> IO Kqueue.Kqueue) -> IO DirWatcherHandle watchDir dir prune _scanevents hooks runstartup = do kq <- runstartup $ Kqueue.initKqueue dir prune forkIO $ Kqueue.runHooks kq hooks #else #if WITH_FSEVENTS type DirWatcherHandle = FSEvents.EventStream -watchDir :: FilePath -> Pruner -> Bool -> WatchHooks -> (IO FSEvents.EventStream -> IO FSEvents.EventStream) -> IO DirWatcherHandle +watchDir :: OsPath -> Pruner -> Bool -> WatchHooks -> (IO FSEvents.EventStream -> IO FSEvents.EventStream) -> IO DirWatcherHandle watchDir dir prune scanevents hooks runstartup = runstartup $ FSEvents.watchDir dir prune scanevents hooks #else diff --git a/Utility/DirWatcher/INotify.hs b/Utility/DirWatcher/INotify.hs index 4b14e85bd2..fa289b149e 100644 --- a/Utility/DirWatcher/INotify.hs +++ b/Utility/DirWatcher/INotify.hs @@ -47,7 +47,7 @@ import Control.Exception (throw) - So this will fail if there are too many subdirectories. The - errHook is called when this happens. -} -watchDir :: INotify -> FilePath -> (FilePath -> Bool) -> Bool -> WatchHooks -> IO () +watchDir :: INotify -> OsPath -> (OsPath -> Bool) -> Bool -> WatchHooks -> IO () watchDir i dir ignored scanevents hooks | ignored dir = noop | otherwise = do @@ -56,10 +56,10 @@ watchDir i dir ignored scanevents hooks lock <- newLock let handler event = withLock lock (void $ go event) flip catchNonAsync failedwatch $ do - void (addWatch i watchevents (toInternalFilePath dir) handler) + void (addWatch i watchevents (fromOsPath dir) handler) `catchIO` failedaddwatch withLock lock $ - mapM_ scan =<< filter (not . dirCruft . toRawFilePath) <$> + mapM_ scan =<< filter (`notElem` dirCruft) <$> getDirectoryContents dir where recurse d = watchDir i d ignored scanevents hooks @@ -108,22 +108,21 @@ watchDir i dir ignored scanevents hooks runhook addHook f ms _ -> noop where - f = fromInternalFilePath fi + f = toOsPath fi -- Closing a file is assumed to mean it's done being written, -- so a new add event is sent. go (Closed { isDirectory = False, maybeFilePath = Just fi }) = - checkfiletype Files.isRegularFile addHook $ - fromInternalFilePath fi + checkfiletype Files.isRegularFile addHook (toOsPath fi) -- When a file or directory is moved in, scan it to add new -- stuff. - go (MovedIn { filePath = fi }) = scan $ fromInternalFilePath fi + go (MovedIn { filePath = fi }) = scan (toOsPath fi) go (MovedOut { isDirectory = isd, filePath = fi }) | isd = runhook delDirHook f Nothing | otherwise = runhook delHook f Nothing where - f = fromInternalFilePath fi + f = toOsPath fi -- Verify that the deleted item really doesn't exist, -- since there can be spurious deletion events for items @@ -134,11 +133,11 @@ watchDir i dir ignored scanevents hooks | otherwise = guarded $ runhook delHook f Nothing where guarded = unlessM (filetype (const True) f) - f = fromInternalFilePath fi + f = toOsPath fi go (Modified { isDirectory = isd, maybeFilePath = Just fi }) | isd = noop - | otherwise = runhook modifyHook (fromInternalFilePath fi) Nothing + | otherwise = runhook modifyHook (toOsPath fi) Nothing go _ = noop @@ -150,35 +149,36 @@ watchDir i dir ignored scanevents hooks indir f = dir f - getstatus f = catchMaybeIO $ R.getSymbolicLinkStatus $ toRawFilePath $ indir f + getstatus f = catchMaybeIO $ R.getSymbolicLinkStatus $ fromOsPath $ indir f + checkfiletype check h f = do ms <- getstatus f case ms of Just s | check s -> runhook h f ms _ -> noop - filetype t f = catchBoolIO $ t <$> R.getSymbolicLinkStatus (toRawFilePath (indir f)) + filetype t f = catchBoolIO $ t <$> R.getSymbolicLinkStatus (fromOsPath (indir f)) failedaddwatch e -- Inotify fails when there are too many watches with a -- disk full error. | isFullError e = case errHook hooks of - Nothing -> giveup $ "failed to add inotify watch on directory " ++ dir ++ " (" ++ show e ++ ")" + Nothing -> giveup $ "failed to add inotify watch on directory " ++ fromOsPath dir ++ " (" ++ show e ++ ")" Just hook -> tooManyWatches hook dir -- The directory could have been deleted. | isDoesNotExistError e = return () | otherwise = throw e - failedwatch e = hPutStrLn stderr $ "failed to add watch on directory " ++ dir ++ " (" ++ show e ++ ")" + failedwatch e = hPutStrLn stderr $ "failed to add watch on directory " ++ fromOsPath dir ++ " (" ++ show e ++ ")" -tooManyWatches :: (String -> Maybe FileStatus -> IO ()) -> FilePath -> IO () +tooManyWatches :: (String -> Maybe FileStatus -> IO ()) -> OsPath -> IO () tooManyWatches hook dir = do sysctlval <- querySysctl [Param maxwatches] :: IO (Maybe Integer) hook (unlines $ basewarning : maybe withoutsysctl withsysctl sysctlval) Nothing where maxwatches = "fs.inotify.max_user_watches" - basewarning = "Too many directories to watch! (Not watching " ++ dir ++")" + basewarning = "Too many directories to watch! (Not watching " ++ fromOsPath dir ++")" withoutsysctl = ["Increase the value in /proc/sys/fs/inotify/max_user_watches"] withsysctl n = let new = n * 10 in [ "Increase the limit permanently by running:" @@ -197,9 +197,3 @@ querySysctl ps = getM go ["sysctl", "/sbin/sysctl", "/usr/sbin/sysctl"] Nothing -> return Nothing Just s -> return $ parsesysctl s parsesysctl s = readish =<< lastMaybe (words s) - -toInternalFilePath :: FilePath -> RawFilePath -toInternalFilePath = toRawFilePath - -fromInternalFilePath :: RawFilePath -> FilePath -fromInternalFilePath = fromRawFilePath diff --git a/Utility/DirWatcher/Types.hs b/Utility/DirWatcher/Types.hs index 9abd5f36a1..ff68295c62 100644 --- a/Utility/DirWatcher/Types.hs +++ b/Utility/DirWatcher/Types.hs @@ -16,12 +16,12 @@ import Common type Hook a = Maybe (a -> Maybe FileStatus -> IO ()) data WatchHooks = WatchHooks - { addHook :: Hook FilePath - , addSymlinkHook :: Hook FilePath - , delHook :: Hook FilePath - , delDirHook :: Hook FilePath + { addHook :: Hook OsPath + , addSymlinkHook :: Hook OsPath + , delHook :: Hook OsPath + , delDirHook :: Hook OsPath , errHook :: Hook String -- error message - , modifyHook :: Hook FilePath + , modifyHook :: Hook OsPath } mkWatchHooks :: WatchHooks diff --git a/Utility/Directory/Create.hs b/Utility/Directory/Create.hs index 9acc0146ac..5aad1fb63a 100644 --- a/Utility/Directory/Create.hs +++ b/Utility/Directory/Create.hs @@ -25,9 +25,7 @@ import Prelude import Utility.SystemDirectory import Utility.Path.AbsRel import Utility.Exception -import Utility.FileSystemEncoding import Utility.OsPath -import qualified Utility.RawFilePath as R import Utility.PartialPrelude {- Like createDirectoryIfMissing True, but it will only create @@ -69,7 +67,7 @@ createDirectoryUnder' topdirs dir0 mkdir = do -- it's not. And on Windows, if they are on different drives, -- the path will not be relative. let notbeneath = \(_topdir, (relp, dirs)) -> - headMaybe dirs /= Just ".." && not (isAbsolute relp) + headMaybe dirs /= Just (literalOsPath "..") && not (isAbsolute relp) case filter notbeneath $ zip topdirs (zip relps relparts) of ((topdir, (_relp, dirs)):_) -- If dir0 is the same as the topdir, don't try to diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index c7f5fe7644..0fbc6a8f91 100644 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -416,9 +416,9 @@ testHarness tmpdir cmd a = ifM (inSearchPath (unGpgCmd cmd)) setup = do subdir <- makenewdir (1 :: Integer) origenviron <- getEnvironment - let environ = addEntry var subdir origenviron + let environ = addEntry var (fromOsPath subdir) origenviron -- gpg is picky about permissions on its home dir - liftIO $ void $ tryIO $ modifyFileMode (toRawFilePath subdir) $ + liftIO $ void $ tryIO $ modifyFileMode (fromOsPath subdir) $ removeModes $ otherGroupModes -- For some reason, recent gpg needs a trustdb to be set up. _ <- pipeStrict' cmd [Param "--trust-model", Param "auto", Param "--update-trustdb"] (Just environ) mempty diff --git a/Utility/LinuxMkLibs.hs b/Utility/LinuxMkLibs.hs index ac329f4df0..54c786b8de 100644 --- a/Utility/LinuxMkLibs.hs +++ b/Utility/LinuxMkLibs.hs @@ -44,7 +44,7 @@ installLib installfile top lib = ifM (doesFileExist (toOsPath lib)) ( do installfile top lib checksymlink lib - return $ Just $ fromRawFilePath $ parentDir $ toRawFilePath lib + return $ Just $ fromOsPath $ parentDir $ toOsPath lib , return Nothing ) where diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs index 236c1aaeba..ff49d9abfa 100644 --- a/Utility/LockFile/PidLock.hs +++ b/Utility/LockFile/PidLock.hs @@ -50,7 +50,6 @@ import System.Posix.Files.ByteString import System.Posix.Process import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO) -import qualified System.FilePath.ByteString as P import Data.Maybe import Data.List import Network.BSD @@ -151,7 +150,7 @@ tryLock lockfile = do where go abslockfile sidelock = do (tmp, h) <- openTmpFileIn - (toOsPath (P.takeDirectory abslockfile)) + (takeDirectory abslockfile) (literalOsPath "locktmp") let tmp' = fromOsPath tmp setFileMode tmp' (combineModes readModes) @@ -162,7 +161,7 @@ tryLock lockfile = do removeWhenExistsWith removeLink tmp' return Nothing let tooklock st = return $ Just $ LockHandle abslockfile st sidelock - linkToLock sidelock tmp' abslockfile >>= \case + linkToLock sidelock tmp' (fromOsPath abslockfile) >>= \case Just lckst -> do removeWhenExistsWith removeLink tmp' tooklock lckst @@ -177,7 +176,7 @@ tryLock lockfile = do -- the pidlock was taken on, -- we know that the pidlock is -- stale, and can take it over. - rename tmp' abslockfile + rename tmp' (fromOsPath abslockfile) tooklock tmpst _ -> failedlock @@ -201,7 +200,7 @@ linkToLock (Just _) src dest = do Right _ -> do _ <- tryIO $ createLink src dest ifM (catchBoolIO checklinked) - ( ifM (catchBoolIO $ not <$> checkInsaneLustre dest) + ( ifM (catchBoolIO $ not <$> checkInsaneLustre (toOsPath dest)) ( catchMaybeIO $ getFileStatus dest , return Nothing ) @@ -243,16 +242,16 @@ linkToLock (Just _) src dest = do -- We can detect this insanity by getting the directory contents after -- making the link, and checking to see if 2 copies of the dest file, -- with the SAME FILENAME exist. -checkInsaneLustre :: RawFilePath -> IO Bool +checkInsaneLustre :: OsPath -> IO Bool checkInsaneLustre dest = do - fs <- dirContents (P.takeDirectory dest) + fs <- dirContents (takeDirectory dest) case length (filter (== dest) fs) of 1 -> return False -- whew! 0 -> return True -- wtf? _ -> do -- Try to clean up the extra copy we made -- that has the same name. Egads. - _ <- tryIO $ removeLink dest + _ <- tryIO $ removeLink $ fromOsPath dest return True -- | Waits as necessary to take a lock. @@ -268,7 +267,7 @@ waitLock (Seconds timeout) lockfile displaymessage sem = go timeout | n > 0 = liftIO (tryLock lockfile) >>= \case Nothing -> do when (n == pred timeout) $ - displaymessage $ "waiting for pid lock file " ++ fromRawFilePath lockfile ++ " which is held by another process (or may be stale)" + displaymessage $ "waiting for pid lock file " ++ fromOsPath lockfile ++ " which is held by another process (or may be stale)" liftIO $ threadDelaySeconds (Seconds 1) go (pred n) Just lckh -> do @@ -280,15 +279,15 @@ waitLock (Seconds timeout) lockfile displaymessage sem = go timeout waitedLock :: MonadIO m => Seconds -> PidLockFile -> (String -> m ()) -> m a waitedLock (Seconds timeout) lockfile displaymessage = do - displaymessage $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ fromRawFilePath lockfile - giveup $ "Gave up waiting for pid lock file " ++ fromRawFilePath lockfile + displaymessage $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ fromOsPath lockfile + giveup $ "Gave up waiting for pid lock file " ++ fromOsPath lockfile -- | Use when the pid lock has already been taken by another thread of the -- same process. alreadyLocked :: MonadIO m => PidLockFile -> m LockHandle alreadyLocked lockfile = liftIO $ do abslockfile <- absPath lockfile - st <- getFileStatus abslockfile + st <- getFileStatus (fromOsPath abslockfile) return $ LockHandle abslockfile st Nothing dropLock :: LockHandle -> IO () @@ -296,7 +295,7 @@ dropLock (LockHandle lockfile _ sidelock) = do -- Drop side lock first, at which point the pid lock will be -- considered stale. dropSideLock sidelock - removeWhenExistsWith removeLink lockfile + removeWhenExistsWith removeLink (fromOsPath lockfile) dropLock ParentLocked = return () getLockStatus :: PidLockFile -> IO LockStatus @@ -312,7 +311,7 @@ checkLocked lockfile = conv <$> getLockStatus lockfile -- locked to get the LockHandle. checkSaneLock :: PidLockFile -> LockHandle -> IO Bool checkSaneLock lockfile (LockHandle _ st _) = - go =<< catchMaybeIO (getFileStatus lockfile) + go =<< catchMaybeIO (getFileStatus (fromOsPath lockfile)) where go Nothing = return False go (Just st') = return $ @@ -327,9 +326,9 @@ checkSaneLock _ ParentLocked = return True -- The parent process should keep running as long as the child -- process is running, since the child inherits the environment and will -- not see unsetLockEnv. -pidLockEnv :: RawFilePath -> IO String +pidLockEnv :: OsPath -> IO String pidLockEnv lockfile = do - abslockfile <- fromRawFilePath <$> absPath lockfile + abslockfile <- fromOsPath <$> absPath lockfile return $ "PIDLOCK_" ++ filter legalInEnvVar abslockfile pidLockEnvValue :: String diff --git a/Utility/LockFile/Posix.hs b/Utility/LockFile/Posix.hs index e7d49b81e3..e05f813e99 100644 --- a/Utility/LockFile/Posix.hs +++ b/Utility/LockFile/Posix.hs @@ -25,6 +25,7 @@ import Utility.Applicative import Utility.FileMode import Utility.LockFile.LockStatus import Utility.OpenFd +import Utility.OsPath import System.IO import System.Posix.Types @@ -33,7 +34,7 @@ import System.Posix.Files.ByteString import System.FilePath.ByteString (RawFilePath) import Data.Maybe -type LockFile = RawFilePath +type LockFile = OsPath newtype LockHandle = LockHandle Fd @@ -75,11 +76,12 @@ tryLock lockreq mode lockfile = uninterruptibleMask_ $ do -- Close on exec flag is set so child processes do not inherit the lock. openLockFile :: LockRequest -> Maybe ModeSetter -> LockFile -> IO Fd openLockFile lockreq filemode lockfile = do - l <- applyModeSetter filemode lockfile $ \filemode' -> - openFdWithMode lockfile openfor filemode' defaultFileFlags + l <- applyModeSetter filemode lockfile' $ \filemode' -> + openFdWithMode lockfile' openfor filemode' defaultFileFlags setFdOption l CloseOnExec True return l where + lockfile' = fromOsPath lockfile openfor = case lockreq of ReadLock -> ReadOnly _ -> ReadWrite @@ -120,7 +122,7 @@ dropLock (LockHandle fd) = closeFd fd -- else. checkSaneLock :: LockFile -> LockHandle -> IO Bool checkSaneLock lockfile (LockHandle fd) = - go =<< catchMaybeIO (getFileStatus lockfile) + go =<< catchMaybeIO (getFileStatus (fromOsPath lockfile)) where go Nothing = return False go (Just st) = do diff --git a/Utility/LockPool/STM.hs b/Utility/LockPool/STM.hs index 2c3eb66aef..370ef1c65e 100644 --- a/Utility/LockPool/STM.hs +++ b/Utility/LockPool/STM.hs @@ -23,14 +23,14 @@ module Utility.LockPool.STM ( ) where import Utility.Monad +import Utility.OsPath import System.IO.Unsafe (unsafePerformIO) -import System.FilePath.ByteString (RawFilePath) import qualified Data.Map.Strict as M import Control.Concurrent.STM import Control.Exception -type LockFile = RawFilePath +type LockFile = OsPath data LockMode = LockExclusive | LockShared deriving (Eq) diff --git a/Utility/Path/Tests.hs b/Utility/Path/Tests.hs index 857a3aad4b..e7df275bd3 100644 --- a/Utility/Path/Tests.hs +++ b/Utility/Path/Tests.hs @@ -17,41 +17,39 @@ module Utility.Path.Tests ( prop_dirContains_regressionTest, ) where -import qualified Data.ByteString as B import Data.List import Data.Maybe -import Data.Char import Control.Applicative import Prelude import Common -import Utility.Path import Utility.QuickCheck +import qualified Utility.OsString as OS prop_upFrom_basics :: TestableFilePath -> Bool prop_upFrom_basics tdir | dir == "/" = p == Nothing | otherwise = p /= Just dir where - p = fromRawFilePath <$> upFrom (toRawFilePath dir) + p = fromOsPath <$> upFrom (toOsPath dir) dir = fromTestableFilePath tdir prop_relPathDirToFileAbs_basics :: TestableFilePath -> Bool prop_relPathDirToFileAbs_basics pt = and - [ relPathDirToFileAbs p (p "bar") == "bar" - , relPathDirToFileAbs (p "bar") p == ".." - , relPathDirToFileAbs p p == "" + [ relPathDirToFileAbs p (p literalOsPath "bar") == literalOsPath "bar" + , relPathDirToFileAbs (p literalOsPath "bar") p == literalOsPath ".." + , relPathDirToFileAbs p p == literalOsPath "" ] where -- relPathDirToFileAbs needs absolute paths, so make the path -- absolute by adding a path separator to the front. - p = pathSeparator `B.cons` relf + p = pathSeparator `OS.cons` relf -- Make the input a relative path. On windows, make sure it does -- not contain anything that looks like a drive letter. - relf = B.dropWhile isPathSeparator $ - B.filter (not . skipchar) $ - toRawFilePath (fromTestableFilePath pt) - skipchar b = b == (fromIntegral (ord ':')) + relf = OS.dropWhile isPathSeparator $ + OS.filter (not . skipchar) $ + toOsPath (fromTestableFilePath pt) + skipchar b = b == unsafeFromChar ':' prop_relPathDirToFileAbs_regressionTest :: Bool prop_relPathDirToFileAbs_regressionTest = same_dir_shortcurcuits_at_difference @@ -60,21 +58,25 @@ prop_relPathDirToFileAbs_regressionTest = same_dir_shortcurcuits_at_difference - location, but it's not really the same directory. - Code used to get this wrong. -} same_dir_shortcurcuits_at_difference = - relPathDirToFileAbs (joinPath [pathSeparator `B.cons` "tmp", "r", "lll", "xxx", "yyy", "18"]) - (joinPath [pathSeparator `B.cons` "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]) - == joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"] + relPathDirToFileAbs (mkp [fromOsPath (pathSeparator `OS.cons` literalOsPath "tmp"), "r", "lll", "xxx", "yyy", "18"]) + (mkp [fromOsPath (pathSeparator `OS.cons` literalOsPath "tmp"), "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]) + == mkp ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"] + where + mkp = joinPath . map literalOsPath prop_dirContains_regressionTest :: Bool prop_dirContains_regressionTest = and - [ not $ dirContains "." ".." - , not $ dirContains ".." "../.." - , dirContains "." "foo" - , dirContains "." "." - , dirContains ".." ".." - , dirContains "../.." "../.." - , dirContains "." "./foo" - , dirContains ".." "../foo" - , dirContains "../.." "../foo" - , dirContains "../.." "../../foo" - , not $ dirContains "../.." "../../.." + [ not $ dc "." ".." + , not $ dc ".." "../.." + , dc "." "foo" + , dc "." "." + , dc ".." ".." + , dc "../.." "../.." + , dc "." "./foo" + , dc ".." "../foo" + , dc "../.." "../foo" + , dc "../.." "../../foo" + , not $ dc "../.." "../../.." ] + where + dc x y = dirContains (literalOsPath x) (literalOsPath y) diff --git a/Utility/Path/Windows.hs b/Utility/Path/Windows.hs index f5342806b2..583f90dd61 100644 --- a/Utility/Path/Windows.hs +++ b/Utility/Path/Windows.hs @@ -14,11 +14,10 @@ module Utility.Path.Windows ( import Utility.Path import Utility.OsPath -import Utility.FileSystemEncoding +import Utility.SystemDirectory import qualified Data.ByteString as B import qualified System.FilePath.Windows.ByteString as P -import System.Directory (getCurrentDirectory) {- Convert a filepath to use Windows's native namespace. - This avoids filesystem length limits. @@ -36,8 +35,8 @@ convertToWindowsNativeNamespace f | otherwise = do -- Make absolute because any '.' and '..' in the path -- will not be resolved once it's converted. - cwd <- toRawFilePath <$> getCurrentDirectory - let p = fromOsPath (simplifyPath (toOsPath (combine cwd f))) + cwd <- getCurrentDirectory + let p = fromOsPath (simplifyPath (combine cwd (toOsPath f))) -- Normalize slashes. let p' = P.normalise p return (win32_file_namespace <> p') diff --git a/Utility/SshConfig.hs b/Utility/SshConfig.hs index fb7a6b95ac..798a48148f 100644 --- a/Utility/SshConfig.hs +++ b/Utility/SshConfig.hs @@ -134,16 +134,16 @@ modifyUserSshConfig modifier = changeUserSshConfig $ changeUserSshConfig :: (String -> String) -> IO () changeUserSshConfig modifier = do sshdir <- sshDir - let configfile = sshdir "config" + let configfile = sshdir literalOsPath "config" whenM (doesFileExist configfile) $ do c <- decodeBS . S8.unlines . fileLines' - <$> F.readFile' (toOsPath (toRawFilePath configfile)) + <$> F.readFile' configfile let c' = modifier c when (c /= c') $ do -- If it's a symlink, replace the file it -- points to. f <- catchDefaultIO configfile (canonicalizePath configfile) - viaTmp writeSshConfig (toOsPath (toRawFilePath f)) c' + viaTmp writeSshConfig f c' writeSshConfig :: OsPath -> String -> IO () writeSshConfig f s = do @@ -161,7 +161,7 @@ setSshConfigMode :: RawFilePath -> IO () setSshConfigMode f = void $ tryIO $ modifyFileMode f $ removeModes [groupWriteMode, otherWriteMode] -sshDir :: IO FilePath +sshDir :: IO OsPath sshDir = do home <- myHomeDir - return $ home ".ssh" + return $ toOsPath home literalOsPath ".ssh" diff --git a/Utility/StatelessOpenPGP.hs b/Utility/StatelessOpenPGP.hs index 8d3f584b3a..290984c4cc 100644 --- a/Utility/StatelessOpenPGP.hs +++ b/Utility/StatelessOpenPGP.hs @@ -70,7 +70,7 @@ newtype Armoring = Armoring Bool - The directory does not really have to be empty, it just needs to be one - that should not contain any files with names starting with "@". -} -newtype EmptyDirectory = EmptyDirectory FilePath +newtype EmptyDirectory = EmptyDirectory OsPath {- Encrypt using symmetric encryption with the specified password. -} encryptSymmetric @@ -112,7 +112,7 @@ decryptSymmetric sopcmd password emptydirectory feeder reader = {- Test a value round-trips through symmetric encryption and decryption. -} test_encrypt_decrypt_Symmetric :: SOPCmd -> SOPCmd -> Password -> Armoring -> B.ByteString -> IO Bool test_encrypt_decrypt_Symmetric a b password armoring v = catchBoolIO $ - withTmpDir (toOsPath "test") $ \d -> do + withTmpDir (literalOsPath "test") $ \d -> do let ed = EmptyDirectory d enc <- encryptSymmetric a password ed Nothing armoring (`B.hPutStr` v) B.hGetContents @@ -188,7 +188,7 @@ feedRead' (SOPCmd cmd) subcmd params med feeder reader = do , std_out = CreatePipe , std_err = Inherit , cwd = case med of - Just (EmptyDirectory d) -> Just d + Just (EmptyDirectory d) -> Just (fromOsPath d) Nothing -> Nothing } copyright =<< bracket (setup p) cleanup (go p) diff --git a/Utility/Su.hs b/Utility/Su.hs index d2d970298a..d926692612 100644 --- a/Utility/Su.hs +++ b/Utility/Su.hs @@ -70,7 +70,7 @@ runSuCommand Nothing _ = return False mkSuCommand :: String -> [CommandParam] -> IO (Maybe SuCommand) #ifndef mingw32_HOST_OS mkSuCommand cmd ps = do - pwd <- getCurrentDirectory + pwd <- fromOsPath <$> getCurrentDirectory firstM (\(SuCommand _ p _) -> inSearchPath p) =<< selectcmds pwd where selectcmds pwd = ifM (inx <||> (not <$> atconsole)) diff --git a/Utility/Tor.hs b/Utility/Tor.hs index b6e9484890..1696d7c3cf 100644 --- a/Utility/Tor.hs +++ b/Utility/Tor.hs @@ -21,6 +21,7 @@ import Common import Utility.ThreadScheduler import Utility.FileMode import Utility.RawFilePath (setOwnerAndGroup) +import qualified Utility.OsString as OS import System.PosixCompat.Types import System.PosixCompat.Files (ownerReadMode, ownerWriteMode, ownerExecuteMode) @@ -35,7 +36,7 @@ type OnionPort = Int newtype OnionAddress = OnionAddress String deriving (Show, Eq) -type OnionSocket = FilePath +type OnionSocket = OsPath -- | A unique identifier for a hidden service. type UniqueIdent = String @@ -68,21 +69,21 @@ connectHiddenService (OnionAddress address) port = do addHiddenService :: AppName -> UserID -> UniqueIdent -> IO (OnionAddress, OnionPort) addHiddenService appname uid ident = do prepHiddenServiceSocketDir appname uid ident - ls <- lines <$> (readFile =<< findTorrc) + ls <- lines <$> (readFile . fromOsPath =<< findTorrc) let portssocks = mapMaybe (parseportsock . separate isSpace) ls - case filter (\(_, s) -> s == sockfile) portssocks of + case filter (\(_, s) -> s == fromOsPath sockfile) portssocks of ((p, _s):_) -> waithiddenservice 1 p _ -> do highports <- R.getStdRandom mkhighports let newport = fromMaybe (error "internal") $ headMaybe $ filter (`notElem` map fst portssocks) highports torrc <- findTorrc - writeFile torrc $ unlines $ + writeFile (fromOsPath torrc) $ unlines $ ls ++ [ "" - , "HiddenServiceDir " ++ hiddenServiceDir appname uid ident + , "HiddenServiceDir " ++ fromOsPath (hiddenServiceDir appname uid ident) , "HiddenServicePort " ++ show newport ++ - " unix:" ++ sockfile + " unix:" ++ fromOsPath sockfile ] -- Reload tor, so it will see the new hidden -- service and generate the hostname file for it. @@ -109,7 +110,8 @@ addHiddenService appname uid ident = do waithiddenservice :: Int -> OnionPort -> IO (OnionAddress, OnionPort) waithiddenservice 0 _ = giveup "tor failed to create hidden service, perhaps the tor service is not running" waithiddenservice n p = do - v <- tryIO $ readFile $ hiddenServiceHostnameFile appname uid ident + v <- tryIO $ readFile $ fromOsPath $ + hiddenServiceHostnameFile appname uid ident case v of Right s | ".onion\n" `isSuffixOf` s -> return (OnionAddress (takeWhile (/= '\n') s), p) @@ -122,11 +124,13 @@ addHiddenService appname uid ident = do -- Has to be inside the torLibDir so tor can create it. -- -- Has to end with "uid_ident" so getHiddenServiceSocketFile can find it. -hiddenServiceDir :: AppName -> UserID -> UniqueIdent -> FilePath -hiddenServiceDir appname uid ident = torLibDir appname ++ "_" ++ show uid ++ "_" ++ ident +hiddenServiceDir :: AppName -> UserID -> UniqueIdent -> OsPath +hiddenServiceDir appname uid ident = + torLibDir toOsPath (appname ++ "_" ++ show uid ++ "_" ++ ident) -hiddenServiceHostnameFile :: AppName -> UserID -> UniqueIdent -> FilePath -hiddenServiceHostnameFile appname uid ident = hiddenServiceDir appname uid ident "hostname" +hiddenServiceHostnameFile :: AppName -> UserID -> UniqueIdent -> OsPath +hiddenServiceHostnameFile appname uid ident = + hiddenServiceDir appname uid ident literalOsPath "hostname" -- | Location of the socket for a hidden service. -- @@ -136,33 +140,36 @@ hiddenServiceHostnameFile appname uid ident = hiddenServiceDir appname uid ident -- Note that some unix systems limit socket paths to 92 bytes long. -- That should not be a problem if the UniqueIdent is around the length of -- a UUID, and the AppName is short. -hiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> FilePath -hiddenServiceSocketFile appname uid ident = varLibDir appname show uid ++ "_" ++ ident "s" +hiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> OsPath +hiddenServiceSocketFile appname uid ident = + varLibDir toOsPath appname + toOsPath (show uid ++ "_" ++ ident) toOsPath "s" -- | Parse torrc, to get the socket file used for a hidden service with -- the specified UniqueIdent. -getHiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> IO (Maybe FilePath) +getHiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> IO (Maybe OsPath) getHiddenServiceSocketFile _appname uid ident = - parse . map words . lines <$> catchDefaultIO "" (readFile =<< findTorrc) + parse . map words . lines <$> catchDefaultIO "" + (readFile . fromOsPath =<< findTorrc) where parse [] = Nothing parse (("HiddenServiceDir":hsdir:[]):("HiddenServicePort":_hsport:hsaddr:[]):rest) - | "unix:" `isPrefixOf` hsaddr && hasident hsdir = - Just (drop (length "unix:") hsaddr) + | "unix:" `isPrefixOf` hsaddr && hasident (toOsPath hsdir) = + Just $ toOsPath $ drop (length "unix:") hsaddr | otherwise = parse rest parse (_:rest) = parse rest -- Don't look for AppName in the hsdir, because it didn't used to -- be included. - hasident hsdir = (show uid ++ "_" ++ ident) `isSuffixOf` takeFileName hsdir + hasident hsdir = toOsPath (show uid ++ "_" ++ ident) `OS.isSuffixOf` takeFileName hsdir -- | Sets up the directory for the socketFile, with appropriate -- permissions. Must run as root. prepHiddenServiceSocketDir :: AppName -> UserID -> UniqueIdent -> IO () prepHiddenServiceSocketDir appname uid ident = do createDirectoryIfMissing True d - setOwnerAndGroup (toRawFilePath d) uid (-1) - modifyFileMode (toRawFilePath d) $ + setOwnerAndGroup (fromOsPath d) uid (-1) + modifyFileMode (fromOsPath d) $ addModes [ownerReadMode, ownerExecuteMode, ownerWriteMode] where d = takeDirectory $ hiddenServiceSocketFile appname uid ident @@ -170,21 +177,23 @@ prepHiddenServiceSocketDir appname uid ident = do -- | Finds the system's torrc file, in any of the typical locations of it. -- Returns the first found. If there is no system torrc file, defaults to -- /etc/tor/torrc. -findTorrc :: IO FilePath -findTorrc = fromMaybe "/etc/tor/torrc" <$> firstM doesFileExist - -- Debian - [ "/etc/tor/torrc" +findTorrc :: IO OsPath +findTorrc = fromMaybe deftorrc <$> firstM doesFileExist + [ deftorrc -- Some systems put it here instead. - , "/etc/torrc" + , literalOsPath "/etc/torrc" -- Default when installed from source - , "/usr/local/etc/tor/torrc" + , literalOsPath "/usr/local/etc/tor/torrc" ] + where + -- Debian uses this + deftorrc = literalOsPath "/etc/tor/torrc" -torLibDir :: FilePath -torLibDir = "/var/lib/tor" +torLibDir :: OsPath +torLibDir = literalOsPath "/var/lib/tor" -varLibDir :: FilePath -varLibDir = "/var/lib" +varLibDir :: OsPath +varLibDir = literalOsPath "/var/lib" torIsInstalled :: IO Bool torIsInstalled = inSearchPath "tor"