Haskell Game Server - Part 1 Followup

Posted on December 28, 2015

Before I get started, I’ve changed the color scheme of this blog after a few comments about the previous colors I was using. Sorry for offending everyone’s eyes! Hopefully the current palette is easier to read.

Anyways, this is a quick followup to my previous post Haskell Game Server - Part 1 which covers a few changes I made after some great feedback, and grievous debugging of a crazy issue.

Changes to Server.hs

The following things were pointed out to me:

In a completely unrelated debugging nightmare that is oddly related to this specific code, I’ve also subtly changed how these methods work. With a high rate of messages flying back and forth we’d eventually lose a message here and there which was causing our event driven SDK to stall, even though it was clearly connected and doing other things. After scratching my head for a week I finally narrowed it down to two things today:

The following is the revised code:

runClient :: Server -> Client -> IO ()
runClient server client = forever $ do
  (mid, msg) <- readMessage (client^.clientInput)
  handleMessage server (client^.clientId) mid msg
  return ()

readMessage :: Streams.InputStream BS.ByteString -> IO (Word8, BS.ByteString)
readMessage in' = do
  inS <- Streams.lockingInputStream in'
  mid <- handleStream 1 inS
  lth <- handleStream 2 inS
  out <- if msgSize lth <= maxMsgSize
         then handleStream (msgSize lth) inS
         else return BS.empty
  return (midData mid, out)
    midData mid' = fromIntegral $ runGet getWord8 (BL.fromStrict mid')
    msgSize lth' = (fromIntegral $ runGet getWord16be (BL.fromStrict lth')) :: Int
    handleStream len str =
      handle (\(SomeException e) -> do debug $ "read failed: " ++ show e; return BS.empty) $
        Streams.readExactly len str

sendMessage :: (GameMessage m, Encode m) => m -> Streams.OutputStream BS.ByteString -> IO ()
sendMessage msg out' = do
  outS <- Streams.lockingOutputStream out'
  handle (\(SomeException e) -> debug $ "write failed: " ++ show e ) $
    Streams.write (Just $ messageOutWithIdAndLength msg) outS