Socket Behaviour

[Steinitz, Dominic J]

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

server 20000 &
and 
client <hostname> 20000

the server logfile produces

[dom@lhrtba8fd85 twotest]$ more log.txt
Thu May 31 14:35:39 BST 2001
Starting logging
Thu May 31 14:36:08 BST 2001
Hello world    48 65 6c 6c 6f 20 77 6f 72 6c 64                                

so it looks like the hPutStrLn to the socket never completes. On the client side, "Hello world" gets sent but the hGetLine never completes.

Client

   do sh <- connectTo host port
      hPutStr sh "Hello world"
      hFlush sh
      x <- hGetLine sh
      putStrLn x

Server

      socket <- listenOn port 
      (sh,host,portid) <- accept socket
      let loop = do b <- getBuffer sh 16
                    case b of
                       Full msg ->
                          do logMessage ofh (hexedMessage msg)
                             loop
                       Partial msg ->
                          do logMessage ofh (hexedMessage msg)
                             hPutStrLn sh "Finishing Logging"
                             hFlush sh
                             logMessage ofh "Finishing logging"
                             hClose ofh
         in loop         


Dominic.

Here's the full code:

module Main (main) where

import System
import IO
import Time
import Socket
import Char

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
      logMessage ofh "Starting logging"
      socket <- listenOn port 
      (sh,host,portid) <- accept socket
      let loop = do b <- getBuffer sh 16
                    case b of
                       Full msg ->
                          do logMessage ofh (hexedMessage msg)
                             loop
                       Partial msg ->
                          do logMessage ofh (hexedMessage msg)
                             hPutStrLn sh "Finishing Logging"
                             hFlush sh
                             logMessage 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
                           
logMessage :: Handle -> String -> IO ()
logMessage hd msg =
   do clock <- getClockTime
      calendar <- toCalendarTime clock
      hPutStrLn hd ((calendarTimeToString calendar) ++ "\n" ++ msg)
      hFlush hd

showHex :: Char -> String
showHex x = 
   let y = ord x in
      hexDigit (y `div` 16):hexDigit (y `mod` 16):[]

hexDigit :: Int -> Char
hexDigit x 
   | (0 <= x) && (x <= 9)  = chr(ord '0' + x)
   | (10 <= x) && (x <=16) = chr(ord 'a' + (x-10))
   | otherwise             = error "Outside hexadecimal range"

hexedMessage :: String -> String
hexedMessage msg =
   (map toPrint msg) ++ "    " ++ unwords (map showHex msg)

toPrint :: Char -> Char
toPrint x = 
   if ((isAscii x) && (not (isControl x)))
      then x
      else '.'          


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

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