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 уже не будет пустым обещанием, а честно будет содержать часть всего ввода.
Александр Ручкин