Socket code dies with SIGPIPE

GHC socket / IO handle code dies with SIGPIPE.

Debian Etch

$ uname -a
Linux alien 2.6.19.1y #7 Mon Dec 25 20:48:36 EET 2006 i686 GNU/Linux

$ cat /etc/debian_version 
4.0

$ ghc --version
The Glorious Glasgow Haskell Compilation System, version 6.6

Test program and strace output are here:

http://linux.ee/~mzz/ghcpipebug/

run: tttd
	strace ./tttd &
	sleep 1
	echo -n | nc -q 0 127.0.0.1 3372; echo -n | nc -q 0 127.0.0.1 3372
	sleep 1

tttd: tttd.hs
	ghc -o $@ $+ -package network

clean:
	rm -f tttd *.hi *.o

import Control.Concurrent
import Network
import System.IO

-- it won't SIGPIPE, when you comment second hPrint
player h hOther otherTh = evil >> hClose h
    where evil = hPrint h 13 >> hPrint h 42

doAccept sock =
     do (h1, _, _) <- accept sock
        (h2, _, _) <- accept sock
        hSetBuffering h1 LineBuffering
        hSetBuffering h2 LineBuffering
        forkIO $ myThreadId >>= forkIO . player h2 h1 >>= player h1 h2
        threadDelay 500000
        hPutStrLn stderr "OK?"

main = withSocketsDo $ listenOn (PortNumber $ fromIntegral 3372) >>= doAccept

select(0, [], [], NULL, {0, 0})         = 0 (Timeout)
write(4, "13\n", 3)                     = 3
gettimeofday({1169512958, 393628}, NULL) = 0
select(0, [], [], NULL, {0, 0})         = 0 (Timeout)
write(5, "13\n", 3)                     = 3
write(5, "42\n", 3)                     = 3
close(5)                                = 0
gettimeofday({1169512958, 393914}, NULL) = 0
select(0, [], [], NULL, {0, 0})         = 0 (Timeout)
write(4, "42\n", 3)                     = -1 EPIPE (Broken pipe)
--- SIGPIPE (Broken pipe) @ 0 (0) ---
+++ killed by SIGPIPE +++
Process 3541 detached

Trac metadata

Trac field	Value
Version	6.6
Type	Bug
TypeOfFailure	OtherFailure
Priority	normal
Resolution	Unresolved
Component	hslibs/net
Test case
Differential revisions
BlockedBy
Related
Blocking
CC
Operating system
Architecture