more debugging
This commit is contained in:
parent
182526ff68
commit
05310538ef
5 changed files with 25 additions and 4 deletions
|
@ -164,7 +164,9 @@ get' staleok file = fromcache =<< getCache file
|
||||||
fromjournal Nothing
|
fromjournal Nothing
|
||||||
| staleok = withIndex frombranch
|
| staleok = withIndex frombranch
|
||||||
| otherwise = withIndexUpdate $ frombranch >>= cache
|
| otherwise = withIndexUpdate $ frombranch >>= cache
|
||||||
frombranch = L.unpack <$> catFile fullname file
|
frombranch = do
|
||||||
|
liftIO $ putStrLn $ "frombranch " ++ file
|
||||||
|
L.unpack <$> catFile fullname file
|
||||||
cache content = do
|
cache content = do
|
||||||
setCache file content
|
setCache file content
|
||||||
return content
|
return content
|
||||||
|
|
|
@ -50,11 +50,16 @@ catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha))
|
||||||
catObjectDetails h object = CoProcess.query h send receive
|
catObjectDetails h object = CoProcess.query h send receive
|
||||||
where
|
where
|
||||||
send to = do
|
send to = do
|
||||||
|
putStrLn "catObjectDetails send start"
|
||||||
fileEncoding to
|
fileEncoding to
|
||||||
hPutStrLn to $ show object
|
hPutStrLn to $ show object
|
||||||
|
putStrLn $ "catObjectDetails send done " ++ show object
|
||||||
receive from = do
|
receive from = do
|
||||||
|
putStrLn "catObjectDetails read header start"
|
||||||
fileEncoding from
|
fileEncoding from
|
||||||
|
putStrLn "catObjectDetails read header start2"
|
||||||
header <- hGetLine from
|
header <- hGetLine from
|
||||||
|
putStrLn "catObjectDetails read header done"
|
||||||
case words header of
|
case words header of
|
||||||
[sha, objtype, size]
|
[sha, objtype, size]
|
||||||
| length sha == shaSize &&
|
| length sha == shaSize &&
|
||||||
|
@ -67,9 +72,14 @@ catObjectDetails h object = CoProcess.query h send receive
|
||||||
| header == show object ++ " missing" -> dne
|
| header == show object ++ " missing" -> dne
|
||||||
| otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)
|
| otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)
|
||||||
readcontent bytes from sha = do
|
readcontent bytes from sha = do
|
||||||
|
putStrLn "readcontent start"
|
||||||
content <- S.hGet from bytes
|
content <- S.hGet from bytes
|
||||||
|
putStrLn "readcontent end"
|
||||||
c <- hGetChar from
|
c <- hGetChar from
|
||||||
|
putStrLn "readcontent newline read"
|
||||||
when (c /= '\n') $
|
when (c /= '\n') $
|
||||||
error "missing newline from git cat-file"
|
error "missing newline from git cat-file"
|
||||||
return $ Just (L.fromChunks [content], Ref sha)
|
return $ Just (L.fromChunks [content], Ref sha)
|
||||||
dne = return Nothing
|
dne = do
|
||||||
|
putStrLn "dne"
|
||||||
|
return Nothing
|
||||||
|
|
|
@ -44,11 +44,15 @@ checkAttr (h, attrs, cwd) want file = do
|
||||||
_ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file
|
_ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file
|
||||||
where
|
where
|
||||||
send to = do
|
send to = do
|
||||||
|
putStrLn "checkAttr send start"
|
||||||
fileEncoding to
|
fileEncoding to
|
||||||
hPutStr to $ file' ++ "\0"
|
hPutStr to $ file' ++ "\0"
|
||||||
|
putStrLn "checkAttr send end"
|
||||||
receive from = forM attrs $ \attr -> do
|
receive from = forM attrs $ \attr -> do
|
||||||
|
putStrLn "checkAttr receive start"
|
||||||
fileEncoding from
|
fileEncoding from
|
||||||
l <- hGetLine from
|
l <- hGetLine from
|
||||||
|
putStrLn "checkAttr receive end"
|
||||||
return (attr, attrvalue attr l)
|
return (attr, attrvalue attr l)
|
||||||
{- Before git 1.7.7, git check-attr worked best with
|
{- Before git 1.7.7, git check-attr worked best with
|
||||||
- absolute filenames; using them worked around some bugs
|
- absolute filenames; using them worked around some bugs
|
||||||
|
|
|
@ -501,7 +501,7 @@ pOpen3 :: Maybe Fd -- ^ Send stdin to this fd
|
||||||
-> (ProcessID -> IO a) -- ^ Action to run in parent
|
-> (ProcessID -> IO a) -- ^ Action to run in parent
|
||||||
-> IO () -- ^ Action to run in child before execing (if you don't need something, set this to @return ()@) -- IGNORED IN HUGS
|
-> IO () -- ^ Action to run in child before execing (if you don't need something, set this to @return ()@) -- IGNORED IN HUGS
|
||||||
-> IO a
|
-> IO a
|
||||||
pOpen3 pin pout perr fp args func childfunc = ddd "pOpen3" $
|
pOpen3 pin pout perr fp args func childfunc = ddd (show ("pOpen3", fp, args)) $
|
||||||
do pid <- pOpen3Raw pin pout perr fp args childfunc
|
do pid <- pOpen3Raw pin pout perr fp args childfunc
|
||||||
putStrLn "got pid"
|
putStrLn "got pid"
|
||||||
retval <- func $! pid
|
retval <- func $! pid
|
||||||
|
|
|
@ -54,6 +54,7 @@ safeSystem command params = safeSystemEnv command params Nothing
|
||||||
{- SIGINT(ctrl-c) is allowed to propigate and will terminate the program. -}
|
{- 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 env = do
|
||||||
|
putStrLn "safeSystemEnv start"
|
||||||
-- Going low-level because all the high-level system functions
|
-- Going low-level because all the high-level system functions
|
||||||
-- block SIGINT etc. We need to block SIGCHLD, but allow
|
-- block SIGINT etc. We need to block SIGCHLD, but allow
|
||||||
-- SIGINT to do its default program termination.
|
-- SIGINT to do its default program termination.
|
||||||
|
@ -65,7 +66,9 @@ safeSystemEnv command params env = do
|
||||||
mps <- getProcessStatus True False childpid
|
mps <- getProcessStatus True False childpid
|
||||||
restoresignals oldint oldset
|
restoresignals oldint oldset
|
||||||
case mps of
|
case mps of
|
||||||
Just (Exited code) -> return code
|
Just (Exited code) -> do
|
||||||
|
putStrLn "safeSystemEnv end"
|
||||||
|
return code
|
||||||
_ -> error $ "unknown error running " ++ command
|
_ -> error $ "unknown error running " ++ command
|
||||||
where
|
where
|
||||||
restoresignals oldint oldset = do
|
restoresignals oldint oldset = do
|
||||||
|
@ -78,9 +81,11 @@ safeSystemEnv command params env = do
|
||||||
{- executeFile with debug logging -}
|
{- executeFile with debug logging -}
|
||||||
executeFile :: FilePath -> Bool -> [String] -> Maybe [(String, String)] -> IO ()
|
executeFile :: FilePath -> Bool -> [String] -> Maybe [(String, String)] -> IO ()
|
||||||
executeFile c path p e = do
|
executeFile c path p e = do
|
||||||
|
putStrLn "executeFile start"
|
||||||
--debugM "Utility.SafeCommand.executeFile" $
|
--debugM "Utility.SafeCommand.executeFile" $
|
||||||
-- "Running: " ++ c ++ " " ++ show p ++ " " ++ maybe "" show e
|
-- "Running: " ++ c ++ " " ++ show p ++ " " ++ maybe "" show e
|
||||||
System.Posix.Process.executeFile c path p e
|
System.Posix.Process.executeFile c path p e
|
||||||
|
putStrLn "executeFile end"
|
||||||
|
|
||||||
{- 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. -}
|
||||||
|
|
Loading…
Reference in a new issue