Bug in IO libraries when sending data through a pipe?

[Volker Wysk]

On Mon, 11 Mar 2002, Simon Marlow wrote:

> > There seems to be a bug in the IO libraries. I'm using the following
> > procedure to call an external program and send it data through a pipe.
>
> Could you send us a complete example that we can run to reproduce the
> problem?

I've stripped down my program to produce an example. In the process, the
problem disappeard a few times. I hope it shows up on your machine. The
attached files reproduce it on my machine, but the exact results vary
from run to run.

Volker
-------------- next part --------------
import System
import List
import Posix
import PosixUtil
import IO


main = do
    qinh <- getContents
    let pfade = zeilen qinh
    mapM_ (\pfad -> run "/bin/echo" [pfad]) pfade
    hPutStrLn stderr ("received: " ++ show (length qinh))


run :: FilePath                    -- Command
    -> [String]                    -- Arguments
    -> IO ()
run prog par =
    callIO (\ps -> "Kommando fehlgeschlagen mit " ++ show ps ++ ":\n" ++ kommando prog par)
           (executeFile' prog True par Nothing)


-- Die gegebene Aktion als neuen Proze? ausf?hren. Kind wegforken und auf
-- dessen Beendigung warten. Sein Ergebnis ?berwachen und bei Fehler mit
-- Meldung abbrechen. Der erste Parameter ist eine Funktion, die aus einem
-- ExitStatus eine Fehlermeldung generiert. Sie wird nur mit (Exited
-- (ExitFailure _)) oder (Terminated _) aufgerufen.
callIO :: (ProcessStatus -> String)               -- Fehlermeldung erzeugen
       -> IO ()                                   -- Kindproze?
       -> IO ()
callIO fm io = do
    maybepid <- forkProcess
    case maybepid of
       Nothing ->                                 -- Kind
           io >> exitWith ExitSuccess
       Just pid -> do                             -- Vater
           (Just ps) <- getProcessStatus True True pid   -- auf angehaltenes Kind warten
           if ps == Exited ExitSuccess
               then return ()
               else failIO (fm ps)


zeilen :: String -> [String]
zeilen txt =
    let gruppen = groupBy (\a b -> (a == '\n') == (b == '\n')) txt
    in  filter (\str -> filter (/= '\n') str /= "") gruppen


kommando :: String -> [String] -> String
kommando k par =
    concat (intersperse " " (map shell_quote (k:par)))




executeFile' :: FilePath                   -- Command
             -> Bool                       -- Search PATH?
             -> [String]                   -- Arguments
             -> Maybe [(String, String)]   -- Environment
             -> IO a
executeFile' cmd args env ca = do
    executeFile cmd args env ca
    hPutStrLn stderr ("Kommando " ++ cmd ++ " nicht gefunden")
    exitFailure




failIO :: String -> IO a
failIO meld = do
   hPutStrLn stderr meld
   exitFailure


shell_quote :: String -> String
shell_quote txt =
   let need_to_quote c = c `elem` "' \t\n\"\\|&;()<>!{}*[?]^$`#"
       quote (z:zs) =
          if (z `elem` "\"$`\\") then ('\\':(z:(quote zs)))
                                 else (z:(quote zs))
       quote "" = "\""
   in if any need_to_quote txt
         then '"' : quote txt
         else txt
-------------- next part --------------
0 :: parent child
	./parent > /dev/null

parent : parent.hs
	ghc -O -o parent parent.hs  -package posix -package util -package std -syslib lang

child : child.hs
	ghc -O -o child child.hs  -package posix -package util -package std -syslib lang

clean ::
	rm -f *.o *~ parent child *.hi
-------------- next part --------------
import System
import List
import Posix
import PosixUtil
import IO

main = do
   pipeto senden "./child" []
   hPutStrLn stderr ("sent: " ++ show (length senden))

senden = concat (take 200 (repeat "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n"))


pipeto :: String
       -> String
       -> [String]
       -> IO ()
pipeto eing prog par = do
    catch (do (zu, von) <- createPipe	                              -- Pipe von --> zu erzeugen
              vonh <- fdToHandle von                                  -- F?r von brauchen wir einen Handle
              hSetBuffering vonh NoBuffering                          -- nichts zur?ckhalten, wenn der Kindproze? es lesen will
              mpid <- forkProcess                                     -- fork(). Danach hat die Pipe vier offene Enden.
              case mpid of
                 Nothing -> do                                        -- Kind
                    hClose vonh                                       -- Kind-Schreibende schlie?en
                    dupTo zu (intToFd 0)                              -- Kind-Leseende auf die Standardeingabe kopieren
                    fdClose zu                                        -- erstes Kind-Leseende schlie?en
                    executeFile' prog True par Nothing
                 Just pid -> do                                       -- Vater
                    fdClose zu                                        -- Vater-Leseende schlie?en
                    hPutStr vonh eing                                 -- Text druch die R?hre (verz?gert)
                    hClose vonh                                       -- Vater-Schreibende schlie?en
                    (Just ps) <- getProcessStatus True True pid       -- auf angehaltenes Kind warten
                    if ps == Exited ExitSuccess
                        then return ()
                        else failIO ("Kommando fehlgeschlagen mit " ++ show ps ++ ":\n"
                                     ++ kommando prog par)
          )
          (\err -> do errno <- getErrorCode
                      hPutStrLn stderr ("Aufruf fehlgeschlagen: ... | " ++ kommando prog par
                                        ++ "\nerrno = " ++ show errno)
                      ioError err)



executeFile' :: FilePath                   -- Command
             -> Bool                       -- Search PATH?
             -> [String]                   -- Arguments
             -> Maybe [(String, String)]   -- Environment
             -> IO a
executeFile' cmd args env ca = do
    executeFile cmd args env ca
    hPutStrLn stderr ("Kommando " ++ cmd ++ " nicht gefunden")
    exitFailure




failIO :: String -> IO a
failIO meld = do
   hPutStrLn stderr meld
   exitFailure


kommando :: String -> [String] -> String
kommando k par =
    concat (intersperse " " (map shell_quote (k:par)))



shell_quote :: String -> String
shell_quote txt =
   let need_to_quote c = c `elem` "' \t\n\"\\|&;()<>!{}*[?]^$`#"
       quote (z:zs) =
          if (z `elem` "\"$`\\") then ('\\':(z:(quote zs)))
                                 else (z:(quote zs))
       quote "" = "\""
   in if any need_to_quote txt
         then '"' : quote txt
         else txt