Merge branch 'threaded' into assistant

This commit is contained in:
Joey Hess 2012-07-18 18:17:33 -04:00
commit f2ed3d6c8e
31 changed files with 262 additions and 158 deletions

View file

@ -20,6 +20,8 @@ module Annex.UUID (
removeRepoUUID, removeRepoUUID,
) where ) where
import System.Process
import Common.Annex import Common.Annex
import qualified Git import qualified Git
import qualified Git.Config import qualified Git.Config
@ -32,8 +34,10 @@ configkey = annexConfig "uuid"
{- Generates a UUID. There is a library for this, but it's not packaged, {- Generates a UUID. There is a library for this, but it's not packaged,
- so use the command line tool. -} - so use the command line tool. -}
genUUID :: IO UUID genUUID :: IO UUID
genUUID = pOpen ReadFromPipe command params $ liftM toUUID . hGetLine genUUID = gen . lines <$> readProcess command params []
where where
gen [] = error $ "no output from " ++ command
gen (l:_) = toUUID l
command = SysConfig.uuid command = SysConfig.uuid
params params
-- request a random uuid be generated -- request a random uuid be generated

View file

@ -12,6 +12,7 @@ import qualified Annex
import Types.Backend import Types.Backend
import Types.Key import Types.Key
import Types.KeySource import Types.KeySource
import System.Process
import qualified Build.SysConfig as SysConfig import qualified Build.SysConfig as SysConfig
import Data.Digest.Pure.SHA import Data.Digest.Pure.SHA
@ -53,14 +54,16 @@ shaN shasize file filesize = do
showAction "checksum" showAction "checksum"
case shaCommand shasize filesize of case shaCommand shasize filesize of
Left sha -> liftIO $ sha <$> L.readFile file Left sha -> liftIO $ sha <$> L.readFile file
Right command -> liftIO $ runcommand command Right command -> liftIO $ parse command . lines <$>
readProcess command (toCommand [File file]) ""
where where
runcommand command = parse command [] = bad command
pOpen ReadFromPipe command (toCommand [File file]) $ \h -> do parse command (l:_)
sha <- fst . separate (== ' ') <$> hGetLine h | null sha = bad command
if null sha | otherwise = sha
then error $ command ++ " parse error" where
else return sha sha = fst $ separate (== ' ') l
bad command = error $ command ++ " parse error"
shaCommand :: SHASize -> Integer -> Either (L.ByteString -> String) String shaCommand :: SHASize -> Integer -> Either (L.ByteString -> String) String
shaCommand shasize filesize shaCommand shasize filesize

View file

@ -4,7 +4,7 @@ module Build.Configure where
import System.Directory import System.Directory
import Data.List import Data.List
import System.Cmd.Utils import System.Process
import Control.Applicative import Control.Applicative
import System.FilePath import System.FilePath
@ -71,7 +71,7 @@ getVersionString = do
getGitVersion :: Test getGitVersion :: Test
getGitVersion = do getGitVersion = do
(_, s) <- pipeFrom "git" ["--version"] s <- readProcess "git" ["--version"] ""
let version = unwords $ drop 2 $ words $ head $ lines s let version = unwords $ drop 2 $ words $ head $ lines s
return $ Config "gitversion" (StringConfig version) return $ Config "gitversion" (StringConfig version)

View file

@ -7,6 +7,8 @@
module Command.Fsck where module Command.Fsck where
import System.Posix.Process (getProcessID)
import Common.Annex import Common.Annex
import Command import Command
import qualified Annex import qualified Annex

View file

@ -9,6 +9,7 @@ module Command.Map where
import Control.Exception.Extensible import Control.Exception.Extensible
import qualified Data.Map as M import qualified Data.Map as M
import System.Process
import Common.Annex import Common.Annex
import Command import Command
@ -198,9 +199,13 @@ tryScan r
case result of case result of
Left _ -> return Nothing Left _ -> return Nothing
Right r' -> return $ Just r' Right r' -> return $ Just r'
pipedconfig cmd params = safely $ pipedconfig cmd params = safely $ do
pOpen ReadFromPipe cmd (toCommand params) $ (_, Just h, _, pid) <-
Git.Config.hRead r createProcess (proc cmd $ toCommand params)
{ std_out = CreatePipe }
r' <- Git.Config.hRead r h
forceSuccessProcess pid cmd $ toCommand params
return r'
configlist = configlist =
onRemote r (pipedconfig, Nothing) "configlist" [] [] onRemote r (pipedconfig, Nothing) "configlist" [] []

View file

@ -13,16 +13,15 @@ import Data.String.Utils as X
import System.Path as X import System.Path as X
import System.FilePath as X import System.FilePath as X
import System.Directory as X import System.Directory as X
import System.Cmd.Utils as X hiding (safeSystem)
import System.IO as X hiding (FilePath) import System.IO as X hiding (FilePath)
import System.Posix.Files as X import System.Posix.Files as X
import System.Posix.IO as X import System.Posix.IO as X
import System.Posix.Process as X hiding (executeFile)
import System.Exit as X import System.Exit as X
import Utility.Misc as X import Utility.Misc as X
import Utility.Exception as X import Utility.Exception as X
import Utility.SafeCommand as X import Utility.SafeCommand as X
import Utility.Process as X
import Utility.Path as X import Utility.Path as X
import Utility.Directory as X import Utility.Directory as X
import Utility.Monad as X import Utility.Monad as X

View file

@ -7,6 +7,8 @@
module Config where module Config where
import System.Process
import Common.Annex import Common.Annex
import qualified Git import qualified Git
import qualified Git.Config import qualified Git.Config
@ -56,7 +58,7 @@ remoteCost r def = do
cmd <- getRemoteConfig r "cost-command" "" cmd <- getRemoteConfig r "cost-command" ""
(fromMaybe def . readish) <$> (fromMaybe def . readish) <$>
if not $ null cmd if not $ null cmd
then liftIO $ snd <$> pipeFrom "sh" ["-c", cmd] then liftIO $ readProcess "sh" ["-c", cmd] ""
else getRemoteConfig r "cost" "" else getRemoteConfig r "cost" ""
cheapRemoteCost :: Int cheapRemoteCost :: Int
@ -116,4 +118,4 @@ getHttpHeaders = do
cmd <- getConfig (annexConfig "http-headers-command") "" cmd <- getConfig (annexConfig "http-headers-command") ""
if null cmd if null cmd
then fromRepo $ Git.Config.getList "annex.http-headers" then fromRepo $ Git.Config.getList "annex.http-headers"
else lines . snd <$> liftIO (pipeFrom "sh" ["-c", cmd]) else lines <$> liftIO (readProcess "sh" ["-c", cmd] "")

View file

@ -73,12 +73,10 @@ commit :: String -> Branch -> [Ref] -> Repo -> IO Sha
commit message branch parentrefs repo = do commit message branch parentrefs repo = do
tree <- getSha "write-tree" $ tree <- getSha "write-tree" $
pipeRead [Param "write-tree"] repo pipeRead [Param "write-tree"] repo
sha <- getSha "commit-tree" $ sha <- getSha "commit-tree" $ pipeWriteRead
ignorehandle $ pipeWriteRead (map Param $ ["commit-tree", show tree] ++ ps)
(map Param $ ["commit-tree", show tree] ++ ps) message repo
message repo
run "update-ref" [Param $ show branch, Param $ show sha] repo run "update-ref" [Param $ show branch, Param $ show sha] repo
return sha return sha
where where
ignorehandle a = snd <$> a
ps = concatMap (\r -> ["-p", show r]) parentrefs ps = concatMap (\r -> ["-p", show r]) parentrefs

View file

@ -7,10 +7,8 @@
module Git.Command where module Git.Command where
import qualified Data.Text.Lazy as L import System.Process
import qualified Data.Text.Lazy.IO as L import System.Posix.Process (getAnyProcessStatus)
import Control.Concurrent
import Control.Exception (finally)
import Common import Common
import Git import Git
@ -44,29 +42,18 @@ run subcommand params repo = assertLocal repo $
-} -}
pipeRead :: [CommandParam] -> Repo -> IO String pipeRead :: [CommandParam] -> Repo -> IO String
pipeRead params repo = assertLocal repo $ do pipeRead params repo = assertLocal repo $ do
(_, h) <- hPipeFrom "git" $ toCommand $ gitCommandLine params repo (_, Just h, _, _) <- createProcess
(proc "git" $ toCommand $ gitCommandLine params repo)
{ std_out = CreatePipe }
fileEncoding h fileEncoding h
hGetContents h hGetContents h
{- Runs a git subcommand, feeding it input. {- Runs a git subcommand, feeding it input, and returning its output,
- You should call either getProcessStatus or forceSuccess on the PipeHandle. -} - which is expected to be fairly small, since it's all read into memory
pipeWrite :: [CommandParam] -> L.Text -> Repo -> IO PipeHandle - strictly. -}
pipeWrite params s repo = assertLocal repo $ do pipeWriteRead :: [CommandParam] -> String -> Repo -> IO String
(p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo) pipeWriteRead params s repo = assertLocal repo $
L.hPutStr h s readProcess "git" (toCommand $ gitCommandLine params repo) s
hClose h
return p
{- Runs a git subcommand, feeding it input, and returning its output.
- You should call either getProcessStatus or forceSuccess on the PipeHandle. -}
pipeWriteRead :: [CommandParam] -> String -> Repo -> IO (PipeHandle, String)
pipeWriteRead params s repo = assertLocal repo $ do
(p, from, to) <- hPipeBoth "git" (toCommand $ gitCommandLine params repo)
fileEncoding to
fileEncoding from
_ <- forkIO $ finally (hPutStr to s) (hClose to)
c <- hGetContents from
return (p, c)
{- Reads null terminated output of a git command (as enabled by the -z {- Reads null terminated output of a git command (as enabled by the -z
- parameter), and splits it. -} - parameter), and splits it. -}

View file

@ -9,6 +9,7 @@ module Git.Config where
import qualified Data.Map as M import qualified Data.Map as M
import Data.Char import Data.Char
import System.Process
import Common import Common
import Git import Git
@ -39,7 +40,7 @@ reRead :: Repo -> IO Repo
reRead = read' reRead = read'
{- Cannot use pipeRead because it relies on the config having been already {- Cannot use pipeRead because it relies on the config having been already
- read. Instead, chdir to the repo. - read. Instead, chdir to the repo and run git config.
-} -}
read' :: Repo -> IO Repo read' :: Repo -> IO Repo
read' repo = go repo read' repo = go repo
@ -47,9 +48,14 @@ read' repo = go repo
go Repo { location = Local { gitdir = d } } = git_config d go Repo { location = Local { gitdir = d } } = git_config d
go Repo { location = LocalUnknown d } = git_config d go Repo { location = LocalUnknown d } = git_config d
go _ = assertLocal repo $ error "internal" go _ = assertLocal repo $ error "internal"
git_config d = bracketCd d $ git_config d = do
pOpen ReadFromPipe "git" ["config", "--null", "--list"] $ (_, Just h, _, pid)
hRead repo <- createProcess (proc "git" params)
{ std_out = CreatePipe, cwd = Just d }
repo' <- hRead repo h
forceSuccessProcess pid "git" params
return repo'
params = ["config", "--null", "--list"]
{- Reads git config from a handle and populates a repo with it. -} {- Reads git config from a handle and populates a repo with it. -}
hRead :: Repo -> Handle -> IO Repo hRead :: Repo -> Handle -> IO Repo

View file

@ -38,11 +38,9 @@ hashFile h file = CoProcess.query h send receive
{- Injects some content into git, returning its Sha. -} {- Injects some content into git, returning its Sha. -}
hashObject :: ObjectType -> String -> Repo -> IO Sha hashObject :: ObjectType -> String -> Repo -> IO Sha
hashObject objtype content repo = getSha subcmd $ do hashObject objtype content repo = getSha subcmd $ do
(h, s) <- pipeWriteRead (map Param params) content repo s <- pipeWriteRead (map Param params) content repo
length s `seq` do reap -- XXX unsure why this is needed, of if it is anymore
forceSuccess h return s
reap -- XXX unsure why this is needed
return s
where where
subcmd = "hash-object" subcmd = "hash-object"
params = [subcmd, "-t", show objtype, "-w", "--stdin"] params = [subcmd, "-t", show objtype, "-w", "--stdin"]

View file

@ -19,7 +19,7 @@ module Git.Queue (
import qualified Data.Map as M import qualified Data.Map as M
import System.IO import System.IO
import System.Cmd.Utils import System.Process
import Data.String.Utils import Data.String.Utils
import Utility.SafeCommand import Utility.SafeCommand
@ -148,11 +148,14 @@ runAction :: Repo -> Action -> IO ()
runAction repo (UpdateIndexAction streamers) = runAction repo (UpdateIndexAction streamers) =
-- list is stored in reverse order -- list is stored in reverse order
Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers
runAction repo action@(CommandAction {}) = runAction repo action@(CommandAction {}) = do
pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs (Just h, _, _, pid) <- createProcess (proc "xargs" params)
{ std_in = CreatePipe }
fileEncoding h
hPutStr h $ join "\0" $ getFiles action
hClose h
forceSuccessProcess pid "xargs" params
where where
params = toCommand $ gitCommandLine params = "-0":"git":baseparams
baseparams = toCommand $ gitCommandLine
(Param (getSubcommand action):getParams action) repo (Param (getSubcommand action):getParams action) repo
feedxargs h = do
fileEncoding h
hPutStr h $ join "\0" $ getFiles action

View file

@ -17,7 +17,7 @@ module Git.UpdateIndex (
stageSymlink stageSymlink
) where ) where
import System.Cmd.Utils import System.Process
import Common import Common
import Git import Git
@ -37,12 +37,13 @@ pureStreamer !s = \streamer -> streamer s
{- Streams content into update-index from a list of Streamers. -} {- Streams content into update-index from a list of Streamers. -}
streamUpdateIndex :: Repo -> [Streamer] -> IO () streamUpdateIndex :: Repo -> [Streamer] -> IO ()
streamUpdateIndex repo as = do streamUpdateIndex repo as = do
(p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo) (Just h, _, _, p) <- createProcess (proc "git" ps) { std_in = CreatePipe }
fileEncoding h fileEncoding h
forM_ as (stream h) forM_ as (stream h)
hClose h hClose h
forceSuccess p forceSuccessProcess p "git" ps
where where
ps = toCommand $ gitCommandLine params repo
params = map Param ["update-index", "-z", "--index-info"] params = map Param ["update-index", "-z", "--index-info"]
stream h a = a (streamer h) stream h a = a (streamer h)
streamer h s = do streamer h s = do

View file

@ -14,7 +14,7 @@ endif
PREFIX=/usr PREFIX=/usr
IGNORE=-ignore-package monads-fd -ignore-package monads-tf IGNORE=-ignore-package monads-fd -ignore-package monads-tf
BASEFLAGS=-Wall $(IGNORE) -outputdir tmp -IUtility -DWITH_ASSISTANT -DWITH_S3 $(BASEFLAGS_OPTS) BASEFLAGS=-threaded -Wall $(IGNORE) -outputdir tmp -IUtility -DWITH_ASSISTANT -DWITH_S3 $(BASEFLAGS_OPTS)
GHCFLAGS=-O2 $(BASEFLAGS) GHCFLAGS=-O2 $(BASEFLAGS)
CFLAGS=-Wall CFLAGS=-Wall

View file

@ -136,9 +136,11 @@ retrieveEncrypted :: BupRepo -> (Cipher, Key) -> Key -> FilePath -> Annex Bool
retrieveEncrypted buprepo (cipher, enck) _ f = do retrieveEncrypted buprepo (cipher, enck) _ f = do
let params = bupParams "join" buprepo [Param $ bupRef enck] let params = bupParams "join" buprepo [Param $ bupRef enck]
liftIO $ catchBoolIO $ do liftIO $ catchBoolIO $ do
(pid, h) <- hPipeFrom "bup" $ toCommand params (_, Just h, _, pid)
<- createProcess (proc "bup" $ toCommand params)
{ std_out = CreatePipe }
withDecryptedContent cipher (L.hGetContents h) $ L.writeFile f withDecryptedContent cipher (L.hGetContents h) $ L.writeFile f
forceSuccess pid forceSuccessProcess pid "bup" $ toCommand params
return True return True
remove :: Key -> Annex Bool remove :: Key -> Annex Bool

View file

@ -9,6 +9,7 @@ module Remote.Git (remote, repoAvail) where
import qualified Data.Map as M import qualified Data.Map as M
import Control.Exception.Extensible import Control.Exception.Extensible
import System.Process
import Common.Annex import Common.Annex
import Utility.CopyFile import Utility.CopyFile
@ -126,17 +127,20 @@ tryGitConfigRead r
safely a = either (const $ return r) return safely a = either (const $ return r) return
=<< liftIO (try a :: IO (Either SomeException Git.Repo)) =<< liftIO (try a :: IO (Either SomeException Git.Repo))
pipedconfig cmd params = safely $ pipedconfig cmd params = safely $ do
pOpen ReadFromPipe cmd (toCommand params) $ (_, Just h, _, pid) <-
Git.Config.hRead r createProcess (proc cmd $ toCommand params)
{ std_out = CreatePipe }
r' <- Git.Config.hRead r h
forceSuccessProcess pid cmd $ toCommand params
return r'
geturlconfig headers = do geturlconfig headers = do
s <- Url.get (Git.repoLocation r ++ "/config") headers s <- Url.get (Git.repoLocation r ++ "/config") headers
withTempFile "git-annex.tmp" $ \tmpfile h -> do withTempFile "git-annex.tmp" $ \tmpfile h -> do
hPutStr h s hPutStr h s
hClose h hClose h
pOpen ReadFromPipe "git" ["config", "--null", "--list", "--file", tmpfile] $ pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile]
Git.Config.hRead r
store = observe $ \r' -> do store = observe $ \r' -> do
g <- gitRepo g <- gitRepo

View file

@ -9,7 +9,6 @@ module Remote.Hook (remote) where
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M import qualified Data.Map as M
import System.Exit
import System.Environment import System.Environment
import Common.Annex import Common.Annex
@ -136,17 +135,5 @@ checkPresent r h k = do
findkey s = show k `elem` lines s findkey s = show k `elem` lines s
check Nothing = error "checkpresent hook misconfigured" check Nothing = error "checkpresent hook misconfigured"
check (Just hook) = do check (Just hook) = do
(frompipe, topipe) <- createPipe env <- hookEnv k Nothing
pid <- forkProcess $ do findkey <$> readProcessEnv "sh" ["-c", hook] env
_ <- dupTo topipe stdOutput
closeFd frompipe
executeFile "sh" True ["-c", hook]
=<< hookEnv k Nothing
closeFd topipe
fromh <- fdToHandle frompipe
reply <- hGetContentsStrict fromh
hClose fromh
s <- getProcessStatus True False pid
case s of
Just (Exited ExitSuccess) -> return $ findkey reply
_ -> error "checkpresent hook failed"

View file

@ -9,6 +9,7 @@ module Remote.Rsync (remote) where
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M import qualified Data.Map as M
import System.Posix.Process (getProcessID)
import Common.Annex import Common.Annex
import Types.Remote import Types.Remote

View file

@ -13,23 +13,25 @@ module Utility.CoProcess (
query query
) where ) where
import System.Cmd.Utils import System.Process
import Common import Common
type CoProcessHandle = (PipeHandle, Handle, Handle) type CoProcessHandle = (ProcessHandle, Handle, Handle, FilePath, [String])
start :: FilePath -> [String] -> IO CoProcessHandle start :: FilePath -> [String] -> IO CoProcessHandle
start command params = hPipeBoth command params start command params = do
(from, to, _err, pid) <- runInteractiveProcess command params Nothing Nothing
return (pid, to, from, command, params)
stop :: CoProcessHandle -> IO () stop :: CoProcessHandle -> IO ()
stop (pid, from, to) = do stop (pid, from, to, command, params) = do
hClose to hClose to
hClose from hClose from
forceSuccess pid forceSuccessProcess pid command params
query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b
query (_, from, to) send receive = do query (_, from, to, _, _) send receive = do
_ <- send to _ <- send to
hFlush to hFlush to
receive from receive from

View file

@ -11,9 +11,9 @@ import qualified Data.ByteString.Lazy as L
import System.Posix.Types import System.Posix.Types
import Control.Applicative import Control.Applicative
import Control.Concurrent import Control.Concurrent
import Control.Exception (finally, bracket) import Control.Exception (bracket)
import System.Exit
import System.Posix.Env (setEnv, unsetEnv, getEnv) import System.Posix.Env (setEnv, unsetEnv, getEnv)
import System.Process
import Common import Common
@ -39,18 +39,30 @@ stdParams params = do
readStrict :: [CommandParam] -> IO String readStrict :: [CommandParam] -> IO String
readStrict params = do readStrict params = do
params' <- stdParams params params' <- stdParams params
pOpen ReadFromPipe "gpg" params' hGetContentsStrict (_, Just from, _, pid)
<- createProcess (proc "gpg" params')
{ std_out = CreatePipe }
hSetBinaryMode from True
r <- hGetContentsStrict from
forceSuccessProcess pid "gpg" params'
return r
{- Runs gpg, piping an input value to it, and returning its stdout, {- Runs gpg, piping an input value to it, and returning its stdout,
- strictly. -} - strictly. -}
pipeStrict :: [CommandParam] -> String -> IO String pipeStrict :: [CommandParam] -> String -> IO String
pipeStrict params input = do pipeStrict params input = do
params' <- stdParams params params' <- stdParams params
(pid, fromh, toh) <- hPipeBoth "gpg" params' (Just to, Just from, _, pid)
_ <- forkIO $ finally (hPutStr toh input) (hClose toh) <- createProcess (proc "gpg" params')
output <- hGetContentsStrict fromh { std_in = CreatePipe
forceSuccess pid , std_out = CreatePipe }
return output hSetBinaryMode to True
hSetBinaryMode from True
hPutStr to input
hClose to
r <- hGetContentsStrict from
forceSuccessProcess pid "gpg" params'
return r
{- Runs gpg with some parameters, first feeding it a passphrase via {- Runs gpg with some parameters, first feeding it a passphrase via
- --passphrase-fd, then feeding it an input, and passing a handle - --passphrase-fd, then feeding it an input, and passing a handle
@ -70,17 +82,14 @@ passphraseHandle params passphrase a b = do
let passphrasefd = [Param "--passphrase-fd", Param $ show pfd] let passphrasefd = [Param "--passphrase-fd", Param $ show pfd]
params' <- stdParams $ passphrasefd ++ params params' <- stdParams $ passphrasefd ++ params
(pid, fromh, toh) <- hPipeBoth "gpg" params' (Just toh, Just fromh, _, pid) <- createProcess (proc "gpg" params')
pid2 <- forkProcess $ do { std_in = CreatePipe, std_out = CreatePipe }
L.hPut toh =<< a L.hPut toh =<< a
hClose toh
exitSuccess
hClose toh hClose toh
ret <- b fromh ret <- b fromh
-- cleanup -- cleanup
forceSuccess pid forceSuccessProcess pid "gpg" params'
_ <- getProcessStatus True False pid2
closeFd frompipe closeFd frompipe
return ret return ret

View file

@ -10,6 +10,7 @@ module Utility.INotify where
import Common hiding (isDirectory) import Common hiding (isDirectory)
import Utility.ThreadLock import Utility.ThreadLock
import Utility.Types.DirWatcher import Utility.Types.DirWatcher
import System.Process
import System.INotify import System.INotify
import qualified System.Posix.Files as Files import qualified System.Posix.Files as Files
@ -160,12 +161,9 @@ tooManyWatches hook dir = do
querySysctl :: Read a => [CommandParam] -> IO (Maybe a) querySysctl :: Read a => [CommandParam] -> IO (Maybe a)
querySysctl ps = do querySysctl ps = do
v <- catchMaybeIO $ hPipeFrom "sysctl" $ toCommand ps v <- catchMaybeIO $ readProcess "sysctl" (toCommand ps) []
case v of case v of
Nothing -> return Nothing Nothing -> return Nothing
Just (pid, h) -> do Just s -> return $ parsesysctl s
val <- parsesysctl <$> hGetContentsStrict h
void $ getProcessStatus True False $ processID pid
return val
where where
parsesysctl s = readish =<< lastMaybe (words s) parsesysctl s = readish =<< lastMaybe (words s)

View file

@ -12,6 +12,7 @@ module Utility.Lsof where
import Common import Common
import System.Posix.Types import System.Posix.Types
import System.Process
data LsofOpenMode = OpenReadWrite | OpenReadOnly | OpenWriteOnly | OpenUnknown data LsofOpenMode = OpenReadWrite | OpenReadOnly | OpenWriteOnly | OpenUnknown
deriving (Show, Eq) deriving (Show, Eq)
@ -34,10 +35,8 @@ queryDir path = query ["+d", path]
-} -}
query :: [String] -> IO [(FilePath, LsofOpenMode, ProcessInfo)] query :: [String] -> IO [(FilePath, LsofOpenMode, ProcessInfo)]
query opts = do query opts = do
(pid, s) <- pipeFrom "lsof" ("-F0can" : opts) (_, s, _) <- readProcessWithExitCode "lsof" ("-F0can" : opts) []
let !r = parse s return $ parse s
void $ getProcessStatus True False $ processID pid
return r
{- Parsing null-delimited output like: {- Parsing null-delimited output like:
- -

View file

@ -33,7 +33,7 @@ separate c l = unbreak $ break c l
| otherwise = (a, tail b) | otherwise = (a, tail b)
{- Breaks out the first line. -} {- Breaks out the first line. -}
firstLine :: String-> String firstLine :: String -> String
firstLine = takeWhile (/= '\n') firstLine = takeWhile (/= '\n')
{- Splits a list into segments that are delimited by items matching {- Splits a list into segments that are delimited by items matching

40
Utility/Process.hs Normal file
View file

@ -0,0 +1,40 @@
{- System.Process enhancements
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Utility.Process where
import System.Process
import System.Exit
import System.IO
import Utility.Misc
{- Waits for a ProcessHandle, and throws an exception if the process
- did not exit successfully. -}
forceSuccessProcess :: ProcessHandle -> String -> [String] -> IO ()
forceSuccessProcess pid cmd args = do
code <- waitForProcess pid
case code of
ExitSuccess -> return ()
ExitFailure n -> error $
cmd ++ " " ++ show args ++ " exited " ++ show n
{- Like readProcess, but allows specifying the environment, and does
- not mess with stdin. -}
readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String
readProcessEnv cmd args environ = do
(_, Just h, _, pid)
<- createProcess (proc cmd args)
{ std_in = Inherit
, std_out = CreatePipe
, std_err = Inherit
, env = environ
}
output <- hGetContentsStrict h
hClose h
forceSuccessProcess pid cmd args
return output

View file

@ -1,6 +1,6 @@
{- safely running shell commands {- safely running shell commands
- -
- Copyright 2010-2011 Joey Hess <joey@kitenet.net> - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -8,11 +8,8 @@
module Utility.SafeCommand where module Utility.SafeCommand where
import System.Exit import System.Exit
import qualified System.Posix.Process import System.Process
import System.Posix.Process hiding (executeFile)
import System.Posix.Signals
import Data.String.Utils import Data.String.Utils
import System.Log.Logger
import Control.Applicative import Control.Applicative
{- A type for parameters passed to a shell command. A command can {- A type for parameters passed to a shell command. A command can
@ -42,7 +39,7 @@ boolSystem :: FilePath -> [CommandParam] -> IO Bool
boolSystem command params = boolSystemEnv command params Nothing boolSystem command params = boolSystemEnv command params Nothing
boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
boolSystemEnv command params env = dispatch <$> safeSystemEnv command params env boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ
where where
dispatch ExitSuccess = True dispatch ExitSuccess = True
dispatch _ = False dispatch _ = False
@ -51,36 +48,13 @@ boolSystemEnv command params env = dispatch <$> safeSystemEnv command params env
safeSystem :: FilePath -> [CommandParam] -> IO ExitCode safeSystem :: FilePath -> [CommandParam] -> IO ExitCode
safeSystem command params = safeSystemEnv command params Nothing safeSystem command params = safeSystemEnv command params Nothing
{- SIGINT(ctrl-c) is allowed to propigate and will terminate the program. -} {- Unlike many implementations of system, SIGINT(ctrl-c) is allowed
- to propigate and will terminate the program. -}
safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode
safeSystemEnv command params env = do safeSystemEnv command params environ = do
-- Going low-level because all the high-level system functions (_, _, _, pid) <- createProcess (proc command $ toCommand params)
-- block SIGINT etc. We need to block SIGCHLD, but allow { env = environ }
-- SIGINT to do its default program termination. waitForProcess pid
let sigset = addSignal sigCHLD emptySignalSet
oldint <- installHandler sigINT Default Nothing
oldset <- getSignalMask
blockSignals sigset
childpid <- forkProcess $ childaction oldint oldset
mps <- getProcessStatus True False childpid
restoresignals oldint oldset
case mps of
Just (Exited code) -> return code
_ -> error $ "unknown error running " ++ command
where
restoresignals oldint oldset = do
_ <- installHandler sigINT oldint Nothing
setSignalMask oldset
childaction oldint oldset = do
restoresignals oldint oldset
executeFile command True (toCommand params) env
{- executeFile with debug logging -}
executeFile :: FilePath -> Bool -> [String] -> Maybe [(String, String)] -> IO ()
executeFile c path p e = do
debugM "Utility.SafeCommand.executeFile" $
"Running: " ++ c ++ " " ++ show p ++ " " ++ maybe "" show e
System.Posix.Process.executeFile c path p e
{- Escapes a filename or other parameter to be safely able to be exposed to {- Escapes a filename or other parameter to be safely able to be exposed to
- the shell. -} - the shell. -}

View file

@ -9,7 +9,7 @@ module Utility.TempFile where
import Control.Exception (bracket) import Control.Exception (bracket)
import System.IO import System.IO
import System.Posix.Process hiding (executeFile) import System.Posix.Process
import System.Directory import System.Directory
import Utility.Exception import Utility.Exception

View file

@ -0,0 +1,64 @@
Back home and laptop is fixed.. back to work.
Warmup exercises:
* Went in to make it queue transfers when a broken symlink is received,
only to find I'd already written code to do that, and forgotten about it.
Heh. Did check that the git-annex branch is always sent first,
which will ensure that code always knows where to transfer a key from.
I had probably not considered this wrinkle when first writing the code;
it worked by accident.
* Made the assistant check that a remote is known to have a key before
queueing a download from it.
* Fixed a bad interaction between the `git annex map` command and the
assistant.
----
Tried using a modified version of `MissingH` that doesn't use `HSLogger`
to make git-annex work with the threaded GHC runtime. Unfortunatly,
I am still seeing hangs in at least 3 separate code paths when
running the test suite. I may have managed to fix one of the hangs,
but have not grokked what's causing the others.
----
I now have access to a Mac OSX system, thanks to Kevin M. I've fixed
some portability problems in git-annex with it before, but today I tested
the assistant on it:
* Found a problem with the kqueue code that prevents incoming pushes from
being noticed.
The problem was that the newly added git ref file does not trigger an add
event. The kqueue code saw a generic change event for the refs directory,
but since the old file was being deleted and replaced by the new file,
the kqueue code, which already had the old file in its cache, did not notice
the file had been replaced.
I fixed that by making the kqueue code also track the inode of each file.
Currently that adds the overhead of a stat of each file, which could be
avoided if haskell exposed the inode returned by `readdir`. Room to
optimise this later...
* Also noticed that the kqueue code was not separating out file deletions
from directory deletions. IIRC Jimmy had once mentioned a problem with file
deletions not being noticed by the assistant, and this could be responsible
for that, although the directory deletion code seems to handle them ok
normally. It was making the transfer watching thread not notice when
any transfers finished, for sure. I fixed this oversight, looking in the
cache to see if there used to be a file or a directory, and running the
appropriate hook.
Even with these fixes, the assistant does not yet reliably transfer file
contents on OSX. I think the problem is that with kqueue we're not
guaranteed to get an add event, and a deletion event for a transfer
info file -- if it's created and quickly deleted, the code that
synthensizes those events doesn't run in time to know it existed.
Since the transfer code relies on deletion events to tell when transfers
are complete, it stops sending files after the first transfer, if the
transfer ran so quickly it doesn't get the expected events.
So, will need to work on OSX support some more...

View file

@ -10,6 +10,13 @@ all the other git clones, at both the git level and the key/value level.
on remotes, and transfer. But first, need to ensure that when a remote on remotes, and transfer. But first, need to ensure that when a remote
receives content, and updates its location log, it syncs that update receives content, and updates its location log, it syncs that update
out. out.
* Transfer watching has a race on kqueue systems, which makes finished
fast transfers not be noticed by the TransferWatcher. Which in turn
prevents the transfer slot being freed and any further transfers
from happening. So, this approach is too fragile to rely on for
maintaining the TransferSlots. Instead, need [[todo/assistant_threaded_runtime]],
which would allow running something for sure when a transfer thread
finishes.
## longer-term TODO ## longer-term TODO

View file

@ -20,6 +20,12 @@ The test suite tends to hang when testing add. `git-annex` occasionally
hangs, apparently in a futex lock. This is not the assistant hanging, and hangs, apparently in a futex lock. This is not the assistant hanging, and
git-annex does not otherwise use threads, so this is surprising. --[[Joey]] git-annex does not otherwise use threads, so this is surprising. --[[Joey]]
> I've spent a lot of time debugging this, and trying to fix it, in the
> "threaded" branch. There are still deadlocks. --[[Joey]]
>> Fixed, by switching from `System.Cmd.Utils` to `System.Process`
>> --[[Joey]]
--- ---
It would be possible to not use the threaded runtime. Instead, we could It would be possible to not use the threaded runtime. Instead, we could

View file

@ -1,5 +1,5 @@
Name: git-annex Name: git-annex
Version: 3.20120629 Version: 3.20120630
Cabal-Version: >= 1.8 Cabal-Version: >= 1.8
License: GPL License: GPL
Maintainer: Joey Hess <joey@kitenet.net> Maintainer: Joey Hess <joey@kitenet.net>
@ -40,11 +40,12 @@ Executable git-annex
unix, containers, utf8-string, network, mtl, bytestring, old-locale, time, unix, containers, utf8-string, network, mtl, bytestring, old-locale, time,
pcre-light, extensible-exceptions, dataenc, SHA, process, json, HTTP, pcre-light, extensible-exceptions, dataenc, SHA, process, json, HTTP,
base == 4.5.*, monad-control, transformers-base, lifted-base, base == 4.5.*, monad-control, transformers-base, lifted-base,
IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, process
-- Need to list this because it's generated from a .hsc file. -- Need to list this because it's generated from a .hsc file.
Other-Modules: Utility.Touch Other-Modules: Utility.Touch
C-Sources: Utility/libdiskfree.c C-Sources: Utility/libdiskfree.c
Extensions: CPP Extensions: CPP
GHC-Options: -threaded
if flag(S3) if flag(S3)
Build-Depends: hS3 Build-Depends: hS3
@ -65,10 +66,11 @@ Test-Suite test
unix, containers, utf8-string, network, mtl, bytestring, old-locale, time, unix, containers, utf8-string, network, mtl, bytestring, old-locale, time,
pcre-light, extensible-exceptions, dataenc, SHA, process, json, HTTP, pcre-light, extensible-exceptions, dataenc, SHA, process, json, HTTP,
base == 4.5.*, monad-control, transformers-base, lifted-base, base == 4.5.*, monad-control, transformers-base, lifted-base,
IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, process
Other-Modules: Utility.Touch Other-Modules: Utility.Touch
C-Sources: Utility/libdiskfree.c C-Sources: Utility/libdiskfree.c
Extensions: CPP Extensions: CPP
GHC-Options: -threaded
source-repository head source-repository head
type: git type: git

View file

@ -14,6 +14,7 @@ import Test.QuickCheck
import System.Posix.Directory (changeWorkingDirectory) import System.Posix.Directory (changeWorkingDirectory)
import System.Posix.Files import System.Posix.Files
import System.Posix.Env import System.Posix.Env
import System.Posix.Process
import Control.Exception.Extensible import Control.Exception.Extensible
import qualified Data.Map as M import qualified Data.Map as M
import System.IO.HVFS (SystemFS(..)) import System.IO.HVFS (SystemFS(..))