cl-websocket/cl-websocket.lisp at master · wisesimpson/cl-websocket · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
;;;; cl-websocket.lisp
;;;; Copyright (c) 2012, Rob Blackwell.  All rights reserved.

(defpackage #:cl-websocket
  (:use #:cl)
  (:export
   #:send-frame
   #:receive-frame
   #:server-handshake))

(in-package #:cl-websocket)

(defvar +crlf+ (coerce '(#\return #\linefeed) 'string))

;; Define a protocol for sending and receiving WebSocket frames.

(defgeneric send-frame (stream data)
  (:documentation "Sends data to a websocket using the appropriate framing."))

(defgeneric receive-frame (stream)
  (:documentation "Receives a frame from a websocket and returns the de-framed data."))

;; .. and a default implementation for arbitrary streams.

(defun write-uint16 (int stream)
  ""
  (write-byte (div int 256) stream)
  (write-byte (truncate int 256) stream))


(defmethod send-frame (stream (message string))
  (write-byte #x81 stream) ;; Final fragment, text frame.

  (let ((message-octets (babel:string-to-octets message :encoding :utf-8)))
    (if (<= (length message-octets) 125)
        (write-byte (length message-octets) stream)
        (progn ;need to change
          (write-byte 126 stream)
          (write-uint16 (length message) stream)))

    (write-sequence message-octets stream))
  (force-output stream))

(defmethod receive-frame ((stream t))
  (let ((b0 (read-byte stream nil :eof)))
    (if (eq :eof b0)
        (return-from receive-frame :eof)
        (let* ((b1 (read-byte stream))
               (fin (> (logand b0 #x80) 0))
               (opcode (logand b0 #x0F))
               (mask (> (logand b1 #x80) 0))
               (len (logand b1 #x7F))
               (payload (make-array len :initial-element '(unsigned-byte 8))))

          ;; A server MUST close the connection upon receiving a frame with
          ;; the MASK bit set to 0.
          (unless mask
            (close stream)
            (return-from receive-frame nil))

          ;; Sorry only short messages currently supported
          (when (> len 125)
            (close stream)
            (return-from receive-frame nil))

          ;; TODO Support longer message types

          (setf mask (list (read-byte stream)
                           (read-byte stream)
                           (read-byte stream)
                           (read-byte stream)))

          (read-sequence payload stream)

          (dotimes (i len)
            (setf (aref payload i) (logxor (aref payload i) (nth (mod i 4)  mask))))

          (if (eq opcode #x01) ;; string?
              (babel:octets-to-string (coerce payload '(simple-array (unsigned-byte 8))) :encoding :utf-8)
              payload)))))

;; TODO: consider implementing binary frames, connection-close, ping
;; and pong.

(defun parse-headers (client-handshake)
  "Parses the websocket request client handshake (which looks like
HTTP) and extracts the headers as an alist of header names and
values."
  (let ((headers (car (cl-ppcre:split (concatenate 'string +crlf+ +crlf+) client-handshake))))
    (loop for string in (cl-ppcre:split +crlf+ headers)
       collect (cl-ppcre:split #\Space string :limit 2))))

(defun compute-acceptance (nonce)
  "Concatenates the client nonce with a magic string as per RFC6455,
signs it with SHA1 and returns the resulting signature base64
encoded."
  (let ((string-to-sign (concatenate 'string nonce "258EAFA5-E914-47DA-95CA-C5AB0DC85B11")))
    (cl-base64:usb8-array-to-base64-string
     (ironclad:digest-sequence
      :sha1
      (ironclad:ascii-string-to-byte-array string-to-sign)))))

(defun server-handshake (client-handshake)
  "Constructs a server handshake corresponding to the given client
handshake as per RFC6455."
  (let* ((headers (parse-headers client-handshake))
         (nonce (second (assoc "Sec-WebSocket-Key:" headers :test #'string=))))

    ;; Ignore Sec-WebSocket-Version, but we only support 13 at the time of writing.
    ;; Ignore Sec-WebSocket-Extensions.
    ;; Ignore Sec-WebSocket-Protocol.

    (concatenate 'string
                 "HTTP/1.1 101 Switching Protocols" +crlf+
                 "Upgrade: websocket" +crlf+
                 "Connection: Upgrade" +crlf+
                 "Sec-WebSocket-Accept: " (compute-acceptance nonce) +crlf+
                 +crlf+)))