How do I get the desired behavior in my TCP server?

Question

import Network.Socket
import Control.Monad
import Network
import System.Environment (getArgs)
import System.IO
import Control.Concurrent (forkIO)

main :: IO ()
main = withSocketsDo $ do
   putStrLn ("up top\n")
   [portStr] <- getArgs
   sock' <- socket AF_INET Stream defaultProtocol 
   let port = fromIntegral (read portStr :: Int)
       socketAddress = SockAddrInet port 0000 
   bindSocket sock' socketAddress
   listen sock' 1
   putStrLn $ "Listening on " ++ (show port)
   (sock, sockAddr) <- Network.Socket.accept sock'
   handle <- socketToHandle sock ReadWriteMode
   sockHandler sock handle
-- hClose handle putStrLn ("close handle\n")

sockHandler :: Socket -> Handle -> IO ()
sockHandler sock' handle = forever $ do
    hSetBuffering handle LineBuffering
    forkIO $ commandProcessor handle

commandProcessor :: Handle -> IO ()
commandProcessor  handle = do
    line <- hGetLine handle
    let (cmd:arg) = words line
    case cmd of
        "echo" -> echoCommand handle arg 
        "add" -> addCommand handle arg 
        _ -> do hPutStrLn handle "Unknown command"
 

echoCommand :: Handle -> [String] -> IO ()
echoCommand handle arg = do
    hPutStrLn handle (unwords arg)

addCommand :: Handle -> [String] -> IO ()
addCommand handle [x,y] = do
    hPutStrLn handle $ show $ read x + read y
addCommand handle _ = do
    hPutStrLn handle "usage: add Int Int"

I'm noticing some quirks in it's behavior, but the one I want to address for the moment is what happens when a client disconnects with the server. When that happens, the server throws the following exception endlessly, and will not respond to further client connections.

strawboss: : hGetLine: end of file

I've tried flushing the handle, and closing the handle. I think that closing the handle is the right thing to do, but I cannot figure out where te correct place to close the handle is. So my first question is: Is the solution to this problem a judicious hClose placement in the code? If not, where does the problem lie?

Answer 1

There are several problems in this code. The main one is that you have your forever in the wrong place. What I assume you want is to endlessly accept connections, and deal with them in sockHandler, whereas your code currently only ever accepts a single connection, and then endlessly forks off worker threads to handle that single connection in parallel. This causes the mess you're experiencing.

sockHandler sock' handle = forever $ do
    ...
    forkIO $ commandProcessor handle

Instead, you'll want to move the forever to main:

forever $ do
    (sock, sockAddr) <- Network.Socket.accept sock'
    handle <- socketToHandle sock ReadWriteMode
    sockHandler sock handle

However, you will still get an exception when a client disconnects, because you're not checking if the connection has ended before calling hGetLine. We can fix this by adding using hIsEOF. You can then safely do a hClose on the handle once you know you're done with it.

Here's your code with these modifications in place. I also took the liberty of restructuring your code a little.

import Network.Socket
import Control.Monad
import Network
import System.Environment (getArgs)
import System.IO
import Control.Concurrent (forkIO)
import Control.Exception (bracket)

main :: IO ()
main = withSocketsDo $ do
   putStrLn ("up top\n")
   [port] <- getArgs
   bracket (prepareSocket (fromIntegral $ read port))
           sClose
           acceptConnections

prepareSocket :: PortNumber -> IO Socket
prepareSocket port = do
   sock' <- socket AF_INET Stream defaultProtocol 
   let socketAddress = SockAddrInet port 0000 
   bindSocket sock' socketAddress
   listen sock' 1
   putStrLn $ "Listening on " ++ (show port)
   return sock'

acceptConnections :: Socket -> IO ()
acceptConnections sock' = do
   forever $ do
       (sock, sockAddr) <- Network.Socket.accept sock'
       handle <- socketToHandle sock ReadWriteMode
       sockHandler sock handle

sockHandler :: Socket -> Handle -> IO ()
sockHandler sock' handle = do
    hSetBuffering handle LineBuffering
    -- Add the forkIO back if you want to allow concurrent connections.
    {- forkIO  $ -}
    commandProcessor handle
    return ()

commandProcessor :: Handle -> IO ()
commandProcessor handle = untilM (hIsEOF handle) handleCommand >> hClose handle
  where
    handleCommand = do
        line <- hGetLine handle
        let (cmd:arg) = words line
        case cmd of
            "echo" -> echoCommand handle arg 
            "add" -> addCommand handle arg 
            _ -> do hPutStrLn handle "Unknown command"

echoCommand :: Handle -> [String] -> IO ()
echoCommand handle arg = do
    hPutStrLn handle (unwords arg)

addCommand :: Handle -> [String] -> IO ()
addCommand handle [x,y] = do
    hPutStrLn handle $ show $ read x + read y
addCommand handle _ = do
    hPutStrLn handle "usage: add Int Int"

untilM cond action = do
   b <- cond
   if b
     then return ()
     else action >> untilM cond action