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
