http - Common Lisp 中的 SSE 服务器

Question

我正在尝试用 Common Lisp 编写一个简单的异步服务器。强调简单。这是拍摄 2(感谢 Rainer 的建议和格式设置):

(ql:quickload (list :cl-ppcre :usocket))
(defpackage :test-server (:use :cl :cl-ppcre :usocket))
(in-package :test-server)

(defvar *socket-handle* nil)
(defparameter *channel* nil)

(defclass buffer ()
  ((contents :accessor contents :initform nil)
   (started :reader started :initform (get-universal-time))
   (state :accessor state :initform :empty)))

(defun listen-on (port &optional (stream *standard-output*))
  (setf *socket-handle* (socket-listen "127.0.0.1" port :reuse-address t))
  (let ((conns (list *socket-handle*))
        (buffers (make-hash-table)))
    (loop (loop for ready in (wait-for-input conns :ready-only t)
                do (if (typep ready 'stream-server-usocket)
                       (push (socket-accept ready) conns)
                     (let ((buf (gethash ready buffers (make-instance 'buffer))))
                       (buffered-read! (socket-stream ready) buf)
                       (when (starts-with? (list #\newline #\return #\newline #\return)
                                           (contents buf))
                         (format stream "COMPLETE ~s~%"
                                 (coerce (reverse (contents buf)) 'string))
                         (setf conns (remove ready conns))
                         (remhash ready buffers)
                         (let ((parsed (parse buf)))
                           (format stream "PARSED: ~s~%" parsed)
                           (handle-request ready (parse buf))))))))))

(defmethod parse ((buf buffer))
  (let ((lines (split "\\r?\\n" (coerce (reverse (contents buf)) 'string))))
    (second (split " " (first lines)))))

HTTP 写入:

(defmethod http-write (stream (line-end (eql :crlf)))
  (declare (ignore line-end))
  (write-char #\return stream)
  (write-char #\linefeed stream)
  (values))

(defmethod http-write (stream (line string))
  (write-string line stream)
  (http-write stream :crlf)
  (values))

(defmethod http-write (stream (lst list))
  (mapc (lambda (thing) (http-write stream thing)) lst)
  (values))

如何处理请求:

(defmethod handle-request (socket request)
  (let ((s (socket-stream socket)))
    (cond ((string= "/sub" request)
           (subscribe! socket))
          ((string= "/pub" request)
           (publish! "Got a message!")
           (http-write s (list "HTTP/1.1 200 OK"
                               "Content-Type: text/plain; charset=UTF-8"
                               "Cache-Control: no-cache, no-store, must-revalidate"
                               "Content-Length: 10" :crlf
                               "Published!" :crlf))
           (socket-close socket))
          (t (http-write s (list "HTTP/1.1 200 OK" 
                                 "Content-Type: text/plain; charset=UTF-9" 
                                 "Content-Length: 2" :crlf 
                                 "Ok" :crlf))
             (socket-close socket)))))

发布!

(defun publish! (msg)
  (loop for sock in *channel*
     do (handler-case
            (let ((s (socket-stream sock)))
              (format s "data: ~a" msg)
              (http-write s (list :crlf :crlf))
              (force-output s))
          (error (e)
             (declare (ignore e))
             (setf *channel* (remove sock *channel*))))))

订阅!

(defun subscribe! (sock)
  (let ((s (socket-stream sock)))
    (http-write s (list "HTTP/1.1 200 OK" 
                        "Content-Type: text/event-stream; charset=utf-8"
                        "Transfer-Encoding: chunked"
                        "Connection: keep-alive"
                        "Expires: Thu, 01 Jan 1970 00:00:01 GMT"
                        "Cache-Control: no-cache, no-store, must-revalidate" :crlf))
    (force-output s)
    (push sock *channel*)))

基本实用程序:

(defmethod starts-with? ((prefix list) (list list) &optional (test #'eql))
  (loop for (p . rest-p) on prefix for (l . rest-l) on list
     when (or (and rest-p (not rest-l)) (not (funcall test p l))) 
     do (return nil)
     finally (return t)))

(defun stop ()
  (when *socket-handle*
    (loop while (socket-close *socket-handle*))
    (setf *socket-handle* nil
      *channel* nil)))

(defmethod buffered-read! (stream (buffer buffer))
  (loop for char = (read-char-no-hang stream nil :eof)
     until (or (null char) (eql :eof char))
     do (push char (contents buffer))))

总结如下:

1. 它监听指定端口并将请求数据转储到指定流
2. 如果它收到对 "/sub" 的请求，它应该保留该套接字以便进一步写入。
3. 如果它收到对 "/pub" 的请求，它应该向所有现有订阅者发送一条短信
4. 它会针对任何其他请求发回纯文本 “Ok”。

像往常一样，欢迎所有反馈。从版本 2 开始(添加了 HTTP 友好的行结尾和几个策略性放置的强制输出调用)，浏览器似乎对我更满意，但 Chrome 在收到消息时仍然会感到窒息实际上被发送到现有 channel 。知道 publish! 中剩余的错误是什么吗？

明确地说，正在做

var src = new EventSource("/sub");
src.onerror = function (e) { console.log("ERROR", e); };
src.onopen = function (e) { console.log("OPEN", e); };
src.onmessage = function (e) { console.log("MESSAGE", e) };

现在，我在 FireFox 中获得了一个工作事件流(它触发 onopen，并在每次发送更新时触发 onmessage)。但在 Chrome 中失败(触发 onopen，每次更新都会触发 onerror 而不是 onmessage)。

感谢任何帮助。

Answer 1

我要确保的一件事是:它应该在输入和输出上正确处理 CRLF。 CRLF 在 HTTP 中使用。

有两个 Common Lisp 字符:#\return 和 #\linefeed。

不要使用#\newline。这是一个特殊字符，取决于操作系统和特定的 CL 实现。在 Unix 操作系统上，它可能与 #\linefeed 相同。在 Windows 实现上，它可能与返回和换行的顺序相同。因此也不要使用换行符作为格式指令 ~%。

在 HTTP 协议(protocol)中，始终显式地将 return 和 newline 写入行结束符。因此，您可以确保您的代码是可移植的并且可以做正确的事情。

另外，请注意，请确保字符比较不是使用 EQ 完成的。字符不一定是eq。使用EQL比较身份、数字和字符。