Client.hs

module Client where

import Network
import System.IO

runClient :: HostName -> PortNumber -> IO ()
runClient ip port = do
    h <- connectTo ip $ PortNumber port 
    putStrLn $ show h
    listen h
  where
    listen h = do
        msg <- getLine
        hPutStrLn h msg 
        answ <- hGetStrLn h
        putStrLn answ
        listen h

Main.hs

module Main where

import System.Environment
import System.IO
import Control.Monad (unless)

import Server
import Client

test :: HandlerFunc
test h msg = unless (show msg == "FUCK YOU") $ hPutStrLn h "We've received your message." 

temp :: [String] -> IO ()
temp ["client", hostname, port] = runClient hostname $ fromIntegral $ read port
temp ["server", port] = runServer (fromIntegral $ read port) test
temp _ = getProgName >>= putStr . (++) "Usage: " >> putStrLn " [OPTIONS]"

main = getArgs >>= temp

Server.hs

module Server (runServer, HandlerFunc) where

import Network
import System.IO
import Control.Concurrent (forkIO)

type HandlerFunc = Handle -> String -> IO ()

runServer :: PortNumber -> HandlerFunc -> IO ()
runServer port func = withSocketsDo $ do
    s <- listenOn $ PortNumber port
    putStrLn "Starting server..."
    forever s
  where
    forever s = do
        (h, ip, _) <- accept s
        putStrLn $ ip ++ " connected."
        forkIO $ procRequests h ip func
        forever s

procRequests :: Handle -> HostName -> HandlerFunc -> IO ()
procRequests h ip f = do
    hSetBuffering h NoBuffering
    hPutStrLn h "Welcome to the server!"
    forever h ip f
  where
    forever h ip f = do  
        msg <- hGetLine h
        f h msg 
        putStrLn $ ip ++ ": " ++ msg 
        forever h ip f