import IO
import Control.Exception hiding (catch)
import Control.Concurrent
import Network
import System.Posix
main = withSocketsDo (installHandler sigPIPE Ignore Nothing >> main')
main' = listenOn (PortNumber 9900) >>= acceptConnections
acceptConnections sock = do
putStrLn "trying to accept" -- debug msg
conn@(h,host,port) <- accept sock
print conn -- debug msg
forkIO $ catch (talk conn `finally` hClose h) (\e -> print e)
acceptConnections sock
talk conn@(h,_,_) = hGetLine h >>= hPutStrLn h >> hFlush h >> talk conn
kyagrd@kyagrd:hsserv$ ./echo.bin
trying to accept
({handle: <socket: 4>},"220.85.155.11",49223)
trying to accept
<socket: 4>: hGetLine: end of file
kyagrd@kyagrd:kyagrd$ telnet kyagrd.dyndns.org 9900 Trying 220.85.155.11... Connected to kyagrd.dyndns.org. Escape character is '^]'. abcd abcd asdf1234 asdf1234 ^] telnet> quit Connection closed. kyagrd@kyagrd:kyagrd$
import IO
import Control.Exception hiding (catch)
import Control.Concurrent
import Network
import System.Posix
import List
import Monad
main = withSocketsDo (installHandler sigPIPE Ignore Nothing >> main')
main' = do
sock <- listenOn (PortNumber 9901)
mvH <- newMVar [] -- list of client handles
mvM <- newMVar [] -- messags stack ... not queue :)
mvS <- newEmptyMVar -- semaphore
let mvt = (mvH,mvM,mvS)
forkIO $ broadcast mvt `finally` putMVar mvS ()
acceptConnections sock mvt
acceptConnections sock mvt@(mvH,mvM,_ ) = do
print "trying to accept" -- for debugging message
conn@(h,host,port) <- accept sock
print conn -- for debugging message
modifyMVar_ mvH (return . (h:))
forkIO $ catch (talk conn mvt `finally` closeConn h mvH) print
acceptConnections sock mvt
talk conn@(h,host,port) mvt@(_ ,mvM,mvS) =
hGetLine h >>= stackMsg >> talk conn mvt
where stackMsg m = do
modifyMVar_ mvM (return . ((show (host,port)++':':m):))
tryPutMVar mvS () -- V
closeConn h mvH = modifyMVar_ mvH (return . delete h) >> hClose h
broadcast mvt@(mvH,mvM,mvS) = do
takeMVar mvS -- P
ms <- swapMVar mvM []
mapM_ (\m ->mapM_ (failSafe(\h->hPutStrLn h m>>hFlush h))=<<readMVar mvH) ms
broadcast mvt
where failSafe ioWithHarg h = catch (ioWithHarg h) print
kyagrd@kyagrd:hsserv$ ./chat.bin
"trying to accept"
({handle: <socket: 4>},"220.85.155.11",49500)
"trying to accept"
<socket: 4>: hGetLine: end of file
kyagrd@kyagrd:kyagrd$ telnet kyagrd.dyndns.org 9901
Trying 220.85.155.11...
Connected to kyagrd.dyndns.org.
Escape character is '^]'.
asdf
("220.85.155.11",49500):asdf
asdf1234
("220.85.155.11",49500):asdf1234
^]
telnet> quit
Connection closed.
kyagrd@kyagrd:kyagrd$
hsserv.tar.gz (1.05 KB)
kyagrd@kyagrd:hsserv$ ls
chat.hs echo.hs makefile
kyagrd@kyagrd:hsserv$ ghc --version
The Glorious Glasgow Haskell Compilation System, version 6.2.1
kyagrd@kyagrd:hsserv$ make
ghc --make echo.hs -o echo.bin -package network -package posix
Chasing modules from: echo.hs
Compiling Main ( echo.hs, echo.o )
Linking ...
ghc --make chat.hs -o chat.bin -package network -package posix
Chasing modules from: chat.hs
Compiling Main ( chat.hs, chat.o )
Linking ...
kyagrd@kyagrd:hsserv$ ls
chat.bin* chat.hs echo.bin* echo.hs makefile
chat.hi chat.o echo.hi echo.o
kyagrd@kyagrd:hsserv$ ./echo.bin
trying to accept
echo.bin: internal error: main thread has been GC'd
Please report this as a bug to glasgow-haskell-bugs@haskell.org,
or http://www.sourceforge.net/projects/ghc/
kyagrd@kyagrd:hsserv$ ./chat.bin
"trying to accept"
chat.bin: internal error: main thread has been GC'd
Please report this as a bug to glasgow-haskell-bugs@haskell.org,
or http://www.sourceforge.net/projects/ghc/
kyagrd@kyagrd:hsserv$ make clean
rm -f echo.bin chat.bin *.hi *.o
kyagrd@kyagrd:hsserv$ ls
chat.hs echo.hs makefile
The error internal error message comes out when pressing Ctrl-C.
You may add comments here.