├── .gitignore ├── .travis.yml ├── README.markdown ├── fast-websocket-test.asd ├── fast-websocket.asd ├── src ├── compose.lisp ├── constants.lisp ├── error.lisp ├── fast-websocket.lisp ├── parser.lisp ├── payload.lisp └── ws.lisp └── t ├── benchmark.lisp ├── compose.lisp ├── fast-websocket.lisp ├── parser.lisp ├── payload.lisp └── util.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.dx32fsl 3 | *.dx64fsl 4 | *.lx32fsl 5 | *.lx64fsl 6 | *.x86f 7 | *~ 8 | .#* -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | sudo: required 3 | 4 | env: 5 | global: 6 | - PATH=~/.roswell/bin:$PATH 7 | - ROSWELL_BRANCH=master 8 | - ROSWELL_INSTALL_DIR=$HOME/.roswell 9 | - COVERAGE_EXCLUDE=t/:src/error.lisp 10 | matrix: 11 | - LISP=sbcl-bin COVERALLS=true 12 | - LISP=ccl-bin 13 | - LISP=abcl 14 | - LISP=ecl 15 | - LISP=clisp 16 | 17 | addons: 18 | apt: 19 | packages: 20 | - default-jre 21 | 22 | install: 23 | # Install Roswell 24 | - curl -L https://raw.githubusercontent.com/snmsts/roswell/$ROSWELL_BRANCH/scripts/install-for-ci.sh | sh 25 | - ros -e '(ql:update-all-dists :prompt nil)' 26 | - git clone https://github.com/rpav/fast-io ~/lisp/fast-io 27 | - ros install prove 28 | 29 | cache: 30 | directories: 31 | - $HOME/.roswell 32 | - $HOME/.config/common-lisp 33 | 34 | script: 35 | - run-prove fast-websocket-test.asd 36 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # fast-websocket 2 | 3 | [![Build Status](https://travis-ci.org/fukamachi/fast-websocket.svg?branch=master)](https://travis-ci.org/fukamachi/fast-websocket) 4 | [![Coverage Status](https://coveralls.io/repos/fukamachi/fast-websocket/badge.svg?branch=master)](https://coveralls.io/r/fukamachi/fast-websocket) 5 | [![Quicklisp dist](http://quickdocs.org/badge/fast-websocket.svg)](http://quickdocs.org/fast-websocket/) 6 | 7 | Optimized low-level WebSocket protocol parser/composer. 8 | 9 | ## Warning 10 | 11 | This software is still BETA quality. The APIs will be likely to change. 12 | 13 | ## Usage 14 | 15 | ```common-lisp 16 | (use-package :fast-websocket) 17 | 18 | (let* ((ws (make-ws)) 19 | (body (make-string-output-stream)) 20 | (parser (make-parser ws 21 | :require-masking t 22 | :message-callback 23 | (lambda (message) 24 | (princ message body)) 25 | :close-callback 26 | (lambda (payload &key code) 27 | (format t "Client closed a connection: ~A (Code: ~D)~%" payload code))))) 28 | (funcall parser (make-array 11 :element-type '(unsigned-byte 8) 29 | :initial-contents (list 129 133 225 106 10 29 169 15 102 113 142))) 30 | 31 | (princ (opcode-name (ws-opcode ws))) 32 | ;-> :TEXT 33 | 34 | (princ (get-output-stream-string body)) 35 | ;-> Hello 36 | 37 | t) 38 | 39 | (compose-frame "bye" :type :close :code (error-code :protocol-error)) 40 | ;=> #(136 5 3 234 98 121 101) 41 | ``` 42 | 43 | ## Installation 44 | 45 | ``` 46 | cd ~/common-lisp 47 | git clone https://github.com/fukamachi/fast-websocket 48 | ``` 49 | 50 | ``` 51 | (ql:quickload :fast-websocket) 52 | ``` 53 | 54 | ## See Also 55 | 56 | * [RFC 6455](https://tools.ietf.org/html/rfc6455) 57 | * [websocket-driver](https://github.com/fukamachi/websocket-driver) 58 | 59 | ## Author 60 | 61 | * Eitaro Fukamachi (e.arrows@gmail.com) 62 | 63 | ## Copyright 64 | 65 | Copyright (c) 2015 Eitaro Fukamachi (e.arrows@gmail.com) 66 | 67 | ## License 68 | 69 | Licensed under the BSD 2-Clause License. 70 | -------------------------------------------------------------------------------- /fast-websocket-test.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of fast-websocket project. 3 | Copyright (c) 2015 Eitaro Fukamachi (e.arrows@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage fast-websocket-test-asd 8 | (:use :cl :asdf)) 9 | (in-package :fast-websocket-test-asd) 10 | 11 | (defsystem fast-websocket-test 12 | :author "Eitaro Fukamachi" 13 | :license "BSD 2-Clause" 14 | :depends-on (:fast-websocket 15 | :trivial-utf-8 16 | :fast-io 17 | :prove) 18 | :components ((:module "t" 19 | :components 20 | ((:test-file "parser") 21 | (:test-file "compose") 22 | (:test-file "payload") 23 | (:test-file "fast-websocket") 24 | (:file "benchmark") 25 | (:file "util")))) 26 | :description "Test system for fast-websocket" 27 | 28 | :defsystem-depends-on (:prove-asdf) 29 | :perform (test-op :after (op c) 30 | (funcall (intern #.(string :run-test-system) :prove-asdf) c) 31 | (asdf:clear-system c))) 32 | -------------------------------------------------------------------------------- /fast-websocket.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of fast-websocket project. 3 | Copyright (c) 2015 Eitaro Fukamachi (e.arrows@gmail.com) 4 | |# 5 | 6 | #| 7 | Author: Eitaro Fukamachi (e.arrows@gmail.com) 8 | |# 9 | 10 | (in-package :cl-user) 11 | (defpackage fast-websocket-asd 12 | (:use :cl :asdf)) 13 | (in-package :fast-websocket-asd) 14 | 15 | (defsystem fast-websocket 16 | :version "0.1" 17 | :author "Eitaro Fukamachi" 18 | :license "BSD 2-Clause" 19 | :depends-on (:fast-io 20 | :babel 21 | :alexandria) 22 | :components ((:module "src" 23 | :components 24 | ((:file "fast-websocket" :depends-on ("ws" "parser" "compose" "payload" "constants" "error")) 25 | (:file "ws") 26 | (:file "parser" :depends-on ("ws" "constants" "error")) 27 | (:file "compose" :depends-on ("constants" "payload")) 28 | (:file "payload") 29 | (:file "constants") 30 | (:file "error")))) 31 | :description "Optimized WebSocket protocol parser" 32 | :long-description 33 | #.(with-open-file (stream (merge-pathnames 34 | #p"README.markdown" 35 | (or *load-pathname* *compile-file-pathname*)) 36 | :if-does-not-exist nil 37 | :direction :input) 38 | (when stream 39 | (let ((seq (make-array (file-length stream) 40 | :element-type 'character 41 | :fill-pointer t))) 42 | (setf (fill-pointer seq) (read-sequence seq stream)) 43 | seq))) 44 | :in-order-to ((test-op (test-op fast-websocket-test)))) 45 | -------------------------------------------------------------------------------- /src/compose.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage fast-websocket.compose 3 | (:use :cl 4 | #:fast-websocket.constants) 5 | (:import-from :fast-websocket.payload 6 | #:mask-message) 7 | (:import-from :fast-websocket.error 8 | #:error-code 9 | #:acceptable-error-code-p) 10 | (:import-from :fast-io 11 | #:with-fast-output 12 | #:fast-write-sequence 13 | #:fast-write-byte) 14 | (:import-from :babel 15 | #:string-to-octets) 16 | (:export #:compose-frame)) 17 | (in-package :fast-websocket.compose) 18 | 19 | (defparameter *mask-random-state* 20 | (make-random-state t)) 21 | 22 | (defun random-mask-keys () 23 | (let ((keys (make-array 4 :element-type '(unsigned-byte 8)))) 24 | (dotimes (i 4 keys) 25 | (setf (aref keys i) (random 256 *mask-random-state*))))) 26 | 27 | (defun compose-frame (data &key start end type code masking) 28 | (setq start (or start 0) 29 | end (or end (length data))) 30 | 31 | (unless type 32 | (setq type (if (stringp data) :text :binary))) 33 | 34 | (when (eq type :close) 35 | (if code 36 | (unless (acceptable-error-code-p code) 37 | (error "Invalid error code: ~S" code)) 38 | (setq code (error-code :normal-closure)))) 39 | 40 | (when (stringp data) 41 | (setq data (babel:string-to-octets 42 | data :encoding :utf-8 :start start :end end)) 43 | (setq start 0 44 | end (length data))) 45 | 46 | (let ((opcode (opcode type)) 47 | (length (+ (- end start) (if code 2 0))) 48 | (masked (if masking 49 | +mask+ 50 | 0))) 51 | (with-fast-output (frame :vector) 52 | (fast-write-byte (logxor +fin+ opcode) frame) 53 | (cond 54 | ((<= length 125) 55 | (fast-write-byte (logxor masked length) frame)) 56 | ((<= length 65535) 57 | (fast-write-byte (logxor masked 126) frame) 58 | (fast-write-byte (logand (ash length -8) +byte+) frame) 59 | (fast-write-byte (logand length +byte+) frame)) 60 | (T 61 | (fast-write-byte (logxor masked 127) frame) 62 | (fast-write-byte (logand (ash length -56) +byte+) frame) 63 | (fast-write-byte (logand (ash length -48) +byte+) frame) 64 | (fast-write-byte (logand (ash length -40) +byte+) frame) 65 | (fast-write-byte (logand (ash length -32) +byte+) frame) 66 | (fast-write-byte (logand (ash length -24) +byte+) frame) 67 | (fast-write-byte (logand (ash length -16) +byte+) frame) 68 | (fast-write-byte (logand (ash length -8) +byte+) frame) 69 | (fast-write-byte (logand length +byte+) frame))) 70 | 71 | (if masking 72 | (let ((mask-keys (random-mask-keys))) 73 | (fast-write-sequence mask-keys frame) 74 | (if code 75 | ;; Add 'code' in front of the data 76 | (setq data 77 | (let ((new-data (make-array length :element-type '(unsigned-byte 8)))) 78 | (replace new-data data 79 | :start1 2 80 | :start2 start 81 | :end2 end) 82 | (setf (aref new-data 0) (logand (ash code -8) +byte+) 83 | (aref new-data 1) (logand code +byte+)) 84 | new-data)) 85 | ;; Call 'subseq' anyway for preventing from rewriting DATA in 'mask-message'. 86 | (setq data (subseq data start end))) 87 | (mask-message data mask-keys) 88 | (fast-write-sequence data frame)) 89 | (progn 90 | (when code 91 | (fast-write-byte (logand (ash code -8) +byte+) frame) 92 | (fast-write-byte (logand code +byte+) frame)) 93 | (fast-write-sequence data frame)))))) 94 | -------------------------------------------------------------------------------- /src/constants.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage fast-websocket.constants 3 | (:use :cl) 4 | (:import-from :alexandria 5 | #:plist-hash-table 6 | #:hash-table-keys) 7 | (:export #:+byte+ 8 | #:+fin+ 9 | #:+rsv1+ 10 | #:+rsv2+ 11 | #:+rsv3+ 12 | #:+opcode+ 13 | #:+mask+ 14 | #:+length+ 15 | #:opcode-name 16 | #:opcode 17 | #:valid-opcode-p 18 | #:fragmented-opcode-p 19 | #:opening-opcode-p)) 20 | (in-package :fast-websocket.constants) 21 | 22 | (defconstant +byte+ #b11111111) 23 | (defconstant +fin+ #b10000000) 24 | (defconstant +rsv1+ #b01000000) 25 | (defconstant +rsv2+ #b00100000) 26 | (defconstant +rsv3+ #b00010000) 27 | (defconstant +opcode+ #b00001111) 28 | (defconstant +mask+ #b10000000) 29 | (defconstant +length+ #b01111111) 30 | 31 | (defparameter *opcodes-map* 32 | (plist-hash-table '( 0 :continuation 33 | 1 :text 34 | 2 :binary 35 | 8 :close 36 | 9 :ping 37 | 10 :pong) 38 | :test 'eql)) 39 | 40 | (defparameter *opcodes-name-map* 41 | (plist-hash-table '(:continuation 0 42 | :text 1 43 | :binary 2 44 | :close 8 45 | :ping 9 46 | :pong 10) 47 | :test 'eq)) 48 | 49 | (defun opcode-name (opcode) 50 | (gethash opcode *opcodes-map*)) 51 | 52 | (defun opcode (name) 53 | (gethash name *opcodes-name-map*)) 54 | 55 | (defparameter *opcode-valid-array* 56 | (let ((ary (make-array 11 :element-type 'fixnum :initial-element 0))) 57 | (dolist (code (hash-table-keys *opcodes-map*) ary) 58 | (setf (aref ary code) 1)))) 59 | 60 | (defun valid-opcode-p (opcode) 61 | (and (< opcode 11) 62 | (= (aref *opcode-valid-array* opcode) 1))) 63 | 64 | (defparameter *fragmented-opcodes* 65 | (let ((ary (make-array 11 :element-type 'fixnum :initial-element 0))) 66 | (dolist (key '(0 1 2) ary) 67 | (setf (aref ary key) 1)))) 68 | 69 | (defun fragmented-opcode-p (opcode) 70 | (= (aref *fragmented-opcodes* opcode) 1)) 71 | 72 | (defparameter *opening-opcodes* 73 | (let ((ary (make-array 11 :element-type 'fixnum :initial-element 0))) 74 | (dolist (key '(1 2) ary) 75 | (setf (aref ary key) 1)))) 76 | 77 | (defun opening-opcode-p (opcode) 78 | (= (aref *opening-opcodes* opcode) 1)) 79 | -------------------------------------------------------------------------------- /src/error.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage fast-websocket.error 3 | (:use :cl) 4 | (:import-from :alexandria 5 | #:plist-hash-table 6 | #:hash-table-values) 7 | (:export #:websocket-error 8 | #:websocket-parse-error 9 | #:protocol-error 10 | #:too-large 11 | #:unacceptable 12 | #:encoding-error 13 | 14 | #:error-code 15 | #:error-code-name 16 | #:valid-error-code-p 17 | #:acceptable-error-code-p)) 18 | (in-package :fast-websocket.error) 19 | 20 | (defconstant +min-reserved-error+ 3000) 21 | (defconstant +max-reserved-error+ 4999) 22 | 23 | (define-condition websocket-error (error) ()) 24 | (define-condition websocket-parse-error (websocket-error) ()) 25 | 26 | (define-condition protocol-error (websocket-parse-error simple-error) ()) 27 | 28 | (define-condition too-large (protocol-error) 29 | ((length :initarg :length) 30 | (max-length :initarg :max-length)) 31 | (:report 32 | (lambda (condition stream) 33 | (with-slots (length max-length) condition 34 | (format stream "WebSocket frame length too large (~D exceeded the limit ~D)" 35 | length 36 | max-length))))) 37 | 38 | (define-condition unacceptable (protocol-error) 39 | ((require-masking :initarg :require-masking)) 40 | (:report 41 | (lambda (condition stream) 42 | (format stream "Recieved ~:[masked~;unmasked~] frame but masking is ~:*~:[not required~;required~]" 43 | (slot-value condition 'require-masking))))) 44 | 45 | (define-condition encoding-error (protocol-error) () 46 | (:report 47 | (lambda (condition stream) 48 | (declare (ignore condition)) 49 | (format stream "Could not decode a text frame as UTF-8")))) 50 | 51 | (defparameter *error-codes-map* 52 | (plist-hash-table '(:normal-closure 1000 53 | :going-away 1001 54 | :protocol-error 1002 55 | :unacceptable 1003 56 | :encoding-error 1007 57 | :policy-violation 1008 58 | :too-large 1009 59 | :extension-error 1010 60 | :unexpected-condition 1011) 61 | :test 'eq)) 62 | 63 | (defparameter *error-codes-name-map* 64 | (plist-hash-table '(1000 :normal-closure 65 | 1001 :going-away 66 | 1002 :protocol-error 67 | 1003 :unacceptable 68 | 1007 :encoding-error 69 | 1008 :policy-violation 70 | 1009 :too-large 71 | 1010 :extension-error 72 | 1011 :unexpected-condition) 73 | :test 'eql)) 74 | 75 | (defparameter *error-codes* 76 | (hash-table-values *error-codes-map*)) 77 | 78 | (defun error-code (error) 79 | (etypecase error 80 | (keyword (gethash error *error-codes-map*)) 81 | (too-large 1009) 82 | (unacceptable 1003) 83 | (encoding-error 1007) 84 | (protocol-error 1002))) 85 | 86 | (defun error-code-name (code) 87 | (gethash code *error-codes-name-map*)) 88 | 89 | (defun valid-error-code-p (code) 90 | (not (null (error-code-name code)))) 91 | 92 | (defun acceptable-error-code-p (code) 93 | (and (integerp code) 94 | (or (<= +min-reserved-error+ code +max-reserved-error+) 95 | (valid-error-code-p code)))) 96 | -------------------------------------------------------------------------------- /src/fast-websocket.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage fast-websocket 3 | (:use :cl 4 | #:fast-websocket.constants 5 | #:fast-websocket.ws) 6 | (:import-from :fast-websocket.parser 7 | #:make-ll-parser) 8 | (:import-from :fast-websocket.compose 9 | #:compose-frame) 10 | (:import-from :fast-websocket.payload 11 | #:fast-write-masked-sequence 12 | #:mask-message) 13 | (:import-from :fast-websocket.error 14 | #:websocket-error 15 | #:websocket-parse-error 16 | #:protocol-error 17 | #:too-large 18 | #:unacceptable 19 | #:encoding-error 20 | 21 | #:acceptable-error-code-p 22 | #:error-code) 23 | (:import-from :fast-io 24 | #:make-output-buffer 25 | #:finish-output-buffer 26 | #:fast-write-sequence) 27 | (:import-from :babel 28 | #:octets-to-string 29 | #:character-decoding-error) 30 | (:export #:make-parser 31 | #:compose-frame 32 | #:ws 33 | #:make-ws 34 | #:ws-fin 35 | #:ws-opcode 36 | #:ws-mask 37 | #:ws-masking-key 38 | #:ws-length 39 | #:ws-stage 40 | #:opcode 41 | #:opcode-name 42 | 43 | ;; errors 44 | #:websocket-error 45 | #:websocket-parse-error 46 | #:protocol-error 47 | #:too-large 48 | #:unacceptable 49 | #:encoding-error 50 | #:error-code)) 51 | (in-package :fast-websocket) 52 | 53 | (defun make-payload-callback (ws message-callback ping-callback pong-callback close-callback) 54 | (declare (type (or null function) 55 | message-callback ping-callback pong-callback close-callback)) 56 | (let ((buffer (make-output-buffer))) 57 | (lambda (payload &key (start 0) (end (length payload)) partial-frame) 58 | (declare (optimize (speed 3) (safety 2)) 59 | (type (simple-array (unsigned-byte 8) (*)) payload) 60 | (type integer start end)) 61 | (ecase (opcode-name (ws-opcode ws)) 62 | 63 | (:continuation 64 | (when (ws-mask ws) 65 | (mask-message payload (ws-masking-key ws) start end)) 66 | (fast-write-sequence payload buffer start end) 67 | (when (and (ws-fin ws) (not partial-frame)) 68 | (let ((message (finish-output-buffer buffer))) 69 | (setf buffer (make-output-buffer)) 70 | (when message-callback 71 | (funcall (the function message-callback) 72 | (if (eq (ws-mode ws) :text) 73 | (handler-case 74 | (octets-to-string message :encoding :utf-8) 75 | (character-decoding-error () 76 | (error 'encoding-error))) 77 | message)))))) 78 | (:text 79 | (if (and (ws-fin ws) (not partial-frame)) 80 | (when message-callback 81 | (handler-case 82 | (funcall (the function message-callback) 83 | (if (ws-mask ws) 84 | (octets-to-string 85 | (let ((payload (subseq payload start end))) 86 | (mask-message payload (ws-masking-key ws))) 87 | :encoding :utf-8) 88 | (octets-to-string payload 89 | :encoding :utf-8 90 | :start start :end end))) 91 | (character-decoding-error () 92 | (error 'encoding-error)))) 93 | (progn 94 | (when (ws-mask ws) 95 | (mask-message payload (ws-masking-key ws) start end)) 96 | (fast-write-sequence payload buffer start end)))) 97 | (:binary 98 | (if (and (ws-fin ws) (not partial-frame)) 99 | (when message-callback 100 | (funcall message-callback 101 | (if (ws-mask ws) 102 | (let ((payload (subseq payload start end))) 103 | (mask-message payload (ws-masking-key ws))) 104 | (subseq payload start end)))) 105 | (progn 106 | (when (ws-mask ws) 107 | (mask-message payload (ws-masking-key ws) start end)) 108 | (fast-write-sequence payload buffer start end)))) 109 | (:close 110 | (let* ((payload (subseq payload start end)) 111 | (payload (if (ws-mask ws) 112 | (mask-message payload (ws-masking-key ws)) 113 | payload)) 114 | (length (- end start)) 115 | (has-code (<= 2 length)) 116 | (code (if has-code 117 | (+ (* 256 (aref payload 0)) (aref payload 1)) 118 | nil))) 119 | (declare (type integer length)) 120 | (unless (or (zerop length) 121 | (acceptable-error-code-p code)) 122 | (setq code (error-code :protocol-error))) 123 | 124 | (if has-code 125 | (let ((reason (octets-to-string payload :encoding :utf-8 :start 2))) 126 | (funcall close-callback reason :code code)) 127 | (funcall close-callback "" :code code)))) 128 | (:ping 129 | (when ping-callback 130 | (let ((payload (subseq payload start end))) 131 | (when (ws-mask ws) 132 | (mask-message payload (ws-masking-key ws))) 133 | (funcall (the function ping-callback) payload)))) 134 | (:pong 135 | (when pong-callback 136 | (let ((payload (subseq payload start end))) 137 | (when (ws-mask ws) 138 | (mask-message payload (ws-masking-key ws))) 139 | (funcall (the function pong-callback) payload)))))))) 140 | 141 | (defun make-parser (ws &key 142 | (require-masking t) 143 | (max-length #x3ffffff) 144 | message-callback ;; (message) 145 | ping-callback ;; (payload) 146 | pong-callback ;; (payload) 147 | close-callback ;; (payload &key code) 148 | error-callback) ;; (code reason) 149 | (declare (type (or null function) error-callback)) 150 | (let ((parser 151 | (make-ll-parser ws 152 | :require-masking require-masking 153 | :max-length max-length 154 | :payload-callback 155 | (make-payload-callback ws 156 | message-callback 157 | ping-callback 158 | pong-callback 159 | close-callback))) 160 | (bufferedp nil) 161 | (buffer (make-output-buffer))) 162 | (lambda (data &key start end) 163 | (setq start (or start 0) 164 | end (or end (length data))) 165 | 166 | (when bufferedp 167 | (fast-write-sequence data buffer start end) 168 | (setq data (finish-output-buffer buffer)) 169 | (setq buffer (make-output-buffer) 170 | bufferedp nil) 171 | (setq start 0 172 | end (length data))) 173 | (multiple-value-bind (i eofp) 174 | (handler-case 175 | (funcall parser data :start start :end (or end (length data))) 176 | (protocol-error (e) 177 | (when error-callback 178 | (funcall (the function error-callback) 179 | (error-code e) 180 | (princ-to-string e))))) 181 | (when eofp 182 | (setq bufferedp t) 183 | (fast-write-sequence data buffer i)))))) 184 | -------------------------------------------------------------------------------- /src/parser.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage fast-websocket.parser 3 | (:use :cl 4 | #:fast-websocket.constants 5 | #:fast-websocket.ws 6 | #:fast-websocket.error) 7 | (:import-from :alexandria 8 | #:named-lambda) 9 | (:export #:make-ll-parser)) 10 | (in-package :fast-websocket.parser) 11 | 12 | (deftype octet () '(unsigned-byte 8)) 13 | (deftype octets () '(simple-array octet (*))) 14 | 15 | (defun make-ll-parser (ws &key require-masking (max-length #x3ffffff) payload-callback) 16 | (declare (type (or null function) payload-callback) 17 | (type fixnum max-length)) 18 | (named-lambda parser (data &key (start 0) (end (length data))) 19 | (declare (type fixnum start end) 20 | (type octets data) 21 | (optimize (speed 3) (safety 2))) 22 | (when (= start end) 23 | (return-from parser start)) 24 | (let ((i start)) 25 | (declare (type fixnum i)) 26 | (tagbody 27 | (ecase (ws-stage ws) 28 | (0 (go parsing-first-byte)) 29 | (1 (go parsing-second-byte)) 30 | (2 (go parsing-extended-length)) 31 | (3 (go parsing-masking-key)) 32 | (4 (go parsing-payload))) 33 | 34 | parsing-first-byte 35 | (let* ((byte (aref data i)) 36 | (fin (= (logand byte +fin+) +fin+))) 37 | (declare (type octet byte)) 38 | 39 | (dolist (rsv (list +rsv1+ +rsv2+ +rsv3+)) 40 | (when (= (logand byte rsv) rsv) 41 | (error 'protocol-error 42 | :format-control "Reserved bit is on: ~A" 43 | :format-arguments (list rsv)))) 44 | 45 | (let ((opcode (logand byte +opcode+))) 46 | (unless (valid-opcode-p opcode) 47 | (error 'protocol-error 48 | :format-control "Unrecognized frame opcode: ~A" 49 | :format-arguments (list opcode))) 50 | 51 | (unless (or fin 52 | (fragmented-opcode-p opcode)) 53 | (error 'protocol-error 54 | :format-control "Received fragmented control frame: opcode = ~A" 55 | :format-arguments (list opcode))) 56 | 57 | (when (and (ws-mode ws) 58 | (opening-opcode-p opcode)) 59 | (error 'protocol-error 60 | :format-control "Received new data frame but previous continuous frame is unfinished")) 61 | 62 | (setf (ws-fin ws) fin 63 | (ws-opcode ws) opcode))) 64 | 65 | (incf i) 66 | (setf (ws-stage ws) 1) 67 | 68 | parsing-second-byte 69 | (when (= i end) 70 | (go end)) 71 | 72 | (let ((byte (aref data i))) 73 | (declare (type octet byte)) 74 | (incf i) 75 | (setf (ws-mask ws) 76 | (= (logand byte +mask+) +mask+)) 77 | 78 | (unless (eql require-masking (ws-mask ws)) 79 | (error 'unacceptable :require-masking require-masking)) 80 | 81 | (let ((length (logand byte +length+))) 82 | (setf (ws-length ws) length) 83 | (cond 84 | ((<= 0 length 125) 85 | (when (< max-length length) 86 | (error 'too-large :length length :max-length max-length)) 87 | (if (ws-mask ws) 88 | (progn 89 | (setf (ws-stage ws) 3) 90 | (go parsing-masking-key)) 91 | (progn 92 | (setf (ws-stage ws) 4) 93 | (go parsing-payload)))) 94 | (t 95 | (setf (ws-length-size ws) (if (= length 126) 2 8)) 96 | (setf (ws-stage ws) 2))))) 97 | 98 | parsing-extended-length 99 | (when (< end (+ i (ws-length-size ws))) 100 | (return-from parser 101 | (values i t))) 102 | 103 | (let ((length 0)) 104 | (declare (type integer length)) 105 | 106 | (dotimes (j (ws-length-size ws)) 107 | (setf length (+ (ash length 8) (aref data i))) 108 | (incf i)) 109 | 110 | (unless (or (fragmented-opcode-p (ws-opcode ws)) 111 | (<= length 125)) 112 | (error 'protocol-error 113 | :format-control "Received control frame having too long payload: ~A" 114 | :format-arguments (list length))) 115 | 116 | (when (< max-length length) 117 | (error 'too-large :length length :max-length max-length)) 118 | 119 | (setf (ws-length ws) length)) 120 | 121 | (if (ws-mask ws) 122 | (setf (ws-stage ws) 3) 123 | (progn 124 | (setf (ws-stage ws) 4) 125 | (go parsing-payload))) 126 | 127 | parsing-masking-key 128 | (when (< end (+ i 4)) 129 | (return-from parser 130 | (values i t))) 131 | 132 | (dotimes (j 4) 133 | (setf (aref (ws-masking-key ws) j) (aref data i)) 134 | (incf i)) 135 | 136 | (setf (ws-stage ws) 4) 137 | 138 | parsing-payload 139 | (let* ((payload-end (+ i (ws-length ws))) 140 | (read-a-part (< end payload-end)) 141 | (next-end (if read-a-part end payload-end))) 142 | (declare (type integer payload-end)) 143 | (case (opcode-name (ws-opcode ws)) 144 | (:continuation 145 | (unless (ws-mode ws) 146 | (error 'protocol-error 147 | :format-control "Received unexpected continuation frame"))) 148 | (:text (unless (ws-fin ws) 149 | (setf (ws-mode ws) :text))) 150 | (:binary (unless (ws-fin ws) 151 | (setf (ws-mode ws) :binary)))) 152 | 153 | (when payload-callback 154 | (funcall (the function payload-callback) 155 | data 156 | :start i 157 | :end next-end 158 | :partial-frame read-a-part)) 159 | 160 | (if read-a-part 161 | (progn 162 | (decf (ws-length ws) (- end i)) 163 | (setq i next-end)) 164 | (progn 165 | (setf (ws-stage ws) 0) 166 | 167 | (setq i next-end) 168 | 169 | (when (and (ws-fin ws) 170 | (= (ws-opcode ws) #.(opcode :continuation))) 171 | (setf (ws-mode ws) nil)) 172 | 173 | (unless (= i end) 174 | (go parsing-first-byte))))) 175 | end 176 | (return-from parser i))))) 177 | -------------------------------------------------------------------------------- /src/payload.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage fast-websocket.payload 3 | (:use :cl) 4 | (:import-from :fast-io 5 | #:fast-write-byte) 6 | (:import-from :alexandria 7 | #:once-only 8 | #:with-gensyms) 9 | (:export #:fast-write-masked-sequence 10 | #:mask-message)) 11 | (in-package :fast-websocket.payload) 12 | 13 | (defun mask-byte (byte mask-key) 14 | (logxor byte mask-key)) 15 | 16 | (defvar *mask-key-indices* 17 | (let ((indices (list 0 1 2 3))) 18 | (rplacd (last indices) indices) 19 | indices)) 20 | 21 | (defmacro with-masking ((byte data &key start end mask-keys (i (gensym "I"))) &body body) 22 | (once-only (data mask-keys start end) 23 | (with-gensyms (next-mask-index) 24 | `(do ((,i (or ,start 0) (1+ ,i)) 25 | (,next-mask-index *mask-key-indices* (cdr ,next-mask-index))) 26 | ((= ,i (or ,end (length ,data))) 27 | ,data) 28 | (let ((,byte (mask-byte (aref ,data ,i) (aref ,mask-keys (car ,next-mask-index))))) 29 | ,@body))))) 30 | 31 | (defun fast-write-masked-sequence (data output-buffer mask-keys &optional start end) 32 | (with-masking (byte data :start start :end end :mask-keys mask-keys) 33 | (fast-write-byte byte output-buffer))) 34 | 35 | (defun mask-message (data mask-keys &optional (start 0) (end (length data))) 36 | (with-masking (byte data :start start :end end :i i :mask-keys mask-keys) 37 | (setf (aref data i) byte))) 38 | -------------------------------------------------------------------------------- /src/ws.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage fast-websocket.ws 3 | (:use :cl) 4 | (:export #:ws 5 | #:make-ws 6 | #:ws-fin 7 | #:ws-opcode 8 | #:ws-mask 9 | #:ws-masking-key 10 | #:ws-length 11 | #:ws-length-size 12 | #:ws-mode 13 | #:ws-stage)) 14 | (in-package :fast-websocket.ws) 15 | 16 | (defstruct ws 17 | (fin nil :type boolean) 18 | (opcode -1 :type fixnum) 19 | (mask nil :type boolean) 20 | (masking-key (make-array 4 :element-type '(unsigned-byte 8)) 21 | :type (simple-array (unsigned-byte 8) (4))) 22 | (length 0 :type integer) 23 | 24 | (length-size 0 :type fixnum) 25 | (mode nil :type symbol) 26 | 27 | (stage 0 :type fixnum)) 28 | -------------------------------------------------------------------------------- /t/benchmark.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage fast-websocket-test.benchmark 3 | (:use :cl 4 | :fast-websocket 5 | :fast-websocket.parser) 6 | (:export :run-ll-benchmark)) 7 | (in-package :fast-websocket-test.benchmark) 8 | 9 | (defvar *masked* 10 | (coerce #(#x81 #x85 #x37 #xfa #x21 #x3d #x7f #x9f #x4d #x51 #x58) 11 | '(simple-array (unsigned-byte 8) (*)))) 12 | 13 | (defun run-ll-benchmark () 14 | (let* ((ws (make-ws)) 15 | (parser (make-ll-parser ws 16 | :require-masking t 17 | :payload-callback (lambda (data &key start end) 18 | (declare (ignore data start end)))))) 19 | (time 20 | (dotimes (i 100000) 21 | (funcall parser *masked*))))) 22 | -------------------------------------------------------------------------------- /t/compose.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage fast-websocket-test.compose 3 | (:use :cl 4 | :fast-websocket.compose 5 | :fast-websocket-test.util 6 | :trivial-utf-8 7 | :prove) 8 | (:import-from :fast-websocket.compose 9 | #:random-mask-keys) 10 | (:import-from :fast-websocket 11 | #:error-code)) 12 | (in-package :fast-websocket-test.compose) 13 | 14 | (plan 6) 15 | 16 | (subtest "string" 17 | (is (compose-frame "hi") #(129 2 104 105) :test #'equalp) 18 | (is (compose-frame "hi" :type :text) #(129 2 104 105) :test #'equalp) 19 | (is (compose-frame "hi" :type :binary) #(130 2 104 105) :test #'equalp)) 20 | 21 | (subtest "octets" 22 | (is (compose-frame (string-to-utf-8-bytes "hi")) #(130 2 104 105) :test #'equalp) 23 | (is (compose-frame (string-to-utf-8-bytes "hi") :type :binary) #(130 2 104 105) :test #'equalp) 24 | (is (compose-frame (string-to-utf-8-bytes "hi") :type :text) #(129 2 104 105) :test #'equalp)) 25 | 26 | (subtest "close" 27 | (is (compose-frame "bye" :type :close :code (error-code :normal-closure)) 28 | #(136 5 3 232 98 121 101) 29 | :test #'equalp) 30 | (is (compose-frame "bye" :type :close) 31 | #(136 5 3 232 98 121 101) 32 | :test #'equalp 33 | ":code is missing. The default status code is :normal-closure")) 34 | 35 | (subtest "length > 125 / length > 65535" 36 | (flet ((xxx-frame-len (count) 37 | (length (compose-frame 38 | (with-output-to-string (out) 39 | (dotimes (i count) 40 | (write-char #\x out))))))) 41 | (is (xxx-frame-len 124) 126) 42 | (is (xxx-frame-len 125) 127) 43 | (is (xxx-frame-len 126) 130) 44 | (is (xxx-frame-len 65534) 65538) 45 | (is (xxx-frame-len 65535) 65539) 46 | (is (xxx-frame-len 65536) 65546))) 47 | 48 | (defun constant-random-mask-keys () 49 | (bv 186 43 99 37)) 50 | 51 | #-ecl 52 | (subtest "masking" 53 | (let ((original #'fast-websocket.compose::random-mask-keys)) 54 | (setf (fdefinition 'fast-websocket.compose::random-mask-keys) 55 | #'constant-random-mask-keys) 56 | 57 | (is (compose-frame "hi" :masking t) 58 | #(129 130 186 43 99 37 210 66) 59 | :test #'equalp) 60 | 61 | (is (compose-frame "bye" 62 | :type :close 63 | :code (error-code :normal-closure) 64 | :masking t) 65 | #(136 133 186 43 99 37 185 195 1 92 223) 66 | :test #'equalp) 67 | 68 | (setf (fdefinition 'fast-websocket.compose::random-mask-keys) 69 | original))) 70 | #+ecl 71 | (skip 1 "because replacing a function doesn't work on ECL") 72 | 73 | (subtest "random-mask-keys" 74 | (is-type (random-mask-keys) '(simple-array (unsigned-byte 8) (4)) 75 | "mask keys must be simple octets (4 length)") 76 | (isnt (random-mask-keys) (random-mask-keys) 77 | :test #'equalp 78 | "mask keys must be different every time")) 79 | 80 | (finalize) 81 | -------------------------------------------------------------------------------- /t/fast-websocket.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage fast-websocket-test 3 | (:use :cl 4 | :fast-websocket 5 | :fast-websocket.constants 6 | :fast-websocket.error 7 | :fast-websocket-test.util 8 | :trivial-utf-8 9 | :prove)) 10 | (in-package :fast-websocket-test) 11 | 12 | (plan 7) 13 | 14 | (defvar *frame* 15 | (bv #x81 #x05 #x48 #x65 #x6c #x6c #x6f)) 16 | 17 | (let ((ws (make-ws))) 18 | (is-type (make-parser ws) 'function 19 | "Can create a parser")) 20 | 21 | (subtest ":text frame" 22 | (let* ((ws (make-ws)) 23 | (body (make-string-output-stream)) 24 | (parser (make-parser ws 25 | :require-masking nil 26 | :message-callback 27 | (lambda (message) 28 | (princ message body))))) 29 | (funcall parser *frame*) 30 | (is (ws-stage ws) 0 "frame ended") 31 | (is (get-output-stream-string body) "Hello"))) 32 | 33 | (subtest "fragmented :text frames" 34 | (let* ((ws (make-ws)) 35 | (body (make-string-output-stream)) 36 | (parser (make-parser ws 37 | :require-masking nil 38 | :message-callback 39 | (lambda (message) 40 | (princ message body))))) 41 | (funcall parser (bv #x01 #x03 #x48 #x65 #x6c)) 42 | (is (ws-stage ws) 0 "1st frame ended") 43 | (funcall parser (bv #x80 #x02 #x6c #x6f)) 44 | (is (ws-stage ws) 0 "2nd frame ended") 45 | (is (get-output-stream-string body) "Hello"))) 46 | 47 | (subtest ":binary frame" 48 | (let* ((ws (make-ws)) 49 | (body (make-string-output-stream)) 50 | (parser (make-parser ws 51 | :require-masking nil 52 | :message-callback 53 | (lambda (message) 54 | (princ message body))))) 55 | (funcall parser (bv 130 15 227 129 147 227 130 147 227 129 171 227 129 161 227 129 175)) 56 | (is (opcode-name (ws-opcode ws)) :binary) 57 | (is (get-output-stream-string body) 58 | (princ-to-string (string-to-utf-8-bytes "こんにちは"))))) 59 | 60 | (subtest ":close frame" 61 | (let* ((ws (make-ws)) 62 | got-code 63 | reason 64 | (parser (make-parser ws 65 | :require-masking nil 66 | :close-callback 67 | (lambda (message &key code) 68 | (setq got-code code) 69 | (setq reason message))))) 70 | (funcall parser (bv 136 5 3 232 98 121 101)) 71 | (is (opcode-name (ws-opcode ws)) :close) 72 | (is reason "bye") 73 | (is (error-code-name got-code) :normal-closure))) 74 | 75 | 76 | (subtest "masked :close frame" 77 | (let* ((ws (make-ws)) 78 | got-code 79 | reason 80 | (parser (make-parser ws 81 | :require-masking t 82 | :close-callback 83 | (lambda (message &key code) 84 | (setq got-code code) 85 | (setq reason message))))) 86 | (funcall parser (bv 136 133 10 11 12 13 9 227 110 116 111)) 87 | (is (opcode-name (ws-opcode ws)) :close) 88 | (is reason "bye") 89 | (is (error-code-name got-code) :normal-closure))) 90 | 91 | 92 | (subtest ":ping frame" 93 | (let* ((ws (make-ws)) 94 | (body (make-string-output-stream)) 95 | (parser (make-parser ws 96 | :require-masking nil 97 | :ping-callback 98 | (lambda (payload) 99 | (princ (utf-8-bytes-to-string payload) body))))) 100 | (funcall parser (bv 137 0)) 101 | (is (opcode-name (ws-opcode ws)) :ping) 102 | (is (get-output-stream-string body) "") 103 | 104 | (funcall parser (bv 137 2 104 105)) 105 | (is (opcode-name (ws-opcode ws)) :ping) 106 | (is (get-output-stream-string body) "hi")) 107 | 108 | (let* ((ws (make-ws)) 109 | (body (make-string-output-stream)) 110 | (parser (make-parser ws 111 | :require-masking t 112 | :ping-callback 113 | (lambda (payload) 114 | (princ (utf-8-bytes-to-string payload) body))))) 115 | (funcall parser (bv 137 128 230 106 10 164)) 116 | (is (opcode-name (ws-opcode ws)) :ping) 117 | (is (get-output-stream-string body) "") 118 | 119 | (funcall parser (bv 137 130 52 60 46 27 92 85)) 120 | (is (opcode-name (ws-opcode ws)) :ping) 121 | (is (get-output-stream-string body) "hi"))) 122 | 123 | (subtest ":pong frame" 124 | (let* ((ws (make-ws)) 125 | (body (make-string-output-stream)) 126 | (parser (make-parser ws 127 | :require-masking nil 128 | :pong-callback 129 | (lambda (payload) 130 | (princ (utf-8-bytes-to-string payload) body))))) 131 | (funcall parser (bv 138 0)) 132 | (is (opcode-name (ws-opcode ws)) :pong) 133 | (is (get-output-stream-string body) "") 134 | 135 | (funcall parser (bv 138 2 104 105)) 136 | (is (opcode-name (ws-opcode ws)) :pong) 137 | (is (get-output-stream-string body) "hi")) 138 | 139 | (let* ((ws (make-ws)) 140 | (body (make-string-output-stream)) 141 | (parser (make-parser ws 142 | :require-masking t 143 | :pong-callback 144 | (lambda (payload) 145 | (princ (utf-8-bytes-to-string payload) body))))) 146 | (funcall parser (bv 138 128 111 74 3 218)) 147 | (is (opcode-name (ws-opcode ws)) :pong) 148 | (is (get-output-stream-string body) "") 149 | 150 | (funcall parser (bv 138 130 149 39 57 220 253 78)) 151 | (is (opcode-name (ws-opcode ws)) :pong) 152 | (is (get-output-stream-string body) "hi"))) 153 | 154 | (finalize) 155 | -------------------------------------------------------------------------------- /t/parser.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage fast-websocket-test.parser 3 | (:use :cl 4 | :fast-websocket.constants 5 | :fast-websocket.parser 6 | :fast-websocket.ws 7 | :fast-websocket.error 8 | :fast-websocket-test.util 9 | :trivial-utf-8 10 | :prove)) 11 | (in-package :fast-websocket-test.parser) 12 | 13 | (plan 7) 14 | 15 | (defvar *masked* 16 | (bv #x81 #x85 #x37 #xfa #x21 #x3d #x7f #x9f #x4d #x51 #x58)) 17 | 18 | (defvar *not-masked* 19 | (bv #x81 #x05 #x48 #x65 #x6c #x6c #x6f)) 20 | 21 | (subtest "basic" 22 | (let ((ws (make-ws))) 23 | (is-type (make-ll-parser ws) 'function 24 | "Can create a low-level parser") 25 | (is-type (make-ll-parser ws :require-masking t) 'function 26 | "Can create a low-level parser with :require-masking t") 27 | (let ((parser (make-ll-parser ws :require-masking t))) 28 | (is (funcall parser (bv)) 0) 29 | (is (funcall parser *masked*) (length *masked*))))) 30 | 31 | (subtest ":require-masking" 32 | (let* ((ws (make-ws)) 33 | (mask-parser (make-ll-parser ws :require-masking t))) 34 | (is (funcall mask-parser *masked*) (length *masked*) 35 | "Can parse masked frame") 36 | (is (ws-stage ws) 0 "Parse ended") 37 | (is-error (funcall mask-parser *not-masked*) 38 | 'unacceptable 39 | "Raise UNACCEPTABLE (:require-masking t)")) 40 | 41 | (let* ((ws (make-ws)) 42 | (unmask-parser (make-ll-parser ws :require-masking nil))) 43 | (is (funcall unmask-parser *not-masked*) (length *not-masked*) 44 | "Can parse unmasked frame") 45 | (is (ws-stage ws) 0 "Parse ended") 46 | (is-error (funcall unmask-parser *masked*) 47 | 'unacceptable 48 | "Raise UNACCEPTABLE (:require-masking nil)"))) 49 | 50 | (subtest "Hello" 51 | (let* ((ws (make-ws)) 52 | body 53 | (parser (make-ll-parser ws 54 | :require-masking nil 55 | :payload-callback 56 | (lambda (data &key start end) 57 | (setf body (subseq data start end)))))) 58 | (funcall parser *not-masked*) 59 | (is (ws-stage ws) 0) 60 | (is (utf-8-bytes-to-string body) "Hello"))) 61 | 62 | (subtest "incomplete frames" 63 | (let* ((ws (make-ws)) 64 | (parser (make-ll-parser ws 65 | :require-masking nil))) 66 | (funcall parser (subseq *not-masked* 0 1)) 67 | (is (ws-stage ws) 1) 68 | (funcall parser (subseq *not-masked* 1 2)) 69 | (is (ws-stage ws) 4)) 70 | 71 | (let* ((ws (make-ws)) 72 | (parser (make-ll-parser ws 73 | :require-masking t))) 74 | ;; first byte 75 | (funcall parser (subseq *masked* 0 1)) 76 | (is (ws-stage ws) 1) 77 | ;; second byte 78 | (funcall parser (subseq *masked* 1 2)) 79 | (is (ws-stage ws) 3) 80 | ;; masking-key 81 | (is (funcall parser (subseq *masked* 2 3)) 0 82 | "EOF") 83 | (is (ws-stage ws) 3) 84 | (funcall parser (subseq *masked* 2 6)) 85 | (is (ws-stage ws) 4) 86 | (is (ws-masking-key ws) #(55 250 33 61) :test #'equalp) 87 | ;; payload 88 | (is (funcall parser (subseq *masked* 6 8)) 2) 89 | (is (ws-stage ws) 4) 90 | (is (funcall parser (subseq *masked* 8)) 3) 91 | (is (ws-stage ws) 0))) 92 | 93 | (subtest "fragmented frames" 94 | (let* ((ws (make-ws)) 95 | (body (make-string-output-stream)) 96 | (parser (make-ll-parser ws 97 | :require-masking nil 98 | :payload-callback 99 | (lambda (data &key start end) 100 | (princ (utf-8-bytes-to-string data :start start :end end) body))))) 101 | (funcall parser (bv #x01 #x03 #x48 #x65 #x6c)) 102 | (is (ws-stage ws) 0 "1st frame ended") 103 | (is (ws-fin ws) nil "not the last frame") 104 | (is (opcode-name (ws-opcode ws)) :text "opcode is :text") 105 | 106 | (funcall parser (bv #x80 #x02 #x6c #x6f)) 107 | (is (ws-stage ws) 0 "2nd frame ended") 108 | (is (ws-fin ws) t "the last frame") 109 | (is (opcode-name (ws-opcode ws)) :continuation "opcode is :continuation") 110 | (is (get-output-stream-string body) "Hello" "body is \"Hello\""))) 111 | 112 | (subtest "ping" 113 | (let* ((ws (make-ws)) 114 | body 115 | (parser (make-ll-parser ws 116 | :require-masking nil 117 | :payload-callback 118 | (lambda (data &key start end) 119 | (setf body (subseq data start end)))))) 120 | (funcall parser (bv #x89 #x05 #x48 #x65 #x6c #x6c #x6f)) 121 | (is (ws-stage ws) 0 "frame ended") 122 | (is (ws-fin ws) t) 123 | (is (opcode-name (ws-opcode ws)) :ping) 124 | (is (utf-8-bytes-to-string body) "Hello"))) 125 | 126 | (subtest "close" 127 | (let* ((ws (make-ws)) 128 | body 129 | (parser (make-ll-parser ws 130 | :require-masking nil 131 | :payload-callback 132 | (lambda (data &key start end) 133 | (setf body (subseq data start end)))))) 134 | (funcall parser (bv 136 5 3 232 98 121 101)) 135 | (is body #(3 232 98 121 101) :test #'equalp) 136 | (is (utf-8-bytes-to-string body :start 2) "bye"))) 137 | 138 | (finalize) 139 | -------------------------------------------------------------------------------- /t/payload.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage fast-websocket-test.payload 3 | (:use :cl 4 | :fast-websocket.payload 5 | :fast-websocket-test.util 6 | :trivial-utf-8 7 | :prove)) 8 | (in-package :fast-websocket-test.payload) 9 | 10 | (plan 3) 11 | 12 | (defvar *mask-keys* 13 | (bv 92 246 238 121)) 14 | 15 | (is (mask-message (string-to-utf-8-bytes "Hello") 16 | *mask-keys*) 17 | #(20 147 130 21 51) 18 | :test #'equalp 19 | "mask-message") 20 | 21 | (is (fast-io:with-fast-output (buffer) 22 | (fast-write-masked-sequence (string-to-utf-8-bytes "Hello") buffer *mask-keys*)) 23 | #(20 147 130 21 51) 24 | :test #'equalp 25 | "fast-write-masked-sequence") 26 | 27 | (is-print (fast-websocket.payload::with-masking (byte (string-to-utf-8-bytes "Hello") :mask-keys *mask-keys*) 28 | (format t "~A~%" byte)) 29 | "20 30 | 147 31 | 130 32 | 21 33 | 51 34 | " 35 | "with-masking") 36 | 37 | (finalize) 38 | -------------------------------------------------------------------------------- /t/util.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage fast-websocket-test.util 3 | (:use :cl) 4 | (:export :bv)) 5 | (in-package :fast-websocket-test.util) 6 | 7 | (defun bv (&rest args) 8 | (make-array (length args) :element-type '(unsigned-byte 8) :initial-contents args)) 9 | --------------------------------------------------------------------------------