A networked based socket server

network_sockets.hs

-- Socket based network library
-- http://www.haskell.org/ghc/docs/6.10.4/html/libraries/network/Network-Socket.html

import Network.Socket

-- System io calls.  Posix based
-- http://lambda.haskell.org/hp-tmp/docs/2011.2.0.0/ghc-doc/libraries/haskell2010-1.0.0.0/System-IO.html

import System.IO

-- for exceptions
-- http://haskell.org/ghc/docs/latest/html/libraries/base/Control-Exception.html

import Control.Exception

-- concurrent primitives
-- http://www.haskell.org/ghc/docs/latest/html/libraries/base/Control-Concurrent.html

import Control.Concurrent

-- concurrent channels
-- http://www.haskell.org/ghc/docs/latest/html/libraries/base/Control-Concurrent-Chan.html

import Control.Concurrent.Chan

-- http://www.haskell.org/ghc/docs/latest/html/libararies/base/Control-Monad.html

import Control.Monad

-- http://www.haskell.org/ghc/docs/latest/html/libraries/base-4.4.0.0/Control-Monad-Fix.html

import Control.Monad.Fix (fix)
 
-- BJB - our message type will be an id and a string message to be passed to all
--     - channels not on that Id
type Msg = (Int, String)
 
-- BJB - The main function is run as an IO Monad
main :: IO ()
main = do
    -- BJB Create a new channel for the server side communication
    chan <- newChan
    -- create socket
    -- BJB - The socket is of type AF_INET http://en.wikipedia.org/wiki/AF_INET
    --       The socket type is Stream, which means they are connected, ie failure on
    --       on party breaks both connections
    sock <- socket AF_INET Stream 0
    -- make socket immediately reusable - eases debuggin
    -- BJB - Socket option SO_REUSEADDR
    --       http://publib.boulder.ibm.com/infocenter/iseries/v5r3/index.jsp?topic=%2Fapis%2Fssocko.htm
    setSocketOption sock ReuseAddr 1
    -- listen on TCP port 4242
    -- BJB - could be written as `bindSocket sock $ SockAddrInet 4242 iNADDR_ANY`
    --       iNADDR_ANY is the ipv4 wildcard.  4242 is the port
    --       this takes the socket and binds it to the network interface
    bindSocket sock (SockAddrInet 4242 iNADDR_ANY)
    -- listen on TCP port 4242
    -- BJB - could be written as `bindSocket sock $ SockAddrInet 4242 iNADDR_ANY`
    --       iNADDR_ANY is the ipv4 wildcard.  4242 is the port
    --       this takes the socket and binds it to the network 
    listen sock 2
    -- BJB - recursive sink to pull data off the first chanel
    --     - this is to prevent the channel from filling it's
    --     - buffer without removing any data
    --     - See below for more information about fix and how it works
    forkIO $ fix $ \loop -> do
        (_, msg) <- readChan chan
        loop
    -- BJB - Passing the channel to the loop with an id
    mainLoop sock chan 0
 
-- handles all incoming connections
-- since it performs IO, it too must operate in the IO monad
mainLoop :: Socket -> Chan Msg -> Int -> IO ()
mainLoop sock chan nr = do
    -- accept on connection and handle it
    -- BJB - http://en.wikipedia.org/wiki/Berkeley_sockets#accept.28.29
    --       waits for a connection to a client
    --       a connection is a (Socket, SockAddr)
    conn <- accept sock
    -- BJB - passes the connection to the handler function
    --     - type of forkIO is IO() -> IO ThreadId
    --     - it's a lightweight thread
    --     - not for use if there are system threads excpected by the
    --     - underlying libraries
    --     - pass the channel to the socket handlers
    forkIO (runConn conn chan nr)
    -- BJB - loops back to accept the next connection
    --     - increment the connection id
    --     - the $! operator is defined as
    --     - f $! x = x `seq` f x
    --     - seq forces evaluation of a function, this increments
    --     - the connection id explicitly before the recursive call is made
    mainLoop sock chan $! nr+1


-- BJB Need to constrain the error handler used below to only receive an IOException
-- Will try to find out why later
errorHandler :: IOException -> IO()
-- BJB - the return () or return unit/void means do nothing
errorHandler _ = return ()

-- sends a message to the incomming socket
runConn :: (Socket, SockAddr) -> Chan Msg -> Int -> IO ()
runConn (sock, _) chan nr = do
    -- BJB - define a helper to broadcast a mesage to the channel
    --     - note: it closes over the channel
    let broadcast msg = writeChan chan (nr, msg)
    -- BJB - socketToHandle converts a network socket to a handle
    --     - a read / write handle
    hdl <- socketToHandle sock ReadWriteMode
    -- BJB - set to nobuffer, no need to flush
    hSetBuffering hdl NoBuffering
    -- BJB - As the user for their name
    hPutStrLn hdl "Hi, what's your name?"
    -- BJB - Store the user name
    name <- liftM init (hGetLine hdl)
    -- BJB - Tell everyone the user entered.
    --     - the ++ operator concats two lists efficientlyd
    broadcast ("--> " ++ name ++ " entered.")
    -- BJB - welcome the user on their socket
    hPutStrLn hdl ("Welcome, " ++ name ++ "!")
    -- BJB - duplicate the chanel
    --     - chan' is used to read
    --     - chan is used to write
    chan' <- dupChan chan
    -- fork off thread for reading fro the duplicate channel
    -- BJB - fix turns a lamba (taking a function as an arg and calling that at the end)
    --     -  into a loop
    --     - fix f = f (fix f)
    --     - http://en.wikibooks.org/wiki/Haskell/Fix_and_recursion
    --     - remember forkIO's threadId so we can work on it later
    reader <- forkIO $ fix $ \loop -> do
        (nr', line) <- readChan chan'
        -- BJB - if the message comes from a channel that isn't mine,
        --     - send it over the socket, otherwise skip it
        when (nr /= nr') $ hPutStrLn hdl line
        loop
    -- BJB - right now, this won't even compile
    --     - I suspect it isn't compiling because it's looking for an exception,
    --     - but one isn't present
    --     - handle is of type handle::Exception e => (e -> IO a) -> IO a -> IO a
    --     - the (e -> IO a) is an exception handler
    --     - However, the compiler wants it to be tightented down to only (IOException -> IO a)
    --     - this is done by using the errorHandler defined above as opposed to the 
    --     - lambda from the original article
    handle errorHandler $fix $ \loop -> do
        -- BJB - http://en.wikibooks.org/wiki/Haskell/Monad_transformers#liftM
        --     - liftM turns init into a monad to take the line from the socket
        --     - init is used to kill the \n character
        line <- liftM init (hGetLine hdl)
        case line of
         -- BJB - quit if needed
         "quit" -> hPutStrLn hdl "Bye!"
         -- BJB - otherwise broadcast
         _      -> do
                   broadcast (name ++ ": " ++ line)
                   loop
    -- BJB - close the reader thread.
    --     - this isn't a problem because the previous line will not get here
    --     - until the writer chanel is closed from the 'quit' command
    killThread reader
    -- BJB - Let the room know this user left
    broadcast ("<-- " ++ name ++ " left.")
    -- BJB - close the socket/handle
    hClose hdl