Hi list, I had to do a little benchmarking of a network connection between two servers and I thought “Well, Haskell seemed pretty awesome, let's use it to accomplish the task.” So I spent a couple of days with the Haskell library and finally got the following (working!) code (see below). Now my questions: 1) Although being a beautiful language, my code seems to be ugly. Any hints to improve this? My problem is (I think) that I simply cannot get rid of the IO Monad and the only way I know how to deal with this is by using lots of 'do's which doesn't help at all to get rid of the monads. (Probably the imperative background problem…) :) 2) The program I wrote doesn't perform. It sended around 33 MBytes in 10 seconds over a connection where iperf (the one packaged by Ubuntu, written in C) was able send 650 MBytes. Where can I improve performance? I'm especially interested in the low hanging fruits, which are easy to understand as a Haskell novice. ;) 3) When I run this program, I get the following Error (both, on the client, as well as on the server): $./iperf -c localhost "Running as client connecting to localhost" Stack space overflow: current size 8388608 bytes. Use `+RTS -Ksize -RTS' to increase it. enlarging the stack space avoids it, but how can I avoid it in the code? I guess that the stack space overflow comes from the recursive call to receiveData on the server and sendIntermediateAndFinalData in the client. I thought that in the way I implemented it, these functions are tailor recursive and therefor not prone to stack overflows!?! Anyway, I didn't check that, so maybe the error is somewhere else… Regards, Thomas Bach. PS: This is the code pasted “As Quotation”. I couldn't find another way to get the code into Thunderbird w/o messing up line breaks and the like. I additionally added the code as an attachment. I hope this is ok – time to get a new MUA!
import Data.Time (DiffTime, utctDayTime, getCurrentTime) import Foreign (ForeignPtr, Int64, Ptr, mallocForeignPtr, withForeignPtr) import Foreign.Storable (sizeOf, peek, poke) import GHC.IO.Handle (Handle, BufferMode(NoBuffering), hClose, hGetBuf, hSetBuffering, hPutBuf) import Network (Socket, HostName, PortID(PortNumber), PortNumber, accept, connectTo, listenOn, withSocketsDo) import System.Console.GetOpt (ArgOrder(Permute), ArgDescr(..), OptDescr(..), getOpt, usageInfo) import System.Environment (getArgs)
data Flag = Client String | Server deriving Show
-- Command line arguments for server and client mode.
options :: [OptDescr Flag] options = [ Option ['c'] ["client"] (ReqArg Client "HOST") "Connect to host as client." , Option ['s'] ["server"] (NoArg Server) "Run as server." ]
perfOpts :: [String] -> IO [Flag] perfOpts argv = case getOpt Permute options argv of ([], [], []) -> ioError (userError ("At least one Option is needed." ++ usageInfo "" options)) (o, [], []) -> return o (_, _, errs) -> ioError (userError (concat errs ++ usageInfo "" options))
-- Some constants
port = PortNumber 8456 type Trans = Int64 numBytes = sizeOf (0 :: Trans) inital = -128 :: Trans intermediate = 0 :: Trans final = 127 :: Trans
makePtr = mallocForeignPtr :: IO (ForeignPtr Trans)
-- The client connects to the server, initializes the connection -- by sending initial, sends then for the amount of at least -- 10 secs as much intermediate (0's) as possible and finally -- sends final.
runClient :: String -> IO () runClient host = do print ("Running as client connecting to " ++ host) hdl <- initClient host port ptr <- makePtr fillInitial ptr withForeignPtr ptr (sendBuf hdl) fillIntermediate ptr curTime <- fmap utctDayTime getCurrentTime (sentBytes, time) <- sendIntermediateAndFinal ptr hdl curTime 10 0 print ("Sent " ++ show sentBytes ++ " Bytes in " ++ show time ++ " seconds.") hClose hdl
initClient :: HostName -> PortID -> IO Handle initClient host port = withSocketsDo $ do hdl <- connectTo host port hSetBuffering hdl NoBuffering return hdl
sendIntermediateAndFinal :: ForeignPtr Trans -> Handle -> DiffTime -> DiffTime -> Int -> IO (Int, DiffTime) sendIntermediateAndFinal ptr hdl start duration sent = do curTime <- fmap utctDayTime getCurrentTime if (curTime - start) > duration then do fillFinal ptr withForeignPtr ptr (sendBuf hdl) finishedTime <- fmap utctDayTime getCurrentTime return (sent + numBytes, finishedTime - start) else do withForeignPtr ptr (sendBuf hdl) sendIntermediateAndFinal ptr hdl start duration (sent + numBytes)
sendBuf :: Handle -> Ptr Trans -> IO () sendBuf hdl buf = hPutBuf hdl buf numBytes
fillPtr :: Trans -> ForeignPtr Trans -> IO () fillPtr num ptr = withForeignPtr ptr (\p -> poke p num)
fillInitial = fillPtr inital fillIntermediate = fillPtr intermediate fillFinal = fillPtr final
-- The server simply accepts connections, receives what it can get -- and adds up the received bytes and transmission time.
runServer :: IO () runServer = do print "Running as server." initServer port >>= handleConnection
initServer :: PortID -> IO Socket initServer port = withSocketsDo $ listenOn port
handleConnection :: Socket -> IO () handleConnection socket = do (hdl, host, port) <- acceptConnection socket print ("Connection from " ++ host) ptr <- makePtr (num, bytes) <- receive ptr hdl curTime <- fmap utctDayTime getCurrentTime if num == inital then do (received, time) <- receiveData ptr hdl curTime 0 print ("Received " ++ show received ++ " in " ++ show time ++ " seconds.") hClose hdl handleConnection socket else do print ("ERR: Expected " ++ show inital ++ " got " ++ show num) hClose hdl handleConnection socket
acceptConnection :: Socket -> IO (Handle, HostName, PortNumber) acceptConnection socket = do (hdl, host, port) <- accept socket hSetBuffering hdl NoBuffering return (hdl, host, port)
receiveData :: ForeignPtr Trans -> Handle -> DiffTime -> Int -> IO (Int, DiffTime) receiveData ptr hdl started received = do (num, bytes) <- receive ptr hdl if num /= final then receiveData ptr hdl started (received + bytes) else do curTime <- fmap utctDayTime getCurrentTime return (received + bytes, curTime - started)
receive :: ForeignPtr Trans -> Handle -> IO (Trans, Int) receive ptr hdl = do withForeignPtr ptr (\p -> hGetBuf hdl p numBytes) num <- withForeignPtr ptr peek return (num, numBytes)
-- The main routine decides whether to run as server or client.
main :: IO () main = do opts <- getArgs >>= perfOpts if length opts /= 1 then ioError (userError ("Too many arguments!" ++ usageInfo "" options)) else case head opts of Server -> runServer Client host -> runClient host