snmsts · August 23, 2014 18:04
diff --git a/clack.websocket.lisp b/clack.websocket.lisp
 (ql:quickload '(:clack :cl-async))

 (defpackage websocket.test
  (:use :cl
 	:clack))

 (in-package :websocket.test)

 (defvar *handler*
  (clackup
   (lambda (env)
     (lambda (f)
       (cond
 	 ((string= "/s" (getf env :request-uri))
 	  (let ((accept (let ((k (getf env :http-sec-websocket-key))
 			      (o7-guid "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"))
 			  (cl-base64:usb8-array-to-base64-string
 			   (ironclad:digest-sequence
 			    :sha1 (map '(vector (unsigned-byte 8)) #'char-code
 				       (concatenate 'string k o7-guid)))))))
 	    #+nil(funcall f `(101 (:upgrade "websocket"
 					    :connection "Upgrade"
 					    "Sec-WebSocket-Accept" ,accept))) ;; I can't cancel chunked encoding
 	    (as:write-socket-data
 	     (getf env :clack.io)
 	     (babel:string-to-octets (format nil "HTTP/1.1 101 Switching Protocols
 Upgrade: websocket
 Connection: Upgrade
 Sec-Websocket-Accept: ~A

 " accept))
 	     :read-cb (lambda (socket data)
 			(let* ((offset 2)
 			       fin mask
 			       (opcode (aref data 0))
 			       (payloadlen (aref data 1)))
 			  (setq fin (not (zerop (logand #x80 opcode)))
 				opcode (logand #x0f opcode)
 				mask (not (zerop (logand #x80 payloadlen)))
 				payloadlen (logand #x7f payloadlen)
 				payloadlen (if (<= 126 payloadlen)
 					       (+ (if (= payloadlen 127)
 						      (+ (ash (prog1 (aref data offset)
 								(incf offset)) 24)
 							 (ash (prog1 (aref data offset)
 								(incf offset)) 16)) 0)
 						  (ash (prog1 (aref data offset)
 							 (incf offset)) 8)
 						  (prog1 (aref data offset)
 						    (incf offset)))
 					       payloadlen))
 			  (when mask
 			    (setq mask (make-array 4 :element-type '(unsigned-byte 8) :initial-contents
 						   (loop :repeat 4 :collect (prog1 (aref data offset)
 									      (incf offset))))))
 			  (let ((ar (subseq data offset)
 				  #+nil(make-array payloadlen :element-type '(unsigned-byte 8))))
 			    (when mask
 			      (loop :for i :from 0
 				 :for v :across ar
 				 :do (setf (aref ar i) (logxor v (aref mask (mod i 4))))))
 			    (when (= 1 opcode) 
 			      '(setf ar (babel:octets-to-string ar :encoding :utf-8)))
 			    (case opcode ;;forget opcode
 			      ((#x1 #x2 #xA)
 			       (let* ((octets ar)
 				      (len (length octets)))
 				 (as:write-socket-data
 				  socket
 				  (flexi-streams:with-output-to-sequence (out)
 				    (write-byte (+ (if fin #x80 0) (logand opcode #xf)) out)
 				    (if (> 126 len) (write-byte len out)
 					(let ((4byte (<= (ash 1 16) len)))
 					  (write-byte (if 4byte 127 126) out)
 					  (when 4byte
 					    (write-byte (ash len -24) out)
 					    (write-byte (logand (ash len -16) #xff) out))
 					  (write-byte (logand (ash len -8) #xff) out)
 					  (write-byte (logand len #xff) out)))
 				    (write-sequence octets out)))))
 			      ((#x8)
 			       ;;(close-connection% stream  nil nil)
 			       )
 			      ((#x9)))))))))
 	 (t
 	  (funcall f `(200 (:content-type "text/html")
 			   ("<html>
  <head>
    <script>
      function c() {
      a=new WebSocket(\"ws://localhost:5000/s\");
      a.onmessage=function(evt){console.log(evt.data)}
      }
      function s() {
      a.send(\"hoge*\")
      }
    </script>
  </head>
  <body>
    hoge
  </body>
 </html>
 ")))))))
   :server :wookie))

 ;;(clack:stop *handler*)

 #+debug
 (progn 
  (ql:quickload :usocket)
  (usocket:with-client-socket (sock stream "localhost" 5000)
  (format stream "GET /s HTTP/1.1~A~A" #\cr #\lf)
  (format stream "Host: localhost:5000~A~A" #\cr #\lf)
  (format stream "~A~A" #\cr #\lf)

  (force-output stream)
  #+nil(print (list (read-line stream)
 	(read-line stream)
 	(read-line stream)
 	(read-line stream)))
  (loop :while t
     :do (print (read-char stream))
 	)))
	(ql:quickload '(:clack :cl-async))

	(defpackage websocket.test
	(:use :cl
	:clack))

	(in-package :websocket.test)

	(defvar handler
	(clackup
	(lambda (env)
	(lambda (f)
	(cond
	((string= "/s" (getf env :request-uri))
	(let ((accept (let ((k (getf env :http-sec-websocket-key))
	(o7-guid "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"))
	(cl-base64:usb8-array-to-base64-string
	(ironclad:digest-sequence
	:sha1 (map '(vector (unsigned-byte 8)) #'char-code
	(concatenate 'string k o7-guid)))))))
	#+nil(funcall f `(101 (:upgrade "websocket"
	:connection "Upgrade"
	"Sec-WebSocket-Accept" ,accept))) ;; I can't cancel chunked encoding
	(as:write-socket-data
	(getf env :clack.io)
	(babel:string-to-octets (format nil "HTTP/1.1 101 Switching Protocols
	Upgrade: websocket
	Connection: Upgrade
	Sec-Websocket-Accept: ~A

	" accept))
	:read-cb (lambda (socket data)
	(let* ((offset 2)
	fin mask
	(opcode (aref data 0))
	(payloadlen (aref data 1)))
	(setq fin (not (zerop (logand #x80 opcode)))
	opcode (logand #x0f opcode)
	mask (not (zerop (logand #x80 payloadlen)))
	payloadlen (logand #x7f payloadlen)
	payloadlen (if (<= 126 payloadlen)
	(+ (if (= payloadlen 127)
	(+ (ash (prog1 (aref data offset)
	(incf offset)) 24)
	(ash (prog1 (aref data offset)
	(incf offset)) 16)) 0)
	(ash (prog1 (aref data offset)
	(incf offset)) 8)
	(prog1 (aref data offset)
	(incf offset)))
	payloadlen))
	(when mask
	(setq mask (make-array 4 :element-type '(unsigned-byte 8) :initial-contents
	(loop :repeat 4 :collect (prog1 (aref data offset)
	(incf offset))))))
	(let ((ar (subseq data offset)
	#+nil(make-array payloadlen :element-type '(unsigned-byte 8))))
	(when mask
	(loop :for i :from 0
	:for v :across ar
	:do (setf (aref ar i) (logxor v (aref mask (mod i 4))))))
	(when (= 1 opcode)
	'(setf ar (babel:octets-to-string ar :encoding :utf-8)))
	(case opcode ;;forget opcode
	((#x1 #x2 #xA)
	(let* ((octets ar)
	(len (length octets)))
	(as:write-socket-data
	socket
	(flexi-streams:with-output-to-sequence (out)
	(write-byte (+ (if fin #x80 0) (logand opcode #xf)) out)
	(if (> 126 len) (write-byte len out)
	(let ((4byte (<= (ash 1 16) len)))
	(write-byte (if 4byte 127 126) out)
	(when 4byte
	(write-byte (ash len -24) out)
	(write-byte (logand (ash len -16) #xff) out))
	(write-byte (logand (ash len -8) #xff) out)
	(write-byte (logand len #xff) out)))
	(write-sequence octets out)))))
	((#x8)
	;;(close-connection% stream nil nil)
	)
	((#x9)))))))))
	(t
	(funcall f `(200 (:content-type "text/html")
	("<html>
	<head>
	<script>
	function c() {
	a=new WebSocket(\"ws://localhost:5000/s\");
	a.onmessage=function(evt){console.log(evt.data)}
	}
	function s() {
	a.send(\"hoge*\")
	}
	</script>
	</head>
	<body>
	hoge
	</body>
	</html>
	")))))))
	:server :wookie))

	;;(clack:stop handler)

	#+debug
	(progn
	(ql:quickload :usocket)
	(usocket:with-client-socket (sock stream "localhost" 5000)
	(format stream "GET /s HTTP/1.1~A~A" #\cr #\lf)
	(format stream "Host: localhost:5000~A~A" #\cr #\lf)
	(format stream "~A~A" #\cr #\lf)

	(force-output stream)
	#+nil(print (list (read-line stream)
	(read-line stream)
	(read-line stream)
	(read-line stream)))
	(loop :while t
	:do (print (read-char stream))
	)))