Bug in make-payload-callback causes disconnect of large WebSocket messages

[rabbibotton]

Any payload that uses more than one frame (ie, :continue with large payloads) fails.

The buffer information is not being stored properly with fast-write-sequence properly. So that finish-output-buffer returns a correct sized vector but the data is garbage. So most likely the issue is in fast-io

A quick test to confirm I used a string to accumulate the buffer and everything worked.

(defun make-payload-callback (ws message-callback ping-callback pong-callback close-callback)
  (declare (type (or null function)
                 message-callback ping-callback pong-callback close-callback))
  (let ((buffer (make-output-buffer))
        (mb     ""))
    (lambda (payload &key (start 0) (end (length payload)))
      (declare (optimize (speed 3) (safety 2))
               (type (simple-array (unsigned-byte 8) (*)) payload)
               (type integer start end))
      (ecase (opcode-name (ws-opcode ws))
        (:continuation
         (setf mb (format nil "~A~A" mb (octets-to-string (let ((payload (subseq payload start end)))
                                                            (mask-message payload (ws-masking-key ws)))
                                                          :encoding :utf-8)))
         (fast-write-sequence payload buffer start end)
         (when (ws-fin ws)
           (let ((message (finish-output-buffer buffer)))
             (when (ws-mask ws)
               (mask-message message (ws-masking-key ws)))
             (setf buffer (make-output-buffer))
             (when message-callback
               (funcall (the function message-callback)
                        (if (eq (ws-mode ws) :text)
                            (handler-case
                                (prog1
                                    mb
                                  (setf mb "") ;;(octets-to-string message :encoding :utf-8)
                              (character-decoding-error ()
                                (error 'encoding-error)))
                            message))))))
        (:text
         (if (ws-fin ws)
             (when message-callback
               (handler-case
                   (funcall (the function message-callback)                            (if (ws-mask ws)
                                (octets-to-string
                                 (let ((payload (subseq payload start end)))
                                   (mask-message payload (ws-masking-key ws)))
                                 :encoding :utf-8)
                                (octets-to-string payload
                                                  :encoding :utf-8
                                                  :start start :end end)))
                 (character-decoding-error ()
                   (error 'encoding-error))))
             (progn
               (setf mb (format nil "~A~A" mb (octets-to-string (let ((payload (subseq payload start end)))
                                                                  (mask-message payload (ws-masking-key ws)))
                                                                :encoding :utf-8)))
               (fast-write-sequence payload buffer start end))))
        (:binary
         (if (ws-fin ws)
             (when message-callback
               (funcall message-callback
                        (if (ws-mask ws)
                            (let ((payload (subseq payload start end)))
                              (mask-message payload (ws-masking-key ws)))
                            (subseq payload start end))))
             (fast-write-sequence payload buffer start end)))
        (:close
         (let* ((payload (subseq payload start end))
                (payload (if (ws-mask ws)
                           (mask-message payload (ws-masking-key ws))
                           payload))
                (length (- end start))
                (has-code (<= 2 length))
                (code (if has-code
                          (+ (* 256 (aref payload 0)) (aref payload 1))
                          nil)))
           (declare (type integer length))
           (unless (or (zerop length)
                       (acceptable-error-code-p code))
             (setq code (error-code :protocol-error)))
           (if has-code
             (let ((reason (octets-to-string payload :encoding :utf-8 :start 2)))
               (funcall close-callback reason :code code))
             (funcall close-callback "" :code code))))
        (:ping
         (when ping-callback
           (let ((payload (subseq payload start end)))
             (when (ws-mask ws)
               (mask-message payload (ws-masking-key ws)))
             (funcall (the function ping-callback) payload))))
        (:pong
         (when pong-callback
           (let ((payload (subseq payload start end)))
             (when (ws-mask ws)
               (mask-message payload (ws-masking-key ws)))
             (funcall (the function pong-callback) payload))))))))

[rabbibotton]

This is solved unmasking (if required) the payload before using fast-write-sequence each time. The reason this works I suspect has to do with optimizations used to copy data to the buffer but I do not have time to investigate. I will try and submit a pull request later today.

[rabbibotton]

Any news on the time frame to merge this fix?