WebSocket-сервер на Haskell

Как-то раз от нечего делать я решил написать WebSocket сервер, а написав, подумал, что кому-то может оказаться интересным, чем же тут может помочь ленивость, функциональная чистота и прочие лямбды.

Прочитав, как в общих чертах работает сервер, я засел писать. Протокол, к слову, очень простой. Клиент шлёт случайные ключи, сервер в ответ подтверждает соединение, отсылая md5 от конкатенации этих ключей. А потом шлют они друг другу или бинарные, или текстовые данные, по большому счёту ничем не отличающиеся.

Рукопожатие

Открываем драфт и видим описание формата handshake:

field = 1*name-char colon [ space ] *any-char cr lf
colon = %x003A ; U+003A COLON (:)
space = %x0020 ; U+0020 SPACE
cr = %x000D ; U+000D CARRIAGE RETURN (CR)
lf = %x000A ; U+000A LINE FEED (LF)
name-char = %x0000-0009 / %x000B-000C / %x000E-0039 / %x003B-10FFFF
; a Unicode character other than U+000A LINE FEED (LF), U+000D CARRIAGE RETURN (CR), or U+003A COLON (:)
any-char = %x0000-0009 / %x000B-000C / %x000E-10FFFF
; a Unicode character other than U+000A LINE FEED (LF) or U+000D CARRIAGE RETURN (CR)

Ну что ж, так его и запишем:

field = (many1 nameChar <& colon <& spaces) <&> (many anyChar <& cr <& lf) where
   spaces = ignore (many space) [()]
colon = lit ':' char
space = lit ' ' char
cr = lit '\r' char
lf = lit '\n' char
unicodeChar = optIf (<= '\x10FFFF') char
nameChar = optIf (`notElem` ": \r\n") unicodeChar
anyChar = optIf (`notElem` "\r\n") unicodeChar

Поясню происходящее на примере первой строки.

field = (many1 nameChar <& colon <& spaces) <&> (many anyChar <& cr <& lf) where
   spaces = ignore (many space) [()]

many1 описывает значение, встречающееся 1 и более раз, many — 0 и более. Операторы &> и <& последовательно соединяют два правила, при этом указывая, что нас интересует значение лишь одного из них. В данном случае значения, которые пройдут по правилам colon и spaces нас не интересуют. Оператор же <&> позволяет получить оба значения в виде кортежа.

Функция lit задаёт жёсткое значение, которое должно быть встречено, а optIf накладывает ограничение.

Само сообщение состоит из заглавной строки, полей и данных определённой длины, идущих после полей. Это записывается не сложнее:

message = (toMessage, fromMessage) `wrap` (leadingLine <&> many field) where
   toMessage (ll, fs) = Message {
      messageLeadingLine = ll,
      messageFields = fs }
   fromMessage (Message { messageLeadingLine = ll, messageFields = fs }) = (ll, fs)

body len = cr &> lf &> times len unicodeChar

leadingLine = many anyChar <& cr <& lf

С leadingLine и body всё просто, а вот в определении message появляется функция wrap. Дело в том, что правило a <&> b определяет правило для кортежа, а нам нужен некий свой тип. Поэтому мы предоставляем две функции для преобразования из кортежа и в него.

Ладно, абстрактное сообщение с полями мы разбирать научились, теперь можно посмотреть и в сторону Opening (от клиента) и Response (ответ сервера).

Opening должен содержать определённые поля (некоторые же опциональны), поэтому правило message мы обернём в optIf; а также содержать тело длиной 8 байт.

opening = (toOpening, fromOpening) `wrap` (optIf hasFields message <&> body 8) where

Функции toOpening, fromOpening я приводить не буду. С Response всё обстоит точно так же.

Фреймы

Допустим, c пожатием руки разобрались, теперь стоит взяться за сообщения. В той же секции драфта можно увидеть описание формата фреймов:

frames = *frame
frame = text-frame / binary-frame
text-frame = (%x00-7F) *(%x00-FE) %xFF
binary-frame = (%x80-FF) length < as many bytes as given by the length >
length = *(%x80-FF) (%x00-7F)

Перепишем за тем лишь исключением, что оставим-таки closing-frame:

frames = (takeWhile (not . isClosing), takeWhile (not . isClosing)) `wrap` many frame
frame = optIf isText textFrame <|> optIf isBinary binaryFrame <|> optIf isClosing closingFrame

Оператор <|> — альтернатива. Сначала применяет левое правило, при неудаче — правое.

Сами фреймы:

textFrame = (TextFrame, \(TextFrame s) -> s) `wrap` (textFlag &> many frameChar <& frameFF) where
   textFlag = ignore (optIf (<= 0x7F) word8) 0x00
binaryFrame = (BinaryFrame, \(BinaryFrame s) -> s) `wrap` (binaryFlag &> byteSourceLength frameLength) where
   binaryFlag = ignore (optIf (liftM2 (&&) (> 0x7F) (/= 0xFF)) word8) 0xF0
closingFrame = check (0xFF, 0x00) (word8 <&> word8) ClosingFrame

Функция ignore игнорирует сопоставленное значение, а при записи подставляет указанное вторым аргументом значение. Т.е. при чтении textFrame мы считаем текстовыми все фреймы, флаг у которых не более 0x7F, однако при сериализации сообщения мы ставим всегда 0.

byteSourceLength грузит/сохраняет тучу байт, предварив её количеством этих байт, которое [количество] будет загружено/сохранено с помощью переданного правила (frameLength).

Длина же в WebSocket имеет переменный размер в байтах. Признак последнего байта — неустановленный старший бит.

frameLength = (\(hs, l) -> toLength (hs ++ [l]), (init &&& last) . fromLength) `wrap` (many highWord <&> lowWord) where

Определения toLength, fromLength, highWord и lowWord я опущу.

Сервер

Теперь можно попробовать написать нечто вроде сервера.

start port onAccept = do
   sock <- S.socket S.AF_INET S.Stream S.defaultProtocol
   S.bindSocket sock $ S.SockAddrInet port S.iNADDR_ANY
   S.listen sock S.maxListenQueue
   let
      -- Обработчик всех исключений. Игнорируем все исключения (перезапускаем функцию ожидания подключения), если только
      -- это не "убийство" потока
      canDie e = if fromException e == Just ThreadKilled then throwIO ThreadKilled else return ()
   -- В отдельном потоке ожидаем подключения
   th <- fork $ forever $ canDie `handle` acceptClient sock onAccept
   return $ Server th

Функция ожидания подключения:

acceptClient socket onAccept = ignore $ accept socket onReceived where

accept принимает подключение и передаёт весь входной поток в функцию onReceived в виде ленивой строки.

onReceived sock income = do
   -- Парсинг тоже ленивый. Благодаря тому, что правило anything всегда истинно (и сматчит весь остаток входного потока),
   -- результат мы получаем сразу, как только по сети придёт opening.
   (o, tailData) <- letFail $ decode (opening <&> anything) income
   -- Посчитаем и сериализуем ответ.
   r <- letFail (responseTo o >>= mapException show . encode response)
   -- и отправим его.
   send sock r
   let con = connection (openingChannel o) (openingHost o) (openingOrigin o) (openingProtocol o) sock
   let
       -- Пришёл фрейм закрытия соединения. Отошлём такой же и вызовем callback.
      onConnect ClosingFrame = close con `finally` acceptOnClose handlers con
      -- Пришло обычное сообщение.
      onConnect f = acceptOnMessage handlers con f
   -- В отдельном потоке запустим callback "подключились".
   fork $ acceptOnOpen handlers con

   -- А тут мы просто-напросто парсим ленивую строку и получаем ленивый список сообщений, что весьма удобно.
   switch (const $ return ()) (mapM_ onConnect) $ decode frames tailData

Работать с ленивыми списками удобно для понимания: есть список сообщений, мы для каждого вызываем соответствующий callback; но есть один нюанс.

К примеру, мы хотим представить весь пользовательский ввод как ленивый ByteString. Если мы напишем это так:

input <- fix $ \loop -> unsafeInterleaveIO $ liftM2 (:) getLine loop
let byteString = pack $ map charToByte input

То попытавшись распечатать ленивый ByteString, можем сильно удивиться отсутствию эффекта. Дело элементарно в строгости функции pack, ей нужна вся строка сразу.

В данном случае правильнее было бы получить ленивый список всех пользовательских вводов, а затем воспользоваться функцией fromChunks. Тогда сразу по мере ввода наш ByteString уже не будет пустым обещанием, а честно будет содержать часть всего ввода.