[Haskell-cafe] Long-running request/response protocol server ...

[oleg at okmij.org]

Nicolas Trangez wrote

> The protocol I'd like to implement is different: it's long-running using
> repeated requests & responses on a single client connection. Basically,
> a client connects and sends some data to the server (where the length of
> this data is encoded in the header). Now the server reads & parses this
> (binary) data, sets up some initial state for this client connection
> (e.g. opening a file handle), and returns a reply. Now the client can
> send another request, server parses/interprets it using the connection
> state, sends a reply, and so on.''

That is very simple to implement in any Iteratee library; I will use
IterateeM for concreteness. The desired functionality is already
implemented, in decoding of chunk-decoded inputs. Your protocol is
almost the same: read a chunk of data (tagged with its size), and do
something about it. After the chunk is handled, read another
chunk. The iteratee library takes care of errors. In particular, if
the request handler finished (normally or with errors) without reading
all of the chunk, the rest of the chunk is read nevertheless and
disregarded. Otherwise, we deadlock. 

The complete code with a simple test is included. The test reads three
requests, the middle of which causes the request handler to report an
error without reading the rest of the request.

module SeveralRequests where

import IterateeM
import Prelude hiding (head, drop, dropWhile, take, break, catch)
import Data.Char (isHexDigit, digitToInt, isSpace)
import Control.Exception
import Control.Monad.Trans


-- Tell the iteratee the stream is finished and write the result
-- as the reply to the client
-- If the iteratee harbors the error, write that too.
reply :: MonadIO m => Iteratee el m String -> Iteratee el m ()
reply r = en_handle show (runI r) >>= check
 where
 check (Right x) = liftIO . putStrLn $ "REPLY: " ++ x
 check (Left  x) = liftIO . putStrLn $ "ERROR: " ++ x


-- Read several requests and get iter to handle them
-- Each request is formatted as a single chunk
-- The code is almost identical to IterateeM.enum_chunk_decoded
-- The only difference is in the internal function
-- read_chunk below.
-- After a chunk is handled, the inner iteratee is terminated
-- and we process the new chunk with a `fresh' iter.
-- If iter can throw async errors, we have to wrap it 
-- accordingly to convert async errors into Iteratee errors.
-- That is trivial.
reply_chunk_decoded :: MonadIO m => Enumeratee Char Char m String
reply_chunk_decoded iter = read_size
 where
 read_size = break (== '\r') >>= checkCRLF iter . check_size
 checkCRLF iter m = do 
   n <- heads "\r\n"
   if n == 2 then m else frame_err (exc "Bad Chunk: no CRLF") iter
 check_size "0" = checkCRLF iter (return iter)
 check_size str@(_:_) =
     maybe (frame_err (exc ("Bad chunk size: " ++ str)) iter) read_chunk $ 
     read_hex 0 str
 check_size _ = frame_err (exc "Error reading chunk size") iter

 read_chunk size = take size iter >>= \r -> checkCRLF r $ 
                    reply r >> reply_chunk_decoded iter

 read_hex acc "" = Just acc
 read_hex acc (d:rest) | isHexDigit d = read_hex (16*acc + digitToInt d) rest
 read_hex acc _ = Nothing

 exc msg = toException (ErrorCall $ "Chunk decoding exc: " ++ msg)
 -- If the processing is restarted, we report the frame error to the inner
 -- Iteratee, and exit
 frame_err e iter = throwRecoverableErr (exc "Frame error")
		    (\s -> enum_err e iter >>= \i -> return (return i,s))


-- Test
-- A simple request_handler iter for handling requests
-- If the input starts with 'abc' it reads and returns the rest
-- Otherwise, it throws an error, without reading the rest of the input.
request_handler :: Monad m => Iteratee Char m String
request_handler = do 
  n <- heads "abc" 
  if n == 3 then stream2list
     else throwErrStr "expected abc"

test_request_handler :: IO ()
test_request_handler = run =<< enum_pure_1chunk input 
	              (reply_chunk_decoded request_handler >> return ())
 where
 input = 
   -- first request
  "6"++crlf++
  "abcdef" ++ crlf++
   -- second request
  "8"++crlf++
  "xxxdefgh" ++ crlf++
   -- third request
  "5"++crlf++
  "abcde" ++ crlf++
  "0"++crlf++ crlf
 crlf = "\r\n"

{-
*SeveralRequests> test_request_handler
REPLY: def
ERROR: expected abc
REPLY: de
-}