[Haskell-beginners] IPerf in Haskell doesn't perform

[Thomas Bach]

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
-------------- next part --------------
A non-text attachment was scrubbed...
Name: iperf.hs
Type: text/x-haskell
Size: 4927 bytes
Desc: not available
URL: <http://www.haskell.org/pipermail/beginners/attachments/20131107/1e7ba573/attachment.hs>