net002.hs 3.84 KB
Newer Older
sof's avatar
sof committed
1
-- $Id: net002.hs,v 1.3 2002/07/23 17:11:52 sof Exp $
2
3
4
5
6
7
8
9
10
-- http://www.bagley.org/~doug/shootout/
-- Haskell echo/client server
-- written by Brian Gregor
-- compile with:
-- ghc -O -o echo -package net -package concurrent -package lang echo.hs
    
-- !!! exposed a bug in 5.02.2's network library, accept wasn't setting the
-- socket it returned to non-blocking mode.

sof's avatar
sof committed
11
12
13
14
15
16
17
-- NOTE: this test depends on non-blocking I/O support,
-- which win32 doesn't support. Rather than having the
-- test program block, we fail to initialise WinSock
-- (via withSocketsDo) here so that the test will fall over
-- (and repeatedly remind us to implement Win32 support
-- for non-blocking I/O !)

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
module Main where

import SocketPrim

import System.IO
import Control.Concurrent
import System.Environment 	( getArgs )
import System.Exit 		( exitFailure )
import Control.Exception 	( finally )

server_sock :: IO (Socket)
server_sock = do
    s <- socket AF_INET Stream 6
    setSocketOption s ReuseAddr 1
    -- bindSocket s (SockAddrInet (mkPortNumber portnum) iNADDR_ANY)
    bindSocket s (SockAddrInet (PortNum portnum) iNADDR_ANY)
    listen s 2
    return s

sof's avatar
sof committed
37
38
39
40
41
eofAsEmptyHandler :: IOError -> IO String
eofAsEmptyHandler e
 | isEOFError e = return ""
 | otherwise    = ioError e

42
43
44
45
46
47
48
49
echo_server s = do
    (s', clientAddr) <- accept s
    proc <- read_data s' 0
    putStrLn ("server processed "++(show proc)++" bytes")
    sClose s'
    where
        read_data sock totalbytes = do
            -- (str,i) <- readSocket sock 19
sof's avatar
sof committed
50
            str <- recv sock 19 `catch` eofAsEmptyHandler
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
            -- if (i >= 19) 
            putStr ("Server recv: " ++ str)
            if ((length str) >= 19) 
                then do
                    putStr ("Server read: " ++ str)
                    -- writ <- writeSocket sock str
                    writ <- send sock str
                    putStr ("Server wrote: " ++ str)
                    --
                    read_data sock $! (totalbytes+(length $! str))
                    -- read_data sock (totalbytes+(length str))
                else do
                    putStr ("server read: " ++ str)
                    return totalbytes

local       = "127.0.0.1"        
message     = "Hello there sailor\n"
portnum     = 7001

client_sock = do
    s <- socket AF_INET Stream 6
    ia <- inet_addr local
    -- connect s (SockAddrInet (mkPortNumber portnum) ia)
    connect s (SockAddrInet (PortNum portnum) ia)
    return s

echo_client n = do
    s <- client_sock
    drop <- server_echo s n
    sClose s
    where
        server_echo sock n = if n > 0
            then do 
                -- writeSocket sock message
                send sock message
                putStr ("Client wrote: " ++ message)
                --
                -- (str,i) <- readSocket sock 19
sof's avatar
sof committed
89
                str <- recv sock 19 `catch` eofAsEmptyHandler
90
91
92
93
94
95
96
97
98
99
100
                if (str /= message)
                    then do
                        putStr ("Client read error: " ++ str ++ "\n")
                        exitFailure
                    else do
                        putStr ("Client read success")
                        server_echo sock (n-1)
            else do 
                putStr "Client read nil\n"
                return []

sof's avatar
sof committed
101
main = {- withSocketsDo $ -} do 
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
    ~[n] <- getArgs
    -- server & client semaphores
    -- get the server socket
    ssock <- server_sock 
    -- fork off the server
    s <- myForkIO (echo_server ssock)
    -- fork off the client
    c <- myForkIO (echo_client (read n::Int))
    -- let 'em run until they've signaled they're done
    join s
    putStr("join s")
    join c
    putStr("join c")

-- these are used to make the main thread wait until
-- the child threads have exited
myForkIO :: IO () -> IO (MVar ())
myForkIO io = do
    mvar <- newEmptyMVar
    forkIO (io `finally` putMVar mvar ())
    return mvar

join :: MVar () -> IO ()
join mvar = readMVar mvar