Merge branch 'threaded' into assistant
This commit is contained in:
commit
f2ed3d6c8e
31 changed files with 262 additions and 158 deletions
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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" [] []
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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] "")
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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. -}
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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"]
|
||||||
|
|
17
Git/Queue.hs
17
Git/Queue.hs
|
@ -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
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
2
Makefile
2
Makefile
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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"
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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:
|
||||||
-
|
-
|
||||||
|
|
|
@ -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
40
Utility/Process.hs
Normal 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
|
|
@ -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. -}
|
||||||
|
|
|
@ -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
|
||||||
|
|
64
doc/design/assistant/blog/day_37__back.mdwn
Normal file
64
doc/design/assistant/blog/day_37__back.mdwn
Normal 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...
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
1
test.hs
1
test.hs
|
@ -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(..))
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue