Permalink
Browse files

Add clack-socket implementation for Hunchentoot handler.

  • Loading branch information...
1 parent dfd1b85 commit 306457e11696bd87da07c96ae4cef4de5d69fa49 @fukamachi committed Feb 11, 2017
Showing with 81 additions and 4 deletions.
  1. +1 −0 clack-handler-hunchentoot.asd
  2. +73 −1 src/handler/hunchentoot.lisp
  3. +7 −3 src/socket.lisp
@@ -22,6 +22,7 @@
:author "Eitaro Fukamachi"
:license "LLGPL"
:depends-on (:hunchentoot
+ :clack-socket
:flexi-streams
:bordeaux-threads
:split-sequence
@@ -17,6 +17,17 @@
(:export :run))
(in-package :clack.handler.hunchentoot)
+(defvar *client-socket*)
+
+(defclass client ()
+ ((stream :initarg :stream
+ :reader client-stream)
+ (socket :initarg :socket
+ :reader client-socket)
+ (read-callback :initarg :read-callback
+ :initform nil
+ :accessor client-read-callback)))
+
(defun initialize ()
(setf *hunchentoot-default-external-format*
(flex:make-external-format :utf-8 :eol-style :lf)
@@ -54,7 +65,8 @@
(defmethod hunchentoot:process-connection :around ((acceptor clack-acceptor) socket)
(let ((flex:*substitution-char* #-abcl #\Replacement_Character
- #+abcl #\?))
+ #+abcl #\?)
+ (*client-socket* socket))
(call-next-method)))
(defun run (app &rest args
@@ -189,10 +201,70 @@ before passing to Clack application."
(parse-integer content-length :junk-allowed t))
:content-type (header-in* :content-type req)
:clack.streaming t
+ :clack.io (make-instance 'client
+ :socket *client-socket*
+ :stream (hunchentoot::content-stream req))
:headers (loop with headers = (make-hash-table :test 'equal)
for (k . v) in (hunchentoot:headers-in* req)
unless (or (eq k :content-length)
(eq k :content-type))
do (setf (gethash (string-downcase k) headers) v)
finally (return headers)))))
+
+(defmethod clack.socket:set-read-callback ((client client) callback)
+ (setf (client-read-callback client) callback))
+
+(defmethod clack.socket:write-sequence-to-socket ((client client) data &key callback)
+ (let ((stream (client-stream client)))
+ (write-sequence data stream)
+ (force-output stream))
+ (when callback
+ (funcall callback)))
+
+(defmethod clack.socket:close-socket ((client client))
+ (finish-output (client-stream client)))
+
+(defmethod clack.socket:flush-socket-buffer ((client client) &key callback)
+ (force-output (client-stream client))
+ (when callback
+ (funcall callback)))
+
+(defmethod clack.socket:start-connection ((client client))
+ (hunchentoot::set-timeouts (client-socket client) 300 300)
+ (let ((stream (client-stream client))
+ (buf (make-array 2 :element-type '(unsigned-byte 8)))
+ (extended-buf (make-array 8 :element-type '(unsigned-byte 8))))
+ (tagbody retry
+ (loop for read-bytes = (handler-case (read-sequence buf stream)
+ (error ()
+ ;; Retry when I/O timeout error
+ (go retry)))
+ while (/= read-bytes 0)
+ for maskp = (plusp (ldb (byte 1 7) (aref buf 1)))
+ for data-length = (ldb (byte 7 0) (aref buf 1))
+ do (cond
+ ((<= 0 data-length 125))
+ (t
+ (let ((end (if (= data-length 126) 2 8)))
+ (read-sequence extended-buf stream :end end)
+ (incf read-bytes end)
+ (setf data-length
+ (loop with length = 0
+ for i from 0 to end
+ do (incf length (+ (ash length 8) (aref extended-buf i)))
+ finally (return length))))))
+ (when maskp
+ (incf data-length 4))
+ (let ((data (make-array (+ read-bytes data-length) :element-type '(unsigned-byte 8))))
+ (replace data buf :end2 2)
+ (unless (= read-bytes 2)
+ (replace data extended-buf :start1 2 :end2 (- read-bytes 2)))
+ (handler-case
+ (read-sequence data stream :start read-bytes)
+ (error (e)
+ ;; I/O timeout. Maybe the connection has been lost
+ (warn "~A" e)
+ (return)))
+ (funcall (client-read-callback client) data))))
+ (clack.socket:close-socket client)))
View
@@ -7,7 +7,8 @@
:write-byte-to-socket
:write-sequence-to-socket-buffer
:write-byte-to-socket-buffer
- :flush-socket-buffer))
+ :flush-socket-buffer
+ :start-connection))
(in-package :clack.socket)
;; required
@@ -17,8 +18,7 @@
(defgeneric close-socket (socket))
;; required.
-(defgeneric write-sequence-to-socket (socket data &key callback)
- (:method (socket data &key callback)))
+(defgeneric write-sequence-to-socket (socket data &key callback))
;; optional. fallback to write-sequence-to-socket
(defgeneric write-byte-to-socket (socket byte &key callback)
@@ -44,3 +44,7 @@
(write-sequence-to-socket socket
#.(make-array 0 :element-type '(unsigned-byte 8))
:callback callback)))
+
+;; optional
+(defgeneric start-connection (socket)
+ (:method (socket)))

0 comments on commit 306457e

Please sign in to comment.