more OsPath conversion
Sponsored-by: Leon Schuermann
This commit is contained in:
Joey Hess
parent
ee0964e61b
commit
f3539efc16
18 changed files with 156 additions and 153 deletions
2
Git.hs
2
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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')
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue