Pull to refresh

WebSocket сервер на Haskell

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

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

Handshake


Открываем драфт и видим описание формата 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<br>
    spaces = ignore (many space) [()]<br>
colon = lit ':' char<br>
space = lit ' ' char<br>
cr = lit '\r' char<br>
lf = lit '\n' char<br>
unicodeChar = optIf (<= '\x10FFFF') char<br>
nameChar = optIf (`notElem` ": \r\n") unicodeChar<br>
anyChar = optIf (`notElem` "\r\n") unicodeChar<br>


Поясню происходящее на примере первой строки.
field = (many1 nameChar <& colon <& spaces) <&> (many anyChar <& cr <& lf) where<br>
    spaces = ignore (many space) [()]<br>


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

Само сообщение состоит из заглавной строки, полей и данных определённой длины, идущих после полей.
Это записывается не сложнее:
message = (toMessage, fromMessage) `wrap` (leadingLine <&> many field) where<br>
    toMessage (ll, fs) = Message {<br>
        messageLeadingLine = ll,<br>
        messageFields = fs }<br>
    fromMessage (Message { messageLeadingLine = ll, messageFields = fs }) = (ll, fs)<br>
<br>
body len = cr &> lf &> times len unicodeChar<br>
<br>
leadingLine = many anyChar <& cr <& lf<br>


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

Ладно, абстрактное сообщение с полями мы разбирать научились, теперь можно посмотреть и в сторону Opening (от клиента) и Response (ответ сервера).
Opening должен содержать определённые поля (некоторые же опциональны), поэтому правило message мы обернём в optIf; а также содержать тело длиной 8 байт.
opening = (toOpening, fromOpening) `wrap` (optIf hasFields message <&> body 8) where<br>

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

Frames


Допустим, 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<br>
frame = optIf isText textFrame <|> optIf isBinary binaryFrame <|> optIf isClosing closingFrame<br>

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

Сами фреймы:
textFrame = (TextFrame, \(TextFrame s) -> s) `wrap` (textFlag &> many frameChar <& frameFF) where<br>
    textFlag = ignore (optIf (<= 0x7F) word8) 0x00<br>
binaryFrame = (BinaryFrame, \(BinaryFrame s) -> s) `wrap` (binaryFlag &> byteSourceLength frameLength) where<br>
    binaryFlag = ignore (optIf (liftM2 (&&) (> 0x7F) (/= 0xFF)) word8) 0xF0<br>
closingFrame = check (0xFF, 0x00) (word8 <&> word8) ClosingFrame<br>

Функция ignore игнорирует сопоставленное значение, а при записи подставляет указанное вторым аргументом значение. Т.е. при чтении textFrame мы считаем текстовыми все фреймы, флаг у которых не более 0x7F, однако при сериализации сообщения мы ставим всегда 0.
byteSourceLength грузит/сохраняет тучу байт, предварив её количеством этих байт, которое [количество] будет загружено/сохранено с помощью переданного правила (frameLength).
Длина же в WebSocket имеет переменный размер в байтах. Признак последнего байта — неустановленный старший бит.
frameLength = (\(hs, l) -> toLength (hs ++ [l]), (init &&& last) . fromLength) `wrap` (many highWord <&> lowWord) where<br>

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

Сервер


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


Функция ожидания подключения:
acceptClient socket onAccept = ignore $ accept socket onReceived where<br>

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

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


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

К примеру, мы хотим представить весь пользовательский ввод как ленивый ByteString.
Если мы напишем это так:
input <- fix $ \loop -> unsafeInterleaveIO $ liftM2 (:) getLine loop<br>
let byteString = pack $ map charToByte input<br>

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

Заключение


Зачем я всё это написал? Ну, надеюсь, у кого-нибудь дополнительный интерес к Haskell пробудило, или поубавило скептицизма относительно бесполезности функциональных приблуд.
Tags:
Hubs:
+43
Comments 21
Comments Comments 21

Articles