Socket Behaviour

[Steinitz, Dominic J]

Apologies if you have received this request for help already.

Can anyone tell me why the following code doesn't work as expected? Both the server and client hang.

[dom@lhrtba8fd85 simptest]$ server 20000 &
[1] 2694
[dom@lhrtba8fd85 simptest]$ client lhrtba8fd85 20000
client: interrupted
[1]+  Broken pipe             server 20000
[dom@lhrtba8fd85 simptest]$ more log.txt
Starting logging
Hello world
[dom@lhrtba8fd85 simptest]$                                                    

So it looks like the hPutStrLn to the server's socket never completes. What's stopping it? On the client side, "Hello world" gets sent but the hGetLine never completes. I guess because the server for some reason can't send.

Dominic.

module Main(main) where

import System
import IO
import Socket

main :: IO ()
main = do prog <- getProgName
          args <- getArgs
          if (length args /= 2)
              then do putStrLn ("Use: " ++ prog ++ " <host> <port>")
                      exitWith (ExitFailure (-1))
              else return ()
          let host = args !! 0
              port = read (args !! 1) :: Int in
              client host (PortNumber (mkPortNumber port))

client :: Hostname -> PortID -> IO ()
client host port = 
   do sh <- connectTo host port
      hPutStr sh "Hello world"
      hFlush sh
      x <- hGetLine sh
      putStrLn x


module Main (main) where

import System
import IO
import Socket

main :: IO ()
main = do prog <- getProgName
          args <- getArgs
          if (length args /= 1) 
             then do putStrLn ("Use: " ++ prog ++ " <port>")
                     exitWith (ExitFailure (-1))
             else return ()
          let port = read (args !! 0) :: Int in
             server (PortNumber (mkPortNumber port))

-- The server function creates a socket to listen on the port and
-- loops to log messages. 

server :: PortID -> IO ()
server port = 
   do ofh <- openFile "log.txt" WriteMode
      hPutStrLn ofh "Starting logging"
      hFlush ofh
      socket <- listenOn port 
      (sh,host,portid) <- accept socket
      let loop = do b <- getBuffer sh 16
                    case b of
                       Full msg ->
                          do hPutStrLn ofh msg
                             hFlush ofh
                             loop
                       Partial msg ->
                          do hPutStrLn ofh msg
                             hFlush ofh
                             hPutStrLn sh "Finishing Logging"
                             hFlush sh
                             hPutStrLn ofh "Finishing logging"
                             hClose ofh
         in loop         

data Buffer = Full String | Partial String

getBuffer :: Handle -> Int -> IO Buffer
getBuffer h n =
   if (n <= 0)
      then return (Full "")
      else do x <- try (hGetChar h)
              case x of
                 Right c -> 
                    do xs <- getBuffer h (n-1)
                       case xs of
                          Full cs -> return (Full (c:cs))
                          Partial cs -> return (Partial (c:cs))
                 Left e -> if isEOFError e 
                              then return (Partial "")
                              else ioError e

-------------------------------------------------------------------------------------------------
21st century air travel     http://www.britishairways.com