diff --git a/core/buffer-pool.lisp b/core/buffer-pool.lisp new file mode 100644 index 0000000..122e89f --- /dev/null +++ b/core/buffer-pool.lisp @@ -0,0 +1,270 @@ +;;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: http2/buffer-pool; Base: 10 -*- + +(in-package :http2/buffer-pool) + +(defsection @buffer-pool (:title "Global Buffer Pool for HTTP/2") + "Lock-free size-class pooling of octet buffers via CAS (Treiber +stack). Eliminates allocation in hot paths: frame reading, frame +writing, payload processing. + +One global pool shared by all connections. Buffers grow on demand +and recycle indefinitely. Max-free cap per size class prevents +unbounded growth after traffic spikes. + +Size classes: small (<=16), medium (<=1024), large (<=16384). +Oversized buffers are allocated directly and not pooled." + + (allocate-buffer function) + (deallocate-buffer function) + (with-pooled-buffer macro) + (buffer-pool-stats function) + (clear-buffer-pool function) + (@buffer-regions section) + (@cas section)) + +(defsection @cas (:title "CAS primitives") + "Lock-free atomic push/pop on a cons cell head pointer. + +Port-specific CAS with generic fallback." + (atomic-push function) + (atomic-pop function)) + +#+sbcl +(defmacro %cas (place old new) + "Atomic compare-and-swap. Returns true if swap succeeded." + `(eq (sb-ext:cas ,place ,old ,new) ,old)) + +#+lispworks +(defmacro %cas (place old new) + "Atomic compare-and-swap. Returns true if swap succeeded." + `(sys:compare-and-swap ,place ,old ,new)) + +#-(or sbcl lispworks) +(progn + (defvar *%cas-lock* + #+bordeaux-threads (bt:make-lock "cas-fallback") + #-bordeaux-threads nil + "Global lock for generic CAS fallback.") + + (defmacro %cas (place old new) + "Generic CAS fallback. Correct but serialized." + (let ((old-val (gensym)) (new-val (gensym))) + `(let ((,old-val ,old) (,new-val ,new)) + #+bordeaux-threads + (bt:with-lock-held (*%cas-lock*) + (cond ((eq ,place ,old-val) + (setf ,place ,new-val) + t) + (t nil))) + #-bordeaux-threads + (cond ((eq ,place ,old-val) + (setf ,place ,new-val) + t) + (t nil)))))) + +(defun atomic-push (value head-cons) + "Atomically push VALUE onto a list whose head is (CAR HEAD-CONS). +Lock-free via CAS (Treiber stack push)." + (declare (type cons head-cons)) + (let ((cell (cons value nil))) + (loop + (let ((old-head (car head-cons))) + (setf (cdr cell) old-head) + (when (%cas (car head-cons) old-head cell) + (return value)))))) + +(defun atomic-pop (head-cons) + "Atomically pop from a list whose head is (CAR HEAD-CONS). +Returns (VALUES element T) on success, (VALUES NIL NIL) if empty. +Lock-free via CAS (Treiber stack pop)." + (declare (type cons head-cons)) + (loop + (let ((old-head (car head-cons))) + (cond ((null old-head) + (return (values nil nil))) + ((%cas (car head-cons) old-head (cdr old-head)) + (return (values (car old-head) t))))))) + +;;;------------------------------------------------------------------- +;;; +;;; SIZE CLASSES +;;; + +(defconstant +small-size+ 16 + "Small buffers: frame headers (9 bytes), small control frames.") + +(defconstant +medium-size+ 1024 + "Medium buffers: HPACK encoded headers, small payloads.") + +(defconstant +large-size+ 16384 + "Large buffers: DATA/HEADERS payloads up to default max-frame-size.") + +(defconstant +max-free-small+ 64 + "Maximum free small buffers retained in pool.") + +(defconstant +max-free-medium+ 32 + "Maximum free medium buffers retained in pool.") + +(defconstant +max-free-large+ 32 + "Maximum free large buffers retained in pool.") + +;;;------------------------------------------------------------------- +;;; +;;; GLOBAL POOL +;;; +;;; Three size classes, each a lock-free Treiber stack. +;;; head-cons is a cons cell whose CAR points to the free list. +;;; free-count is approximate (not atomic) — used only for max-free cap. +;;; + +(defstruct (size-class (:conc-name sc-)) + "Lock-free free list of buffers at a fixed size." + (size 0 :type fixnum :read-only t) + (max-free 0 :type fixnum :read-only t) + (head-cons (list nil) :type cons :read-only t) + (free-count 0 :type fixnum) + (total-allocated 0 :type fixnum) + (total-recycled 0 :type fixnum)) + +(defvar *small-class* + (make-size-class :size +small-size+ :max-free +max-free-small+)) + +(defvar *medium-class* + (make-size-class :size +medium-size+ :max-free +max-free-medium+)) + +(defvar *large-class* + (make-size-class :size +large-size+ :max-free +max-free-large+)) + +(declaim (inline %select-class)) + +(defun %select-class (size) + "Select the size class for SIZE bytes, or NIL if oversized." + (declare (type fixnum size)) + (cond ((<= size +small-size+) *small-class*) + ((<= size +medium-size+) *medium-class*) + ((<= size +large-size+) *large-class*) + (t nil))) + +;;;------------------------------------------------------------------- +;;; +;;; ALLOCATE / DEALLOCATE +;;; + +(defun allocate-buffer (size) + "Allocate an octet buffer for at least SIZE bytes with fill-pointer +set to SIZE. Returns a pooled buffer if available, otherwise allocates +fresh. The fill-pointer controls (LENGTH buffer) so callers see exactly +the requested size regardless of the underlying size-class capacity. +Lock-free. Oversized buffers (>16384) are allocated directly." + (declare (type fixnum size)) + (let ((sc (%select-class size))) + (cond (sc + (multiple-value-bind (buf found-p) + (atomic-pop (sc-head-cons sc)) + (cond (found-p + (decf (sc-free-count sc)) + (incf (sc-total-recycled sc)) + (setf (fill-pointer buf) size) + buf) + (t + (incf (sc-total-allocated sc)) + (make-array (sc-size sc) + :element-type '(unsigned-byte 8) + :fill-pointer size))))) + (t (make-array size :element-type '(unsigned-byte 8) + :fill-pointer size))))) + +(defun deallocate-buffer (buffer) + "Return BUFFER to the global pool. Lock-free. +Resets fill-pointer to full capacity before pooling. +Oversized or excess buffers are dropped for GC." + (let* ((size (array-total-size buffer)) + (sc (%select-class size))) + (when (and sc + (= size (sc-size sc)) + (< (sc-free-count sc) (sc-max-free sc))) + (setf (fill-pointer buffer) size) + (atomic-push buffer (sc-head-cons sc)) + (incf (sc-free-count sc))) + (values))) + +(defmacro with-pooled-buffer ((var size) &body body) + "Bind VAR to a pooled octet buffer of at least SIZE bytes. +The buffer is returned to the global pool on exit via unwind-protect. +VAR may be larger than SIZE — use :end to delimit the active region." + (let ((buf-var (gensym "BUF"))) + `(let* ((,buf-var (allocate-buffer ,size)) + (,var ,buf-var)) + (unwind-protect + (progn ,@body) + (deallocate-buffer ,buf-var))))) + +(defsection @buffer-regions (:title "Buffer regions") + "Scope-based deallocation for buffers whose lifetime extends beyond +the immediate allocator. The caller manages buffers locally on the +hot path (zero tracking overhead). When a buffer escapes local +management (e.g., captured by a continuation closure), the caller +transfers deallocation responsibility to the region via +REGION-TRACK-BUFFER. On region exit, all tracked buffers are +returned to the pool." + (with-resource-usage-region macro) + (region-track-buffer function)) + +(defvar *current-buffer-region* nil + "Active buffer region tracking list, or NIL. +Bound per-thread by WITH-RESOURCE-USAGE-REGION.") + +(defmacro with-resource-usage-region (() &body body) + "Establish a buffer region. On exit (normal or abnormal), deallocate +all buffers that were transferred to the region via REGION-TRACK-BUFFER." + (let ((head-var (gensym "REGION-HEAD"))) + `(let* ((,head-var (list nil)) + (*current-buffer-region* ,head-var)) + (unwind-protect + (progn ,@body) + (%region-cleanup ,head-var))))) + +(defun region-track-buffer (buffer) + "Transfer deallocation responsibility for BUFFER to the active region. +The caller relinquishes ownership; the region will deallocate BUFFER +on exit. Safe to call when no region is active (no-op)." + (let ((region *current-buffer-region*)) + (when region + (push buffer (car region)))) + (values)) + +(defun %region-cleanup (head) + "Deallocate all buffers tracked by the region HEAD." + (declare (type cons head)) + (loop for buf in (car head) + do (deallocate-buffer buf)) + (setf (car head) nil) + (values)) + +;;;------------------------------------------------------------------- +;;; +;;; DIAGNOSTICS +;;; + +(defun buffer-pool-stats () + "Return a description of global pool utilization." + (flet ((class-stats (name sc) + (format nil "~A (~D bytes): ~D allocated, ~D recycled, ~D/~D free" + name (sc-size sc) + (sc-total-allocated sc) + (sc-total-recycled sc) + (sc-free-count sc) + (sc-max-free sc)))) + (format nil "~A~%~A~%~A" + (class-stats "Small" *small-class*) + (class-stats "Medium" *medium-class*) + (class-stats "Large" *large-class*)))) + +(defun clear-buffer-pool () + "Release all pooled buffers for GC and reset counters." + (dolist (sc (list *small-class* *medium-class* *large-class*)) + (setf (car (sc-head-cons sc)) nil + (sc-free-count sc) 0 + (sc-total-allocated sc) 0 + (sc-total-recycled sc) 0)) + (values)) diff --git a/core/classes.lisp b/core/classes.lisp index 3b1021e..8624bcc 100644 --- a/core/classes.lisp +++ b/core/classes.lisp @@ -1,7 +1,9 @@ -;;;; Copyright 2022-2024 by Tomáš Zellerin +;;;; Copyright 2022-2026 by Tomáš Zellerin (in-package :http2/core) +(declaim (optimize (speed 3) (safety 1))) + (defsection @implementation/overview (:title "Overview") "There are three core groups of classes: @@ -113,13 +115,34 @@ pretending that connection of connection is the same connection can be useful." (stream-collection class) (server-stream class)) -(defclass http2-stream (http2-stream-minimal flow-control-mixin) +(defclass http2-stream (http2-stream-minimal buffered-stream) ((data :accessor get-data :initarg :data) (weight :accessor get-weight :initarg :weight) (depends-on :accessor get-depends-on :initarg :depends-on) (seen-text-header :accessor get-seen-text-header :initarg :seen-text-header :documentation - "Set if in the header block a non-pseudo header was already seen.")) + "Set if in the header block a non-pseudo header was already seen.") + ;; Request pseudo-header slots. Server streams populate these from + ;; incoming client request headers; client streams may carry them for + ;; diagnostics (log-closed-stream, print-object). Shared here so that + ;; code handling either side uniformly can access them via the same + ;; accessor generic functions. + (method :accessor get-method :initarg :method + :documentation + "The HTTP method ([RFC7231], Section 4)") + (scheme :accessor get-scheme :initarg :scheme + :documentation + "Scheme portion of the target URI ([RFC3986], Section 3.1). + + Not restricted to \"http\" and \"https\" schemed URIs. + A proxy or gateway can translate requests for non-HTTP schemes, + enabling the use of HTTP to interact with non-HTTP services") + (authority :accessor get-authority :initarg :authority + :documentation + "The authority portion of the target URI ([RFC3986], Section 3.2)") + (path :accessor get-path :initarg :path + :type (or null string) + :documentation "The path and query parts of the target URI")) (:default-initargs :window-size 0 ;; All streams are initially assigned a non-exclusive dependency on ;; stream 0x0. Pushed streams (Section 8.2) initially depend on their @@ -127,7 +150,8 @@ pretending that connection of connection is the same connection can be useful." ;; weight of 16. :weight 16 :depends-on '(:non-exclusive 0) - :seen-text-header nil) + :seen-text-header nil + :method nil :scheme nil :authority nil :path nil) (:documentation "Representation of HTTP/2 stream. See RFC7540.")) @@ -140,24 +164,9 @@ pretending that connection of connection is the same connection can be useful." (setf window-size (get-initial-window-size connection))))) (defclass server-stream (http2-stream) - ((method :accessor get-method :initarg :method - :documentation - "The HTTP method ([RFC7231], Section 4)") - (scheme :accessor get-scheme :initarg :scheme - :documentation - "Scheme portion of the target URI ([RFC3986], Section 3.1). - - Not restricted to \"http\" and \"https\" schemed URIs. - A proxy or gateway can translate requests for non-HTTP schemes, - enabling the use of HTTP to interact with non-HTTP services") - (authority :accessor get-authority :initarg :authority - :documentation - "The authority portion of the target URI ([RFC3986], Section 3.2)") - (path :accessor get-path :initarg :path - :type string - :documentation "The path and query parts of the target URI")) - (:default-initargs :method nil :scheme nil :authority nil :path nil) - (:documentation "Server streams need to track attributes from the client headers such as PATH.")) + () + (:documentation "Server streams track the request pseudo-headers (method, +scheme, authority, path) inherited from http2-stream.")) (defmethod print-object ((stream server-stream) out) (if *print-escape* diff --git a/core/errors.lisp b/core/errors.lisp index 6c0879e..f714a0f 100644 --- a/core/errors.lisp +++ b/core/errors.lisp @@ -53,6 +53,7 @@ (connection-error condition) (connection-error function) (http-stream-error condition) + (http-stream-error-received condition) (http-stream-error function) (too-big-frame condition) (frame-too-small-for-priority condition) @@ -108,8 +109,10 @@ subclasses. Application must handle it, including closing associated NETWORK-STREAM.")) (defmethod print-object ((ce connection-error) out) - (print-unreadable-object (ce out :type t) - (format out "on ~a" (get-connection ce)))) + (if *print-escape* + (print-unreadable-object (ce out :type t) + (format out "on ~a" (get-connection ce))) + (call-next-method))) (define-condition protocol-error (connection-error) () @@ -118,12 +121,10 @@ NETWORK-STREAM.")) (define-condition client-preface-mismatch (protocol-error) ((received :accessor get-received :initarg :received)) (:documentation "HTTPS server expects a specific sequence of octets at the start of the new -connection. The client sent something different.")) - -(defmethod print-object ((err client-preface-mismatch) out) - (with-slots (received) err - (print-unreadable-object (err out :type t) - (format out "~a ~a" received (map 'string 'code-char received))))) +connection. The client sent something different.") + (:report (lambda (err out) + (with-slots (received) err + (format out "Client did not sent the client preface, but ~a" (map 'string 'code-char received)))))) (define-condition too-big-frame (connection-error) ((max-frame-size :accessor get-max-frame-size :initarg :max-frame-size) @@ -199,9 +200,12 @@ size (2^24-1 or 16,777,215 octets), inclusive.")) (:documentation "Frame cannot be applied to stream in particular state")) -(define-condition http-stream-error (warning) +(define-condition http-stream-error (error) ((code :accessor get-code :initarg :code) - (stream :accessor get-stream :initarg :stream))) + (stream :accessor get-stream :initarg :stream)) + (:documentation "HTTP stream error was either detected, or received from the peer. + +Base class for more detailed errors.")) (defmethod print-object ((err http-stream-error) out) (with-slots (stream code) err @@ -209,39 +213,47 @@ size (2^24-1 or 16,777,215 octets), inclusive.")) (print-unreadable-object (err out :type t) (format out "~d (~a) on ~s" (get-error-name code) - (documentation (get-error-name code) 'variable) + (or (documentation (class-of err) t) + (documentation (get-error-name code) 'variable)) stream)) - (format out "~a" (documentation (get-error-name code) 'variable))))) + (call-next-method)))) + +(define-condition http-stream-error-received (http-stream-error) + ()) + +(defmethod print-object ((err http-stream-error-received) out) + (with-slots (stream code) err + (if *print-escape* + (call-next-method) + (format out "Received error: ~a" (documentation (get-error-name code) 'variable))))) (define-condition incorrect-frame-size (http-stream-error) () (:default-initargs :code +frame-size-error+) - (:documentation - "A PRIORITY frame with a length other than 5 octets MUST be treated as a stream error (Section 5.4.2) of type FRAME_SIZE_ERROR.")) + (:report + "We received a PRIORITY frame with a length other than 5 octets (Section 5.4.2)")) (define-condition incorrect-rst-frame-size (connection-error) () (:default-initargs :code +frame-size-error+) - (:documentation - "A RST_STREAM frame with a length other than 4 octets MUST be treated as a connection error (Section 5.4.1) of type FRAME_SIZE_ERROR.")) + (:report + "We received a RST_STREAM frame with a length other than 4 octets (Section 5.4.1)")) (define-condition incorrect-settings-frame-size (connection-error) () (:default-initargs :code +frame-size-error+) (:documentation - "A SETTINGS frame with a length other than a multiple of 6 octets MUST be treated as a connection error (Section 5.4.1) of type FRAME_SIZE_ERROR.")) + "We received a SETTINGS frame with a length other than a multiple of 6 (Section 5.4.1)")) (define-condition incorrect-ping-frame-size (connection-error) () (:default-initargs :code +frame-size-error+) (:documentation - "Receipt of a PING frame with a length field value other than 8 MUST be treated as a connection error (Section 5.4.1) of type FRAME_SIZE_ERROR.")) + "We received PING frame with a length field value other than 8 (Section 5.4.1)")) (define-condition incorrect-window-update-frame-size (connection-error) () - (:default-initargs :code +frame-size-error+) - (:documentation - "Receipt of a PING frame with a length field value other than 8 MUST be treated as a connection error (Section 5.4.1) of type FRAME_SIZE_ERROR.")) + (:default-initargs :code +frame-size-error+)) (define-condition unexpected-continuation-frame (protocol-error) () @@ -249,22 +261,25 @@ size (2^24-1 or 16,777,215 octets), inclusive.")) "A CONTINUATION frame MUST be preceded by a HEADERS, PUSH_PROMISE or CONTINUATION frame without the END_HEADERS flag set. A recipient that observes violation of this rule MUST respond with a connection error (Section - 5.4.1) of type PROTOCOL_ERROR.")) + 5.4.1) of type PROTOCOL_ERROR.") + (:report "Continuation frame received when not expected.")) (define-condition stream-protocol-error (http-stream-error) () - (:default-initargs :code +protocol-error+)) + (:default-initargs :code +protocol-error+) + (:report "We detected some kind of protocol error.")) (define-condition header-error (stream-protocol-error) ((name :accessor get-name :initarg :name) - (value :accessor get-value :initarg :value))) + (value :accessor get-value :initarg :value)) + (:documentation "Base class for various errors in headers")) (define-condition incorrect-pseudo-header (header-error) ()) (define-condition pseudo-header-after-text-header (header-error) () - (:documentation "Pseudo header follows text header.")) + (:documentation "Peer sent a pseudo header after a text header.")) (define-condition incorrect-response-pseudo-header (header-error) ()) diff --git a/core/frames.lisp b/core/frames.lisp index 8f54c26..b7c069d 100644 --- a/core/frames.lisp +++ b/core/frames.lisp @@ -2,6 +2,8 @@ (in-package :http2/core) +(declaim (optimize (speed 3) (safety 1))) + (defsection @frames-for-classes () (handle-undefined-frame generic-function) @@ -12,9 +14,13 @@ (frame-context class) (flush-http2-data generic-function)) +(declaim (ftype (function (t) frame-size) get-max-peer-frame-size)) + (defclass frame-context () - ((max-frame-size :accessor get-max-frame-size :initarg :max-frame-size) - (max-peer-frame-size :accessor get-max-peer-frame-size :initarg :max-peer-frame-size)) + ((max-frame-size :accessor get-max-frame-size :initarg :max-frame-size + :type frame-size) + (max-peer-frame-size :accessor get-max-peer-frame-size :initarg :max-peer-frame-size + :type frame-size)) (:default-initargs :max-frame-size 16384 :max-peer-frame-size 16384)) @@ -73,6 +79,16 @@ Existing implementations are for: (write-sequence frame (get-network-stream connection)) frame)) +(defgeneric queue-frame-region (connection data start length) + (:documentation "Send or queue LENGTH octets of DATA starting at START to the connection + +Must use the data immediately.") + (:method (connection data start length) + "Fallback using QUEUE-FRAME." + (queue-frame connection (subseq data start (+ start length)))) + (:method ((connection stream-based-connection-mixin) frame start length) + (write-sequence frame (get-network-stream connection) :start start :end (+ start length)))) + (defsection @frames-api (:title "API for sending and receiving frames") "![image](../frames.png) There are several main low-level components: @@ -392,6 +408,25 @@ Each PARAMETER is a list of name, size in bits or type specifier and documentati ',(mapcar (lambda (a) (intern (symbol-name a) :keyword)) flags)))))) +(defun write-vector-frame (http-connection-or-stream type-code keys payload start length) + "Optimized version to write frame when the payload is already prepared as an octet vector." + (let* ((padded (getf keys :padded)) + (padded-length (padded-length length padded)) + (buffer (make-octet-buffer (+ 9 (if padded 1 0)))) + (connection (get-connection http-connection-or-stream))) + (write-frame-header-to-vector buffer 0 padded-length type-code (flags-to-code keys) + (get-stream-id http-connection-or-stream) nil) + (when padded (setf (aref buffer 9) (length padded))) + ;; This assumes: + ;; - only one thread talks to the connection, + ;; - the queue-frame and caller agree on who owns the buffer. Presently, all queue-frame I know about use the payload vector immediately. + (queue-frame connection buffer) + (queue-frame-region connection payload start length) + (when padded (queue-frame connection padded)) + (when (getf keys :end-stream) + (change-state-on-write-end http-connection-or-stream)) + buffer)) + (defun write-frame (http-connection-or-stream length type-code keys writer &rest pars) "Universal function to write a frame to a stream and account for possible stream @@ -402,6 +437,7 @@ frame header (9 octets) and padding octets. The payload is generated using WRITER object. The WRITER takes CONNECTION and PARS as its parameters." + (declare (dynamic-extent pars)) (let* ((padded (getf keys :padded)) (padded-length (padded-length length padded)) (buffer (make-octet-buffer (+ 9 padded-length)))) @@ -443,7 +479,7 @@ PARS as its parameters." (declare (type (unsigned-byte 24) length) (type (frame-code-type) type) (type (unsigned-byte 8) flags) - (type (simple-array (unsigned-byte 8)) vector) + (type octet-vector vector) (type stream-id stream-id)) (setf (aref vector start) (ldb (byte 8 16) length)) (setf (aref vector (incf start)) (ldb (byte 8 8) length)) @@ -482,7 +518,7 @@ PARS as its parameters." This function is primarily factored out to be TRACEd to see arriving frames." (declare (optimize speed) - ((simple-array (unsigned-byte 8) *) header) + (octet-vector header) (fixnum start) ((simple-array t *) *frame-types*)) (let* ((length (aref/wide header start 3)) diff --git a/core/frames/data.lisp b/core/frames/data.lisp index 60b4740..bf4a2c9 100644 --- a/core/frames/data.lisp +++ b/core/frames/data.lisp @@ -1,5 +1,7 @@ (in-package http2/core) +(declaim (optimize (speed 3) (safety 1))) + ;;;; content: ;;;; - flow control frame definition ;;;; - classes @@ -17,20 +19,152 @@ the windows is maintained by the FLOW-CONTROL-MIXIN." (flow-control-mixin class) (get-peer-window-size generic-function) (apply-window-size-increment generic-function) - (long-write function)) + (long-write function) + (available-window-size function)) + +(declaim (ftype (function (flow-control-mixin) window-size) get-peer-window-size)) (defclass flow-control-mixin () - ((window-size :accessor get-window-size :initarg :window-size) - (peer-window-size :accessor get-peer-window-size :initarg :peer-window-size) - (window-open-fn :accessor get-window-open-fn :initarg :window-open-fn - :initform nil - :documentation "Reference to a function to call when the window is extended. This is used in the -handler for /long in the demo.lisp example.")) + ((window-size :accessor get-window-size :initarg :window-size + :type window-size) + (peer-window-size :accessor get-peer-window-size :initarg :peer-window-size + :type window-size) + (window-size-increment-callback :accessor get-window-size-increment-callback :initarg :window-size-increment-callback)) + (:default-initargs :window-size-increment-callback nil) (:documentation "The flow control parameters that are kept both per-stream and per-connection. In addition to the accounting items (current window size of both endpoints) it -also tracks a callback to be called when window is increased (WINDOW-OPEN-FN).")) +also has an output buffer and tracks a callback to be called when window is +increased (WINDOW-SIZE-INCREMENT-CALLBACK).")) + +(defun available-window-size (http-stream &optional (connection (get-connection http-stream))) + "Smaller of connection and stream window size. You should not send in the data +frame for the stream more than this." + (min (get-peer-window-size connection) (get-peer-window-size http-stream))) + +(defsection @buffered () + "BUFFERED-STREAM mixin implements flow control on the senders side. + +It accepts new data with WRITE-OCTET-TO-STREAM and WRITE-SEQUENCE-TO-STREAM. + +FLUSH-STREAM-BUFFER uses generic functions WRITE-BUFFERED-FRAME to pass the +data and signals further." + (buffered-stream class) + (write-octet-to-stream function) + (write-sequence-to-stream function) + (flush-stream-buffer function) + (send-available-data function)) + +(defvar *default-stream-buffer-size* 65536 + "Buffer size for buffers. Default is chosen same as the default initial frame +size for buffers, which is 65536.") + +(declaim (ftype (function (t) (integer 0 #.array-dimension-limit)) get-flush-mark) + (ftype (function (t) octet-vector) get-output-buffer)) + +(defclass buffered-stream (flow-control-mixin) + ((output-buffer :accessor get-output-buffer :initarg :output-buffer + :documentation "Data to send, window permitting.") + (flush-mark :accessor get-flush-mark :initarg :flush-mark + :type fixnum + :documentation "Data up to FLUSH-MARK are flushed, i.e., they should be sent even when less than +a full frame. Still, write can be delayed due to insufficient window.") + (to-close :accessor get-to-close :initarg :to-close)) + (:documentation + "Hold queue of data to write in a buffer. Some of the data (flushed) are to be +sent as soon as possible given flow control constrains, the rest is to be send +when it is efficient (to prevent small frames).") + (:default-initargs :output-buffer + (make-array *default-stream-buffer-size* :element-type '(unsigned-byte 8) + :fill-pointer 0 :adjustable nil) + :flush-mark -1 :to-close nil)) + +(defgeneric write-buffered-frame (http-stream buffer offset size end-stream) + ;; this is split out to allow override for debugging and testing + (:documentation "Send a single buffered frame to HTTP-STREAM.") + (:method (stream buffer offset size end-stream) + (write-data-frame-region stream buffer offset size :end-stream end-stream))) + +(defun send-available-data (http-stream) + "Send queued data to the peer, respecting the peer window size limit and frame size efficiency. + +Specifically, send data while either +- they fit full frame and full frame window is open, +- there are data to flush and they fit the window, " + (declare (type http2-stream http-stream)) + (loop + with available-window of-type window-size = (available-window-size http-stream) + and peer-frame-size = (get-max-peer-frame-size (get-connection http-stream)) + and buffer = (get-output-buffer http-stream) + and offset of-type fixnum = 0 + and flush-mark = (get-flush-mark http-stream) + with fill-pointer = (fill-pointer buffer) + for tentative-size = (min peer-frame-size (- fill-pointer offset)) ; how much can we write in one frame + while (and (>= available-window peer-frame-size) ; window allows to write full frame + (or (> flush-mark offset) ; do not buffer flush data + (= tentative-size peer-frame-size))) + do + (write-buffered-frame http-stream buffer offset tentative-size + (and (get-to-close http-stream) + (= fill-pointer (+ offset tentative-size)))) + (incf offset tentative-size) + (decf available-window offset) + finally + (when (plusp offset) + (replace buffer buffer :start1 0 :start2 offset) + (setf (fill-pointer buffer) (- fill-pointer offset)) + (setf (get-flush-mark http-stream) (max -1 (- (get-flush-mark http-stream) offset))) + (flush-http2-data (get-connection http-stream))) + (return (>= available-window peer-frame-size)))) + +(defmacro with-buffer-slots (stream &body body) + `(with-slots (connection peer-window-size state output-buffer) ,stream + ,@body)) + +(defvar *buffer-grow-limit* (* 16 65536)) + +(defun maybe-grow-buffer (buffer &optional (target 0)) + (cond + ((> target *buffer-grow-limit*) + (cerror "Ok" "Too much data written and waiting.")) + ((>= target (array-dimension buffer 0)) + (adjust-array buffer (max target + (* 2 (array-dimension buffer 0))))))) + +(defun write-octet-to-stream (stream byte) + "Write an octet to the output buffer. + +Special cases: + +- Buffer is full -> extend it +- Buffer contains more that max peer frame size octets -> send the data out " + (with-buffer-slots stream + (maybe-grow-buffer output-buffer (fill-pointer output-buffer)) + (vector-push byte output-buffer) + (when (>= (fill-pointer output-buffer) + (get-max-peer-frame-size connection)) + (send-available-data stream)))) + +(defun write-sequence-to-stream (stream sequence start end) + "Write an octet to the output buffer, possibly extending it and sending out. + +- Buffer is full -> extend it +- Buffer contains more that max peer frame size octets -> send the data out " + (with-buffer-slots stream + (let* ((old-fill (fill-pointer output-buffer)) + (new-fill (+ (- end start) old-fill))) + (maybe-grow-buffer output-buffer new-fill) + (setf (fill-pointer output-buffer) new-fill) + (replace output-buffer sequence :start1 old-fill :start2 start + :end2 end)) + (send-available-data stream))) + +(defun flush-stream-buffer (stream end-stream-p) + (with-buffer-slots stream + (setf (get-flush-mark stream) (fill-pointer (get-output-buffer stream)) + (get-to-close stream) end-stream-p) + (send-available-data stream))) (define-condition duplicit-long-write () ((old-action :accessor get-old-action :initarg :old-action) @@ -44,66 +178,68 @@ also tracks a callback to be called when window is increased (WINDOW-OPEN-FN).") stream new-action old-action)))))) (defun continue-long-write (stream action size-needed) - "Actually implement LONG-WRITE behaviour. " + "Write chunks of possibly long data to HTTP/2 stream. + +Run chain of ACTIONS till the window size is too small or next action is NIL." (declare (type flow-control-mixin stream) - ((or null compiled-function) action)) - (with-slots (peer-window-size window-open-fn connection) stream + ((or null (and compiled-function (function () ))) action)) + (with-slots (peer-window-size window-size-increment-callback connection) stream (with-slots ((connection-window peer-window-size)) connection - (loop (cond ((null action) - (setf window-open-fn nil) + (setf window-size-increment-callback nil) (return nil)) ((> size-needed peer-window-size) - (setf window-open-fn action) + (setf window-size-increment-callback action) (return action)) ((> size-needed connection-window) (error "Connection window too small")) (t (setf (values action size-needed) (funcall action)))))))) (defun long-write (stream action size-needed) - "ACTION is a function that writes data to the stream using appropriate layer (not + "Write chunks of possibly long data to HTTP/2 stream. + +ACTION writes data to the stream using appropriate layer (not necessary flushing), and return two values, next ACTION and size needed for it. Writing to the stream also implicitly lowers the peer-window-size. -Calling these function is done either till the next action is NIL, or till the -peer window size is too low. In the latter case, store the next function so that -this is re-run when the appropriate window frame is received. +Calling the chain of these function is done either till the next action is NIL, +or till the peer window size is too low. In the latter case, store the next +function so that this is re-run when the appropriate window frame is received. This is supposed to be final part of sending data to the stream. Do not call it second time on same stream. -See /long example in demo.lisp.." - (with-slots (window-open-fn) stream - (when (and action window-open-fn) - (error 'window-full :old-action window-open-fn :new-action action +See /long example in demo.lisp." + (declare (type http2-stream stream) + (compiled-function action)) + (with-slots (window-size-increment-callback) stream + (when (and action window-size-increment-callback) + (error 'window-full :old-action window-size-increment-callback :new-action action :stream stream))) (continue-long-write stream action size-needed)) -(defclass multi-part-data-stream () - ((window-size-increment-callback :accessor get-window-size-increment-callback :initarg :window-size-increment-callback)) - (:default-initargs :window-size-increment-callback nil) - (:documentation - "Implement writing of data that may possibly be too big to send at once. - -When peer sends window size increment frame, call specified callback -function. This is set in WRITE-BINARY-PAYLOAD to write rest of data to write.")) - (defgeneric apply-window-size-increment (object increment) (:documentation "Called on window update frame. By default, increases PEER-WINDOW-SIZE slot of -the stream or connection, and possibly calls WINDOW-OPEN-FN.") +the stream or connection, and possibly calls WINDOW-SIZE-INCREMENT-CALLBACK.") (:method ((object (eql :closed)) increment)) (:method ((object flow-control-mixin) increment) - (with-slots (window-open-fn peer-window-size) object + (with-slots (window-size-increment-callback peer-window-size) object (incf peer-window-size increment) - (when window-open-fn - (continue-long-write object window-open-fn (get-max-peer-frame-size (get-connection object)))))) - - (:method :after ((object multi-part-data-stream) increment) - (with-slots (window-size-increment-callback) object + ;; FIXME: If a sender receives a WINDOW_UPDATE that causes a flow-control window + ;; to exceed this maximum, it MUST terminate either the stream or the + ;; connection, as appropriate. For streams, the sender sends a RST_STREAM + ;; with an error code of FLOW_CONTROL_ERROR; for the connection, a GOAWAY + ;; frame with an error code of FLOW_CONTROL_ERROR is sent. (when window-size-increment-callback - (funcall window-size-increment-callback object))))) + (continue-long-write object window-size-increment-callback (get-max-peer-frame-size (get-connection object)))))) +#+nil + (:method ((object buffered-stream) increment) + (with-slots (window-size-increment-callback peer-window-size) object + (incf peer-window-size increment) + (when (and (send-available-data object) window-size-increment-callback) + (funcall window-size-increment-callback))))) (defun account-read-window-contribution (connection stream length) "Update window size when we receive data." @@ -465,7 +601,19 @@ As always, use untrace to stop tracing." nil nil) -(defun write-data-frame (stream data &rest keys &key padded end-stream) +(defun write-data-frame (stream data &key padded end-stream (start 0) (length (length data))) + "``` + +---------------+-----------------------------------------------+ + | Data (*) ... + +---------------------------------------------------------------+ +``` + + DATA frames (type=0x0) convey arbitrary, variable-length sequences of + octets associated with a stream. One or more DATA frames are used, + for instance, to carry HTTP request or response payloads." + (write-data-frame-region stream data start length :padded padded :end-stream end-stream)) + +(defun write-data-frame-region (stream data start length &rest keys &key padded end-stream) "``` +---------------+-----------------------------------------------+ | Data (*) ... @@ -477,13 +625,9 @@ As always, use untrace to stop tracing." for instance, to carry HTTP request or response payloads." (declare (ignore padded end-stream) (octet-vector data)) - (let ((length (length data))) - (write-frame stream length +data-frame+ keys - (lambda (buffer start data) - (account-write-window-contribution (get-connection stream) - stream length) - (replace buffer data :start1 start)) - data))) + (write-vector-frame stream +data-frame+ keys data start length) + (account-write-window-contribution (get-connection stream) + stream length)) (defun write-data-frame-multi (stream data &rest keys &key end-stream) "Write a data frame that includes DATA - that is a sequence of octet vectors." diff --git a/core/frames/headers.lisp b/core/frames/headers.lisp index 23b5888..c4ddb2a 100644 --- a/core/frames/headers.lisp +++ b/core/frames/headers.lisp @@ -2,6 +2,8 @@ (in-package http2/core) +(declaim (optimize (speed 3) (safety 1))) + (defsection @frame-headers () (add-header generic-function) @@ -63,6 +65,17 @@ (setf (get-weight stream) weight (get-depends-on stream) `(,(if exclusive :exclusive :non-exclusive) ,stream-dependency))) + ;; FIND-JUST-STREAM-BY-ID returns the keyword :CLOSED when the stream-id + ;; is no longer in the streams table (already closed and reaped). RFC 9113 + ;; sec 5.5 explicitly permits PRIORITY frames on closed streams, and RFC 9218 + ;; deprecates stream priority entirely, so there is no per-stream state to + ;; update. Without this no-op method, the default method's (setf get-weight) + ;; signals "No applicable methods for #<... (SETF GET-WEIGHT) ...> with args + ;; (WEIGHT :CLOSED)". Pattern matches the existing (eql :closed) no-op + ;; methods on update-window-size, peer-resets-stream, and get-peer-window-size. + (:method ((stream (eql :closed)) exclusive weight stream-dependency) + (declare (ignore exclusive weight stream-dependency)) + nil) (:documentation "Called when priority frame - or other frame with priority settings set - arrives. Does nothing, as priorities are deprecated in RFC9113 anyway.")) @@ -89,6 +102,19 @@ arrives. Does nothing, as priorities are deprecated in RFC9113 anyway.")) (log-closed-stream active-stream e) (values #'parse-frame-header 9)))) +(defsection @log-streams () + (log-closed-stream function)) + +(defun log-closed-stream (stream e) + "Log request information when peer sends all headers or when the request errs for +some reason.. + +This is to be bound to HTTP-STREAM-ERROR" + (format *log-stream* "~&~A ~@<~A [#~d] ~a ~:>~%" + (get-peer-name (get-connection stream)) (get-path stream) + (get-stream-id stream) e) + (force-output *log-stream*)) + (defun parse-simple-frames-header-end-all (connection data &optional (start 0) (end (length data))) (handler-case (read-and-add-headers data (car (get-streams connection)) start end 5 5) @@ -320,7 +346,7 @@ expected, and then it is parsed by a different function." (values (lambda (connection header &optional (start 0) (end (length header))) (declare - ((simple-array (unsigned-byte 8) *) header old-data) + (octet-vector header old-data) ((integer 0 #.array-dimension-limit) start end)) (assert (= 9 (- end start))) (multiple-value-bind (frame-type-object length flags http-stream R) @@ -356,7 +382,7 @@ expected, and then it is parsed by a different function." (t (values (lambda (connection data start end) (declare (ignore connection)) - (declare ((simple-array (unsigned-byte 8) *) data)) + (declare (octet-vector data)) (let ((full-data (make-octet-buffer (+ length (- old-data-end old-data-start))))) (unless (= old-data-start old-data-end) diff --git a/core/frames/http2-stream.lisp b/core/frames/http2-stream.lisp index 8b8d8a0..98db4db 100644 --- a/core/frames/http2-stream.lisp +++ b/core/frames/http2-stream.lisp @@ -1,4 +1,7 @@ (in-package http2/core) + +(declaim (optimize (speed 3) (safety 1))) + ;;;; Interface diff --git a/core/frames/ping.lisp b/core/frames/ping.lisp index edaa016..d3c583b 100644 --- a/core/frames/ping.lisp +++ b/core/frames/ping.lisp @@ -1,5 +1,7 @@ (in-package http2/core) +(declaim (optimize (speed 3) (safety 1))) + (defgeneric do-ping (connection data) (:documentation "Called when ping-frame without ACK is received. diff --git a/core/frames/rst-and-goaway.lisp b/core/frames/rst-and-goaway.lisp index 7fc54e1..4143f8f 100644 --- a/core/frames/rst-and-goaway.lisp +++ b/core/frames/rst-and-goaway.lisp @@ -1,5 +1,7 @@ (in-package http2/core) +(declaim (optimize (speed 3) (safety 1))) + (defsection @rst () (peer-resets-stream generic-function)) @@ -64,16 +66,20 @@ error was reported.") (peer-resets-stream http-stream (aref/wide data 0 4)) (values #'parse-frame-header 9))) -(defun http-stream-error (e stream &rest args) - "We detected a HTTP2-STREAM-ERROR in a peer frame. So we send a RST frame, raise +(defun http-stream-error (error-class stream &rest args) + "Handle error in the incoming stream. + +We detected a HTTP2-STREAM-ERROR in a peer frame. So we send a RST frame, raise appropriate warning in case someone is interested, close affected stream, and continue." - (let ((e (apply #'make-instance e :stream stream args))) + (let ((e (apply #'make-instance error-class :stream stream args))) + (declare (http-stream-error e)) + ;; The error object is created in advance to be able to get its code. (unless (eql stream :closed) (write-rst-stream-frame stream (get-code e)) - (flush-http2-data (get-connection stream)) - (warn e) - (close-http2-stream stream)))) + (flush-http2-data (get-connection stream))) + (close-http2-stream stream) + (error e))) (define-frame-type 7 :goaway-frame "``` diff --git a/core/frames/settings.lisp b/core/frames/settings.lisp index d190508..f87eab8 100644 --- a/core/frames/settings.lisp +++ b/core/frames/settings.lisp @@ -1,5 +1,7 @@ (in-package http2/core) +(declaim (optimize (speed 3) (safety 1))) + (defgeneric peer-expects-settings-ack (connection) (:documentation "Called when settings-frame without ACK is received, after individual diff --git a/core/hpack.lisp b/core/hpack.lisp index 247b9d7..28cfa57 100644 --- a/core/hpack.lisp +++ b/core/hpack.lisp @@ -2,6 +2,17 @@ (in-package :http2/hpack) +;; File-level optimization: leave safety at the implementation default +;; (typically 3 on LispWorks and SBCL). The previous (speed 3) (safety 1) +;; declamation reduced bounds checking throughout hpack.lisp, including +;; in callers of decode-huffman-to-stream, which already lowers safety +;; to 0 in its inner update-vars flet. A malformed HEADERS frame +;; combined with reduced caller-side safety could turn a recoverable +;; type error into a SIGSEGV in production (rmcs1, 2026-05-22). The +;; per-function speed declarations below still apply where intended; +;; safety stays high on the cross-function dispatch. +(declaim (optimize (speed 3))) + (defsection @hpack-api (:title "HPACK - RFC7541 implementation.") "HTTP2 headers can be compressed - and implementation needs to be able to decompress - by two (or maybe three) ways: @@ -544,13 +555,18 @@ Return nil if the complete headers were processed, or index to first unprocessed ((integer 0 35) nr-size prefix) (optimize speed) ((integer 0 65536) idx start end) - ((and vector (simple-array (unsigned-byte 8))) bytes)) + (octet-vector bytes)) (macrolet ((decode () (decode-octet-fn))) (flet ((update-vars (min-prefix) - (declare (optimize (safety 0))) + ;; safety 1 (not 0) so the aref below has bounds checking; + ;; rmcs1 production SIGSEGV (2026-05-22) traced to an aref + ;; running past the end of the header block fragment under + ;; safety 0. The per-byte cost is negligible because the + ;; hot path is dispatch, not the byte fetch. + (declare (optimize (safety 1))) (when (> min-prefix nr-size) - (when (= idx end) (return-from decode-huffman-to-stream)) + (when (>= idx end) (return-from decode-huffman-to-stream)) (let ((old nr)) (setf nr 0 (ldb (byte 8 8) nr) old @@ -561,7 +577,10 @@ Return nil if the complete headers were processed, or index to first unprocessed (decf nr-size min-prefix) (setf nr (ldb (byte nr-size 0) nr))) (emit (char) (write-char char char-stream))) - (declare (optimize speed (safety 0) space) + ;; safety 1 here too -- the inner loop's dispatch shouldn't run + ;; with safety 0 in a network-input context. See rmcs1 SIGSEGV + ;; (2026-05-22). + (declare (optimize speed (safety 1) space) (notinline update-vars emit)) (loop (decode)))))) diff --git a/core/payload-streams.lisp b/core/payload-streams.lisp index d3bccc9..4770d7e 100644 --- a/core/payload-streams.lisp +++ b/core/payload-streams.lisp @@ -1,5 +1,7 @@ (in-package http2/stream-overlay) +(declaim (optimize (speed 3) (safety 1))) + ;;;; What does "stream" mean here? ;;;; ;;;; 1. we have TCP socket (usocket) and possibly stream as well @@ -14,12 +16,39 @@ ;;;; -> transport stream ;;;; -(mgl-pax:defsection @overlay - () +(defsection @payload-streams-ref (:title "HTTP/2 streams as CL streams") + "There is an abstraction implemented that allows to write data to HTTP/2 streams +as if it was a Common Lisp STREAM. The data written to the CL stream are encoded +to octets, then possibly compressed, and send out to the peer in data +frames. Closing the CL stream ends the HTTP/2 stream. Flushing or forcing CL +streams flushes the HTTP/2 stream. + +The only - but significant - issue is that due to the nature of the protocol, +the rate of sending the data after initial burst is limited by how fast the +other side accepts it. If you send too much too fast, your endpoint thread might +block. This can impact negatively other streams (in multi-thread server) or even +other connections (in poll server). On client it is probably fine. + +What you should do is to schedule further writes to the stream for later. Yes, +this complicates things, so you can also reset the stream if window is too +small (maybe better that impact other connections/streams) + +The \"Look before you leap\" approach is to use AVAILABLE-WINDOW-SIZE before you +send. Note that the size is for octets, and compression as well as multibyte +character encoding may change the numbers. + +The \"Easier to ask for forgiveness than permission\" approach is to handle the +WINDOW-IS-CLOSED condition. + +It is also possible to treat HTTP/2 stream as an INPUT-STREAM. This will +definitively block, so use in a client when you wait for data from single +stream, but not for the server." + (available-window-size function) + (window-is-closed condition) + (payload-output-stream class) (http2-stream-with-input-stream class)) -(defmethod stream-element-type ((stream binary-stream)) - '(unsigned-byte 8)) +(defmethod stream-element-type ((stream binary-stream)) '(unsigned-byte 8)) (defclass payload-stream (binary-stream) @@ -28,41 +57,18 @@ "Base class for a CL binary stream that is defined over http2 stream")) (defclass payload-output-stream (payload-stream trivial-gray-streams:fundamental-binary-output-stream) - ((output-buffer :accessor get-output-buffer)) - (:default-initargs :to-write 0 :to-store 0) + (#+moved(output-buffer :accessor get-output-buffer)) +#+nil (:default-initargs :to-write 0 :to-store 0) (:documentation - "Binary stream that accepts new octets to the output-buffer, until it is big -enough to send the data as a data frame on BASE-HTTP2-STREAM (or forced to by close of force-output) ")) - -(defmethod initialize-instance :after ((stream payload-output-stream) - &key - base-http2-stream - (connection (get-connection base-http2-stream)) - (window-size (min 65536 (get-initial-peer-window-size connection))) &allow-other-keys) - (setf (get-output-buffer stream) - (make-array window-size :element-type '(unsigned-byte 8) - :fill-pointer 0 :adjustable nil))) + "Binary gray output stream build upon an HTTP/2 stream. It accepts new octets to +the output-buffer, until it is big enough to send the data as a data frame on +the underlying stream.")) (defmacro with-output-payload-slots (stream &body body) - `(with-slots (output-buffer base-http2-stream) ,stream - (with-slots (connection peer-window-size state) base-http2-stream + `(with-slots (base-http2-stream) ,stream + (with-slots (connection peer-window-size state output-buffer) base-http2-stream ,@body))) -(define-condition http2-write-data-stall (warning) - ((sent :reader get-sent :initarg :sent) - (data :reader get-data :initarg :data)) - (:documentation "Signalled when data are to be sent and there is not big enough window available -to sent. Tracks DATA to sent and number of octets actually SENT.")) - -(defun send-buffer-to-peer (output-buffer peer-window-size stream connection) - (loop while (< peer-window-size (length output-buffer)) - ;; we want to send more than window allows, so lets wait for more - ;; window - ;; this assumes that the client will not shrink the window too much. - do (read-frame connection)) - (write-data-frame stream output-buffer) - (setf (fill-pointer output-buffer) 0)) - (defmethod trivial-gray-streams:stream-write-byte ((stream payload-output-stream) byte) "Write an octet to the output buffer. @@ -70,93 +76,93 @@ Special cases: - Buffer is full -> warn and do nothing (FIXME: handle it somehow) - Buffer contains more that max peer frame size octets -> send the data out " - (with-output-payload-slots stream - (if (< (fill-pointer output-buffer) (array-dimension output-buffer 0)) - (vector-push byte output-buffer) - (warn "Not enough space in buffer: ~d<~d" - (fill-pointer output-buffer) (array-dimension output-buffer 0))) - (when (>= (fill-pointer output-buffer) - (get-max-peer-frame-size connection)) - (send-buffer-to-peer output-buffer - (min peer-window-size (get-peer-window-size connection)) - base-http2-stream connection)))) + (write-octet-to-stream (get-base-http2-stream stream) byte)) (defmethod close ((stream payload-output-stream) &key &allow-other-keys) - (with-output-payload-slots stream - ;; FIXME: here we know (aside of intervening setting changes) that the - ;; output buffer is smaller than max-frame-size, but it still might be - ;; larger than the window. + (flush-stream-buffer (get-base-http2-stream stream) t) +#+nil (with-output-payload-slots stream + ;; FIXME: here we know (aside of intervening setting changes) that the + ;; output buffer is smaller than max-frame-size, but it still might be + ;; larger than the window. - ;; Should we handle also RST on send? - (unless (eq 'http2/core::closed state) - (write-data-frame base-http2-stream output-buffer :end-stream t) - (flush-http2-data connection)))) + ;; Should we handle also RST on send? + (unless (eq 'http2/core::closed state) + (write-data-frame base-http2-stream output-buffer :end-stream t) + (flush-http2-data connection)))) (defmethod trivial-gray-streams:stream-force-output ((stream payload-output-stream)) - (with-output-payload-slots stream - (unless (zerop (length output-buffer)) - (write-data-frame base-http2-stream output-buffer :end-stream nil) - (setf (fill-pointer output-buffer) 0)) - (flush-http2-data connection))) + (flush-stream-buffer (get-base-http2-stream stream) nil)) ;; TODO: finish-output could wait for window updates arriving. Except afaics ;; noone forces the other side to keep window size unchanged over time... -(defun send-data (stream sequence start size) +(defun end-data (stream sequence start size) "Send data in OUTPUT-BUFFER and SIZE data from SEQUENCE starting at START in one data frame; mark them as sent. Return new START." - (with-slots (output-buffer base-http2-stream) stream - (write-data-frame-multi base-http2-stream - (if (zerop (length output-buffer)) - (make-array size - :displaced-to sequence - :displaced-index-offset start - :element-type '(unsigned-byte 8)) - (list output-buffer - (make-array size - :displaced-to sequence - :displaced-index-offset start - :element-type '(unsigned-byte 8))))) - (setf (fill-pointer output-buffer) 0) - (incf start size))) + (with-slots (base-http2-stream) stream + (with-slots (output-buffer) base-http2-stream + (write-data-frame-multi base-http2-stream + (if (zerop (length output-buffer)) + (make-array size + :displaced-to sequence + :displaced-index-offset start + :element-type '(unsigned-byte 8)) + (list output-buffer + (make-array size + :displaced-to sequence + :displaced-index-offset start + :element-type '(unsigned-byte 8))))) + (setf (fill-pointer output-buffer) 0) + (incf start size)))) (defun wait-for-window-is-at-least-frame-size (connection http-stream) - (loop for allowed-window = (min (get-peer-window-size connection) - (get-peer-window-size http-stream)) + (loop for allowed-window = (available-window-size http-stream connection) for frame-size = (get-max-peer-frame-size connection) while (> frame-size allowed-window) do (read-frame connection) -#+nil(loop until - (restart-case + #+nil(loop until + (restart-case - (read-again ()))))) + (read-again ()))))) + +#+unused +(define-condition http2-write-data-stall (warning) + ((sent :reader get-sent :initarg :sent) + (data :reader get-data :initarg :data)) + (:documentation "Signalled when data are to be sent and there is not big enough window available +to sent. Tracks DATA to sent and number of octets actually SENT.")) (define-condition window-is-closed (condition) ((start :accessor get-start :initarg :start) - (data :accessor get-data :initarg :data))) + (data :accessor get-data :initarg :data)) + (:report "Not all data could be sent to peer. Peer window too small.")) (defmethod print-object ((o window-is-closed) stream) - (with-slots (start data) o - (print-unreadable-object (o stream) - (format o "at ~d of ~d" start (length data))))) + (if *print-escape* + (with-slots (start data) o + (print-unreadable-object (o stream) + (format o "at ~d of ~d" start (length data)))) + (call-next-method))) + (defmethod trivial-gray-streams:stream-write-sequence ((stream payload-output-stream) sequence start end &key) - (with-output-payload-slots stream - ;; Situations: - ;; - We have more than max-peer-frame-size data, and peer window is above it -> we can send a frame and go on - ;; - We do not have enough data (full frame) yet - we wait for more data - ;; - We have more than max-peer-frame-size, but window is too small -> we read a frame + (http2/core::write-sequence-to-stream (get-base-http2-stream stream) sequence start end) +#+old (with-output-payload-slots stream (let ((total-length (- (+ (or end (length sequence)) - (length (get-output-buffer stream))) + (length output-buffer)) start))) (loop for frame-size = (get-max-peer-frame-size connection) while (and (>= total-length frame-size)) do + ;; FIXME: this signals too often, even when window is OK. + ;; maybe we should store data away so that it "works", even ineffectively, + ;; out of box. + ;; and we should not wait but schedule for future. (signal 'window-is-closed :start start :data sequence) (wait-for-window-is-at-least-frame-size connection base-http2-stream) (setf start (send-data stream sequence start diff --git a/core/pipe.lisp b/core/pipe.lisp index 4992f08..6346901 100644 --- a/core/pipe.lisp +++ b/core/pipe.lisp @@ -1,5 +1,7 @@ (in-package #:http2/utils) +(declaim (optimize (speed 3) (safety 1))) + (defsection @buffer-stream-and-pipes (:title "Vector backed streams and (buffered) octet pipes") diff --git a/core/stream-based-connections.lisp b/core/stream-based-connections.lisp index 52c41d6..8b3fa8e 100644 --- a/core/stream-based-connections.lisp +++ b/core/stream-based-connections.lisp @@ -1,5 +1,7 @@ (in-package http2/stream-overlay) +(declaim (optimize (speed 3) (safety 1))) + (mgl-pax:defsection @stream-based-connection (:title "Connections using CL streams") (stream-based-connection-mixin class) @@ -35,15 +37,18 @@ May block." with frame-action = initial-action and size = initial-size and stream = (get-network-stream connection) + ;; Reusable buffer for 9-byte frame headers (the common case). + ;; Payload buffers vary in size and are allocated per frame. + and header-buf = (make-octet-buffer 9) ;; Prevent ending when waiting for payload while (or (null just-pending) (listen stream) (not (eql #'parse-frame-header frame-action))) do (force-output stream) - (let* ((buffer (make-octet-buffer size)) - (read (read-sequence buffer stream))) - (declare (dynamic-extent buffer)) + (let* ((buffer (cond ((= size 9) header-buf) + (t (make-octet-buffer size)))) + (read (read-sequence buffer stream :end size))) (cond ((= size read) (multiple-value-setq diff --git a/core/utils.lisp b/core/utils.lisp index e0bad56..31e6651 100644 --- a/core/utils.lisp +++ b/core/utils.lisp @@ -2,6 +2,8 @@ (in-package :http2/utils) +(declaim (optimize (speed 3) (safety 1))) + (defsection @utils (:title "Utilities") (find-setting-code function) (find-setting-by-id function) @@ -14,6 +16,7 @@ (aref/wide function) (vector-from-hex-text function) (frame-size type) + (window-size type) (octet-vector type) (trace-object macro) @@ -23,9 +26,6 @@ (declaim (inline make-octet-buffer)) -#| -|# - (deftype frame-size () "The size of a frame payload is limited by the maximum size that a receiver advertises in the SETTINGS_MAX_FRAME_SIZE setting. This @@ -33,6 +33,10 @@ setting can have any value between 2^14 (16,384) and 2^24-1 (16,777,215) octets, inclusive." '(unsigned-byte 24)) +(deftype window-size () + "A sender MUST NOT allow a flow-control window to exceed 2^31-1 octets." + '(unsigned-byte 31)) + (defun make-octet-buffer (size) " ```cl-transcript @@ -365,3 +369,9 @@ reading).")) (print-unreadable-object (err out :type t) (format out "on ~a" (http2/utils:get-medium err))) (call-next-method))) + +(defsection @log-basics () + (*log-stream* variable)) + +(defvar *log-stream* (make-synonym-stream '*standard-output*) + "The stream used for generic logging. ") diff --git a/http2.asd b/http2.asd index 29c4b59..1f12079 100644 --- a/http2.asd +++ b/http2.asd @@ -14,6 +14,7 @@ :components ((:file "package") (:module "core" :components ((:file "utils") + (:file "buffer-pool") (:file "pipe") (:file "errors") (:file "hpack") diff --git a/overview.lisp b/overview.lisp index 3572271..fbdce7c 100644 --- a/overview.lisp +++ b/overview.lisp @@ -32,7 +32,7 @@ part of the HTTP2/SERVER system. This system is also loaded when HTTP2 is loaded (@systems-and-packages section) (http2/client::@client-api section) (http2/server::@server-reference section) - (http2/server::@logging section)) + (http2/stream-overlay::@payload-streams-ref section)) (defsection @systems-and-packages (:title "Systems and packages") "The library is split to several subsystems. Most of them depend on other @@ -54,7 +54,6 @@ priority, and definitely not a blocker." (http2/core::@implementation/overview section) (http2/hpack::@hpack-api section) (http2/core::@data section) - (http2/server::@server-reference section) (http2/server/poll::@async-server section)) (defsection @test @@ -81,8 +80,6 @@ priority, and definitely not a blocker." "Make package documentation for the release: - HTML documentation files, -- README to be distributed with the package - -" +- README to be distributed with the package" (mgl-pax:update-asdf-system-readmes @overview "http2") (mgl-pax:update-asdf-system-html-docs @index "http2" :pages (pages))) diff --git a/package.lisp b/package.lisp index 8af824f..ffb753b 100644 --- a/package.lisp +++ b/package.lisp @@ -4,8 +4,12 @@ (:use :cl :mgl-pax) (:import-from #:anaphora #:acond #:aif #:it)) +(mgl-pax:define-package #:http2/buffer-pool + (:use #:cl) + (:import-from #:mgl-pax #:defsection #:section #:macro)) + (mgl-pax:define-package :http2/hpack - (:use :cl #:anaphora #:http2/utils) + (:use :cl #:anaphora #:http2/utils #:http2/buffer-pool) (:import-from #:mgl-pax #:defsection #:glossary-term #:section #:define-glossary-term)) @@ -16,7 +20,7 @@ (:use #:cl #:cffi #:mgl-pax #:dref #:http2/utils)) (mgl-pax:define-package :http2/core - (:use :cl :http2/hpack :http2/utils) + (:use :cl :http2/hpack :http2/utils #:http2/buffer-pool) (:import-from :anaphora #:awhen #:acond #:it) (:import-from #:mgl-pax #:defsection #:glossary-term #:section #:define-glossary-term) @@ -27,7 +31,7 @@ (:use #:cl #:http2/core #:cl+ssl #:mgl-pax #:http2/openssl)) (mgl-pax:define-package #:http2/stream-overlay - (:use #:cl #:http2/core #:http2/utils) + (:use #:cl #:http2/core #:http2/utils #:mgl-pax) (:import-from #:anaphora #:acond #:awhen #:aif #:it)) (mgl-pax:define-package #:http2/client diff --git a/server/dispatch.lisp b/server/dispatch.lisp index 36fcd8c..4f7939c 100644 --- a/server/dispatch.lisp +++ b/server/dispatch.lisp @@ -21,14 +21,26 @@ This defines a handler on \"/hello-world\" path that sends reasonable headers, w In general, the handlers are set using DEFINE-PREFIX-HANDLER or DEFINE-EXACT-HANDLER, and are functions typically created by HANDLER macro, -or (in simple cases) by REDIRECT-HANDLER or SEND-TEXT-HANDLER functions." +or (in simple cases) by REDIRECT-HANDLER or SEND-TEXT-HANDLER functions.") + +(defsection @handlers (:title "Define handler") + "See tutorial @SERVER-CONTENT for the overview." (define-prefix-handler macro) (define-exact-handler macro) (handler type) (handler macro) (constant-handler macro) (redirect-handler function) - (send-text-handler function) + (send-text-handler function)) + +(defsection @send-response (:title "Send response") + "Customized handlers need to actually prepare and send the response. Response +usually has some body and headers, and also can end badly and close either the +stream or even the connection. + +In most cases, body is sent by writing to the stream provided by the +handler." + ;; FIXME: move detail to the PAYLOAD-STREAM (send-headers function) (send-goaway function)) @@ -56,12 +68,18 @@ variable. ``` " + (@request-body section)) + +(defsection @request-details-reference (:title "Access request parameter") + "Here are listed function that allow to access request parameters." (get-path generic-function) (get-headers (method (HTTP2/core::header-collecting-mixin))) (get-method (method (server-stream))) (get-scheme (method (server-stream))) (get-authority (method (server-stream))) - (@request-body section)) + (get-body (method (body-collecting-mixin))) + (http-stream-to-string function) + (http2/client::fallback-all-is-ascii class)) (defsection @request-body (:title "Body of the request") @@ -86,10 +104,7 @@ want to read text, as last resort change class of your streams to include FALLBACK-ALL-IS-ASCII (or improve IS-UTF8-P, or add some other decoding function). If you do not want to see text at all, change class to \\NOT include -UTF8-PARSER-MIXIN or any other conversion mixin." - (get-body (method (body-collecting-mixin))) - (http-stream-to-string function) - (http2/client::fallback-all-is-ascii class)) +UTF8-PARSER-MIXIN or any other conversion mixin.") (defun send-goaway (code debug-data) "Start closing connection, sending CODE and DEBUG-DATA in the go-away frame to @@ -102,14 +117,11 @@ peer. Must be called from inside of HANDLER macro." (prefix-handlers :accessor get-prefix-handlers :initarg :prefix-handlers)) (:default-initargs :exact-handlers nil :prefix-handlers nil) (:documentation - "Server with behaviour that is defined by two sets of handlers, exact and -prefix. Appropriate handler is run to process the request when peer closes the -http2 stream. The exact handler must match fully the path (so not the query), -prefix handlers matches when the path starts with the prefix. + "Defined two sets of handlers, exact and prefix, for the dispatcher. Appropriate +handler is run to process the request when peer closes the http2 stream. The exact handler must match fully the path (so not the query), prefix handlers matches when the path starts with the prefix. Protocol and domain are not checked. The behaviour is implemented in the -appropriate PEER-ENDS-HTTP-STREAM method. -")) +appropriate PEER-ENDS-HTTP-STREAM method.")) (eval-when (:compile-toplevel :load-toplevel) (defun define-some-handler (target prefix fn) @@ -127,7 +139,10 @@ the http request described by STREAM object." This handler, when called, runs BODY in a context where -- FLEXI-STREAM-NAME is bound to an open flexi stream that can be written to (to write response). On background, written text is converted from CHARSET to octets, possibly compressed by GZIP and split into frames, +- FLEXI-STREAM-NAME is bound to an open flexi stream that can be written to (to + write response). On background, written text is converted from CHARSET to + octets, possibly compressed by GZIP and split into frames, + - and two lexical functions are defined, SEND-HEADERS and SEND-GOAWAY. The SEND-HEADERS sends the provided headers to the STREAM. @@ -243,8 +258,7 @@ optionally prints activities.")) (defclass vanilla-server-stream (server-stream utf8-parser-mixin fallback-all-is-ascii text-collecting-stream http2/core::header-collecting-mixin - body-collecting-mixin - multi-part-data-stream) + body-collecting-mixin) () (:documentation "A server-side stream that can be used as a binary output stream, optionally @@ -415,7 +429,11 @@ wrapper over START that cannot be customized." (defsection @server-reference (:title "Server API reference") - (@dispatchers section)) + (@dispatchers section) + (@handlers section) + (@send-response section) + (@request-details-reference section) + (@logging section)) (defsection @dispatchers (:title "Server classes") @@ -444,7 +462,8 @@ Some predefined combinations are below." (poll-dispatcher-mixin class) (single-client-dispatcher class) (tls-dispatcher-mixin class) - (detached-server-mixin class)) + (detached-server-mixin class) + (routing-mixin class)) "- use polling interface that uses openssl directly, - TLS-THREADED-DISPATCHER and DETACHED-TLS-THREADED-DISPATCHER use thread per connection and use CL+SSL, diff --git a/server/logging.lisp b/server/logging.lisp index 0c6345f..799a17f 100644 --- a/server/logging.lisp +++ b/server/logging.lisp @@ -12,8 +12,6 @@ What is logged: - Client disconnected" (*log-stream* variable)) -(defvar *log-stream* (make-synonym-stream '*standard-output*)) - (defgeneric log-server-connected (connection) (:documentation "Log connection established (with PEER).") (:method (connection) @@ -27,13 +25,3 @@ What is logged: (format *log-stream* "~&~A Disconnected ~a~%" (get-peer-name connection) error) (force-output *log-stream*))) - -(defun log-closed-stream (stream e) - "Log request information when peer sends all headers or when the request errs for -some reason.. - -This is to be bound to HTTP-STREAM-ERROR" - (format *log-stream* "~&~A ~@<~A [#~d] ~a ~:>~%" - (http2/server::get-peer-name (get-connection stream)) (get-path stream) - (http2/core::get-stream-id stream) e) - (force-output *log-stream*)) diff --git a/server/poll-openssl.lisp b/server/poll-openssl.lisp index 454acd1..98f0ac1 100644 --- a/server/poll-openssl.lisp +++ b/server/poll-openssl.lisp @@ -1,7 +1,15 @@ (in-package #:http2/openssl) (defsection @SSL (:title "SSL handling") - (communication-error condition) + "Wrapper library over openssl functions. + +TLS-ENDPOINT-CORE wraps the SSL parameter used in openssl functions. The functions that use it are listed in @SSL-OPS. + +" +#+nil (bio-should-retry function) + (@openssl-endpoint section) + (@openssl-context section) + (@ssl-ops section) (@ssl-errors section)) (defsection @SSL-errors (:title "Signalled errors") @@ -9,10 +17,13 @@ conditions. They are descended from the COMMUNICATION-ERROR. See manual page for SSL_get_error for the overview." + (handle-ssl-errors function) (communication-error condition) - (ssl-blocked condition) - (ssl-wants-read condition) - (ssl-wants-write condition)) + (simple-communication-error condition) + (peer-sent-close-notify condition) + (ssl-error-condition condition) + (ssl-syscall-error condition) + (other-ssl-error condition)) (define-condition ssl-error-condition (communication-error) ((codes :accessor get-codes :initarg :codes)) @@ -74,23 +85,6 @@ indicate that the underlying transport has been closed.") ;; To test: run a curl request (:report "Peer closed TLS connection.")) -(define-condition ssl-blocked (communication-error) - () - (:documentation "The operation did not complete and can be retried later.")) - -(define-condition ssl-wants-read (ssl-blocked) - () - (:documentation - "The last operation was a read operation from a nonblocking BIO. Not enough data -was available at this time to complete the operation. If at a later time the -underlying BIO has data available for reading the same function can be called -again.") - (:report "Not enough data for SSL read. Waiting for more data normally fixes this")) - -(define-condition ssl-wants-write (ssl-blocked) - () - (:documentation "")) - (define-condition retry-flag-not-set (communication-error) () (:documentation "Openss ")) @@ -105,26 +99,39 @@ nothing was added to the error stack, and errno was 0.")) ((code :accessor get-code :initarg :code)) (:documentation "ssl-get-error return code that we do not handle (yet)")) -(defun handle-ssl-errors* (client ret) - "Check RET value of a openssl call and raise relevant error, if any." +(defun bio-should-retry (wbio client) + (when (zerop (bio-test-flags wbio bio-flags-should-retry)) + (error 'simple-communication-error :format-control "Retry flag should be set." + :medium client))) + +(defun handle-ssl-errors* (client ret on-read-fail-idx on-write-fail-idx) + "Raise appropriate error after a failed openssl call. + +If ret>0 (no fail), returns nil. If write or read is needed by SSL, return nil +as well and clear appropriate flag. + +Otherwise raise one of SIMPLE-COMMUNICATION-ERROR, PEER-SENT-CLOSE-NOTIFY, +SSL-ERROR-CONDITION, SSL-SYSCALL-ERROR, or OTHER-SSL-ERROR. + +" + ;; after SSL_connect(), SSL_accept(),SSL_do_handshake(), SSL_read_ex(), + ;; SSL_read(), SSL_peek_ex(),SSL_peek(), SSL_shutdown(), SSL_write_ex() or + ;; SSL_write() + (let* ((ssl (tls-endpoint-core-ssl client)) (wbio (tls-endpoint-core-rbio client)) (err-code (ssl-get-error ssl ret))) (cond ;; after ssl read ((= err-code ssl-error-want-write) - (when (zerop (bio-test-flags wbio bio-flags-should-retry)) - (error 'simple-communication-error :format-control "Retry flag should be set." - :medium client)) - (error 'ssl-wants-write :medium client)) + (bio-should-retry wbio client) + (set-state* client on-write-fail-idx 0)) ((= err-code ssl-error-want-read) ;; This is relevant for accept call and handled in loop ;; may be needed for pull phase ;; is this needed? - (when (zerop (bio-test-flags wbio bio-flags-should-retry)) - (error 'simple-communication-error :format-control "Retry flag should be set." - :medium client)) - (error 'ssl-wants-read)) + (bio-should-retry wbio client) + (set-state* client on-read-fail-idx 0)) ((= err-code ssl-error-none) nil) ; this should happen iff ret > 0 ((= err-code ssl-error-zero-return) (error 'peer-sent-close-notify :medium client)) ((= err-code ssl-error-ssl) (error 'ssl-error-condition :medium client :codes (get-ssl-errors))) @@ -135,16 +142,119 @@ nothing was added to the error stack, and errno was 0.")) (error 'ssl-syscall-error :codes (get-ssl-errors) :errno errno :medium client)))) (t (error 'other-ssl-error :code err-code :medium client))))) +(defun handle-ssl-errors (client ret) + "Check real error after a call to SSL_connect, SSL_accept, +SSL_do_handshake, SSL_read_ex, SSL_read, SSL_peek_ex, SSL_peek, SSL_shutdown, +SSL_write_ex or SSL_write. + +If the operation was successfully completed, do nothing. + +If it is a harmless one (want read or want write), try to process the data. + +Raise error otherwise." + (handle-ssl-errors* client ret (state-idx 'can-read-ssl) nil)) ; FIXME: write status + + +(defsection @ssl-ops () + "Use ENCRYPT-SOME* and SSL-READ" + (encrypt-some* function) + (read-encrypted-from-openssl* function) + (write-octets-to-decrypt* function) + (ssl-read function) + (maybe-init-ssl function) + (ssl-peek function)) + +; TODO: rename to encrypt-vector (defun encrypt-some* (client vector from to) "Encrypt octets in VECTOR between FROM and TO. Return number of octets -processed, or raise appropriate error." +processed, or raise appropriate error. You can try to read the encrypted octets +later by READ-ENCRYPTED-FROM-OPENSSL*, and it sets CAN-READ-BIO." + ;; VECTOR -> SSL + (declare (type (integer 0 #.array-dimension-limit) from to)) + (assert (if-state client 'can-write-ssl)) (with-pointer-to-vector-data (buffer vector) (let* ((ssl (tls-endpoint-core-ssl client)) (res (ssl-write ssl (inc-pointer buffer from) (- to from)))) (cond - ((plusp res) res) - (t (handle-ssl-errors* client res) + ((plusp res) + (add-state client 'can-read-bio) + res) + ;; no-star handle-ssl-errors masks SSL-WANTS-READ + (t (handle-ssl-errors* client res (state-idx 'can-write-ssl) nil) 0))))) -(defun bio-should-retry (wbio) - (bio-test-flags wbio bio-flags-should-retry)) +(defun read-encrypted-from-openssl* (client vec size) + "Read decrypted octets from WBIO. Possibly cleans CAN-READ-BIO. + +Return number of octets read" + ;; WBIO -> VEC + (declare ((simple-array (unsigned-byte 8)) vec) + (fixnum size)) + (assert (if-state client 'can-read-bio)) + (with-pointer-to-vector-data (buffer vec) + (let* ((wbio (tls-endpoint-core-wbio client)) + (res (bio-read% wbio buffer size))) + (cond ((plusp res) + (add-state client 'can-read-ssl) + (add-state client 'can-write-ssl) + res) + (t + (bio-should-retry wbio client) + (remove-state client 'can-read-bio) + 0))))) + +(defun write-octets-to-decrypt* (client vector from to) + "Send octets in VECTOR for decryption. Read result with SSL-READ later. + +Return number of written bytes. This should be positive. + +When SSL receives data through the BIO channel, it possibly can be read from and +written to again (or at least it could be tried). + +This assumes writing BIO never fails due to size." + (with-pointer-to-vector-data (buffer vector) + (let ((written (bio-write (tls-endpoint-core-rbio client) + (inc-pointer buffer from) + (- to from)))) + (unless (plusp written) (error "Bio-write failed")) + (add-state client 'can-read-ssl) + (add-state client 'can-read-bio) ; maybe ssl needs to do something? + (add-state client 'can-write-ssl) + written))) + +(defun maybe-init-ssl (client) + "If SSL is not initialized yet, initialize it." + (cond + ((zerop (ssl-is-init-finished (tls-endpoint-core-ssl client))) + (handle-ssl-errors client (ssl-accept (tls-endpoint-core-ssl client)))) + (t (remove-state client 'ssl-init-needed) + (add-state client 'can-read-bio) + (add-state client 'can-read-ssl) + (add-state client 'can-write-ssl)))) + +;;;; Read decrypted data +(defun ssl-read (client vec size) + "Move up to SIZE octets from the decrypted SSL ③ to the VEC. + +Return 0 when no data are available. Possibly remove CAN-READ-SSL flag." + (assert (if-state client 'can-read-ssl)) + (let ((res + (with-pointer-to-vector-data (buffer vec) + (ssl-read% (tls-endpoint-core-ssl client) buffer size)))) + (handle-ssl-errors client res) + (unless (= res size) (remove-state client 'can-read-ssl)) + (max 0 res))) + +(defun ssl-peek (client max-size) + "Copy up to SIZE octets from the decrypted SSL ③ to the VEC. + +This is intended for introspection and debugging, e.g., in DESCRIBE-OBJECT. + +Return 0 when no data are available." + (unless (null-pointer-p (tls-endpoint-core-ssl client)) + (let* ((vec (make-octet-buffer max-size)) + (res + (with-pointer-to-vector-data (buffer vec) + (ssl-peek% (tls-endpoint-core-ssl client) buffer max-size)))) + (handle-ssl-errors client res) + (values (subseq vec 0 (max 0 res)) res)))) diff --git a/server/poll-server.lisp b/server/poll-server.lisp index 98f6c13..9e02743 100644 --- a/server/poll-server.lisp +++ b/server/poll-server.lisp @@ -90,96 +90,6 @@ The actions are in general indicated by arrows in the diagram: (defvar *default-buffer-size* 1500) ; close to socket size -(defsection @poll-tls-states (:title "TLS endpoint states") - "The actions available for a specific endpoint are kept in STATE. - -Each state bit corresponds to one function that can be called." - "CAN-READ-PORT is set when there are data available on the input port. This can -be set by HANDLE-CLIENT-IO after poll, and is cleared by READ-FROM-PEER when there are -no longer data available. It allows PROCESS-DATA-ON-SOCKET to be called." - "CAN-READ-SSL is set when there are data available on SSL to read by the -application. It is set by PROCESS-DATA-ON-SOCKET, as it indicates that some data -to decrypt were written, and is cleared by SSL-READ. It triggers -ON-COMPLETE-SSL-DATA or RUN-USER-CALLBACK." - "CAN-WRITE-SSL is set when data can be written to SSL. It is set by -PROCESS-DATA-ON-SOCKET and cleared by ENCRYPT-SOME. Triggers ENCRYPT-DATA." - "CAN-READ-BIO is set when there are probably some data to read from the BIO. It -is set by ENCRYPT-SOME and PROCESS-DATA-ON-SOCKET and MAYBE-INIT-SSL. It is -cleared by READ-ENCRYPTED-FROM-OPENSSL. It triggets MOVE-ENCRYPTED-BYTES." - "CAN-WRITE is set when writing to the output socket is possible (which usually -is). It is set by HANDLE-CLIENT-IO and . It is cleared by SEND-TO-PEER and -WRITE-DATA-TO-SOCKET. It triggers WRITE-DATA-TO-SOCKET." - "HAS-DATA-TO-WRITE is set when the write buffer for output socket is -non-empty (or, not implemented, has enough data to make sending economical). It -is set by READ-ENCRYPTED-FROM-OPENSSL and MOVE-ENCRYPTED-BYTES. It is cleared by -WRITE-DATA-TO-SOCKET and triggers MOVE-ENCRYPTED-BYTES." - "NEG-BIO-NEEDS-READ is set by PROCESS-DATA-ON-SOCKET and triggers -MAYBE-INIT-SSL. It is cleared by an error condition in HANDLE-SSL-ERRORS." - "SSL-INIT-NEEDED is maybe not needed?" - (state type) - - (select-next-action function) - (states-to-string function)) - -;;;; Async TLS endpoint state -(eval-when (:load-toplevel :compile-toplevel) - (defparameter *states* - '(CAN-READ-PORT ; ① - CAN-READ-SSL ; ③ - CAN-WRITE-SSL ; ④ - CAN-READ-BIO ; ⑤ - CAN-WRITE ; ⑥ - HAS-DATA-TO-WRITE ; ⓤ - NEG-BIO-NEEDS-READ ; B - SSL-INIT-NEEDED ; S - ) - "List of state bits that can a TLS endpoint have.")) - -(defun states-to-string (state) - "Short string describing the state using codes on the diagram." - (with-output-to-string (*standard-output*) - (loop ;for state in *states* - for state-idx from 0 - for label across "①③④⑤⑥ⓤⒺBSO" - do (princ - (if (plusp (ldb (byte 1 state-idx) state)) label #\Space))))) - -(deftype state () - "Description of actions available to the endpoint." - `(unsigned-byte ,(length *states*))) - -(defmacro state-idx (state) - `(let ((idx (position ,state ',*states*))) - (or idx (error "No state ~a" ,state)))) - -(defun if-state* (client state-idx) - (plusp (ldb (byte 1 state-idx) - (client-state client)))) - -(declaim (inline if-state add-state remove-state if-state* test-state*)) - -(defun if-state (client state) - (if-state* client (state-idx state))) - -(defun set-state* (client idx value) - (declare (bit value) - (fixnum idx)) - (setf (ldb (byte 1 idx) - (client-state client)) - value)) - -(defun add-state (client state) - (set-state* client (state-idx state) 1)) - -(defun remove-state (client state) - (set-state* client (state-idx state) 0)) - -(defparameter *initial-state* - (loop with state = 0 - for item in - '(CAN-WRITE CAN-WRITE-SSL ssl-init-needed) - do (setf (ldb (byte 1 (state-idx item)) state) 1) - finally (return state))) (deftype app-callback () @@ -214,10 +124,6 @@ MAYBE-INIT-SSL. It is cleared by an error condition in HANDLE-SSL-ERRORS." (octets-needed 0 :type fixnum) (encrypt-buf-size 0 :type fixnum) (start-time (get-internal-real-time) :type fixnum) - (state *initial-state* :type state) - ;; set of CAN-READ-PORT, CAN-READ-SSL, CAN-WRITE-SSL, - ;; CAN-READ-BIO, HAS-DATA-TO-WRITE, CAN-WRITE - ;; NEG-BIO-NEEDS-READ SSL-INIT-NEEDED (application-data)) (defvar *tls-content-types* @@ -316,18 +222,8 @@ available. Raise an error on error." vector destination) (remove-state client 'CAN-READ-PORT)) read)) -;;;; Read BIO (rbio) - -;;; This name is somewhat confusing - it is BIO for SSL reads, so it actually -;;; gets written to. - (define-writer write-octets-to-decrypt openssl-to-decrypt (client vector from to) - (with-pointer-to-vector-data (buffer vector) - (let ((written (bio-write (client-rbio client) - (inc-pointer buffer from) - (- to from)))) - (unless (plusp written) (error "Bio-write failed")) - written))) + (write-octets-to-decrypt* client vector from to)) (defun decrypt-socket-octets (client vector from to) "Send data in the VECTOR between FROM and TO to the ② openssl for decryption ." @@ -336,38 +232,9 @@ available. Raise an error on error." vector destination) #'write-octets-to-decrypt vector from to)) (defun process-data-on-socket (client) + ;; Trigger: CAN-READ-PORT & "Read data from client socket ① and pass them to the tls buffer ② to decrypt." - (pull-once-push-bytes client #'read-from-peer #'decrypt-socket-octets) - (add-state client 'CAN-READ-SSL) - (add-state client 'can-write-ssl) - (unless (if-state client 'neg-bio-needs-read) - (add-state client 'neg-BIO-NEEDS-READ) - (add-state client 'CAN-READ-BIO))) - -;;;; Read SSL -(defun ssl-read (client vec size) - "Move up to SIZE octets from the decrypted SSL ③ to the VEC. - -Return 0 when no data are available. Possibly remove CAN-READ-SSL and/or -NEG-BIO-NEEDS-READ flags." - (let ((res - (with-pointer-to-vector-data (buffer vec) - (ssl-read% (client-ssl client) buffer size)))) - (handle-ssl-errors client res) - (unless (= res size) (remove-state client 'can-read-ssl)) - (max 0 res))) - -(defun ssl-peek (client max-size) - "Move up to SIZE octets from the decrypted SSL ③ to the VEC. - -Return 0 when no data are available." - (unless (null-pointer-p (client-ssl client)) - (let* ((vec (make-octet-buffer max-size)) - (res - (with-pointer-to-vector-data (buffer vec) - (http2/openssl::ssl-peek% (client-ssl client) buffer max-size)))) - (handle-ssl-errors client res) - (values (subseq vec 0 (max 0 res)) res)))) + (pull-once-push-bytes client #'read-from-peer #'decrypt-socket-octets)) ;;;; Encrypt queue (defun add-and-maybe-pass-data (client buffer new-data from to old-size cleaner) @@ -422,16 +289,8 @@ NEW-DATA are completely used up (can be dynamic-extent)." (setf (client-encrypt-buf-size client) new-size) (assert (= processed (length new-data))))) -;;;; Write to SSL (define-writer encrypt-some output-ssl (client vector from to) - (handler-case - (let ((res - (encrypt-some* client vector from to))) - (when (plusp res) - (add-state client 'can-read-bio)) - res) - (ssl-blocked () - (remove-state client 'can-write-ssl)))) + (encrypt-some* client vector from to)) (defun encrypt-data (client) "Encrypt data in client's ENCRYPT-BUF. @@ -448,18 +307,7 @@ Otherwise, use a temporary vector to write data " ;;;; Write BIO (define-reader read-encrypted-from-openssl bio-out (client vec size) - (declare ((simple-array (unsigned-byte 8)) vec) - (fixnum size)) - (with-pointer-to-vector-data (buffer vec) - (let ((res (bio-read% (client-wbio client) buffer size))) - (cond ((plusp res) - (add-state client 'has-data-to-write) - res) - ((zerop (bio-should-retry (client-wbio client))) - (error "Failed to read from bio, and cant retry")) - (t - (remove-state client 'can-read-bio) - 0))))) + (read-encrypted-from-openssl* client vec size)) (defun move-encrypted-bytes (client) "Move data encrypted by OpenSSL to the socket write queue Ⓔ. @@ -467,8 +315,7 @@ Otherwise, use a temporary vector to write data " This should be called in a way friendly to Nagle algorithm. My understaning is this is either when we pipeline a lot of data, or when we send out somethinf that expects a response." - (pull-push-bytes client #'read-encrypted-from-openssl #'queue-encrypted-bytes) - (add-state client 'has-data-to-write)) + (pull-push-bytes client #'read-encrypted-from-openssl #'queue-encrypted-bytes)) ;;;; TCP write port (define-writer send-to-peer peer-out (client vector from to) @@ -501,7 +348,6 @@ keep what did not fit." #'send-to-peer concated 0 (client-write-buf-size client)))) (cond ((= written (client-write-buf-size client)) - (remove-state client 'has-data-to-write) (setf (client-write-buf-size client) 0)) ((plusp written) (remove-state client 'can-write) @@ -536,7 +382,7 @@ TLS-SERVER/MEASURE::ACTIONS clip on this function." (cond ((if-state client 'can-read-port) #'process-data-on-socket) ((and (if-state client 'ssl-init-needed) - (if-state client 'neg-bio-needs-read)) + (if-state client 'can-read-ssl)) #'maybe-init-ssl) ((if-state client 'can-read-ssl) (if (plusp (client-octets-needed client)) @@ -548,7 +394,7 @@ TLS-SERVER/MEASURE::ACTIONS clip on this function." (if-state client 'can-write-ssl)) #'encrypt-data) ((if-state client 'can-read-bio) #'move-encrypted-bytes) - ((and (if-state client 'has-data-to-write) + ((and (plusp (client-write-buf-size client)) (if-state client 'can-write)) #'write-data-to-socket) (t nil))) @@ -631,27 +477,6 @@ Repeat on partial write." ((zerop written) (return from)))))) -(defun handle-ssl-errors (client ret) - "Check real error after a call to SSL_connect, SSL_accept, -SSL_do_handshake, SSL_read_ex, SSL_read, SSL_peek_ex, SSL_peek, SSL_shutdown, -SSL_write_ex or SSL_write. - -If the operation was successfully completed, do nothing. - -If it is a harmless one (want read or want write), try to process the data. - -Raise error otherwise." - (handler-case (handle-ssl-errors* client ret) - (ssl-wants-read () (remove-state client 'neg-bio-needs-read)))) - -(defun maybe-init-ssl (client) - "If SSL is not initialized yet, initialize it." - (cond - ((zerop (ssl-is-init-finished (client-ssl client))) - (handle-ssl-errors client (ssl-accept (client-ssl client)))) - (t (remove-state client 'ssl-init-needed) - (add-state client 'can-read-bio)))) - (defun doubled-buffer (buffer) "Return a larger buffer with same initial data as the provided one." (let ((new (make-array (* 2 (length buffer)) @@ -784,8 +609,9 @@ reading of the client hello." (unless (eql #'parse-frame-header (client-io-on-read client)) (warn "Poll error for ~a: ~d" client err-or-hup)) (signal 'done)) - (and (if-state client 'has-data-to-write) - (not (if-state client 'can-write)))))) + (and + (plusp (client-write-buf-size client)) + (not (if-state client 'can-write)))))) (defun setup-new-connect-pollfd (fdset listening-socket) (add-socket-to-fdset% fdset (sb-bsd-sockets:socket-file-descriptor (usocket:socket listening-socket)) diff --git a/server/tcpip.lisp b/server/tcpip.lisp index 40ed820..fafd311 100644 --- a/server/tcpip.lisp +++ b/server/tcpip.lisp @@ -116,6 +116,8 @@ Otherwise signal an error." "See man errno(3). " (mem-ref (errno%) :int)) +(declaim (ftype (function * integer) errno)) + ;;;; Polling stuff (defcfun ("poll" poll%) :int "Synchronous I/O multiplexing. Called by POLL." (fdset :pointer) (rb :int) (timeout :int)) @@ -341,12 +343,16 @@ follow later (EAGAIN)." (defun fd-to-ip (fd) (with-foreign-objects ((addr '(:struct sockaddr-in)) (len :int)) (setf (mem-ref len :int) size-of-sockaddr-in) - (checked-syscall #'zerop #'getpeername fd addr len) - (assert (= (mem-ref len :int) size-of-sockaddr-in)) - (with-foreign-slots ((sin-family sin-port sin-addr) addr (:struct sockaddr-in)) - (values (format nil "~a.~a.~a.~a:~a" - (ldb (byte 8 0) sin-addr) - (ldb (byte 8 8) sin-addr) - (ldb (byte 8 16) sin-addr) - (ldb (byte 8 24) sin-addr) - (htons sin-port)))))) + (handler-case + (progn + (checked-syscall #'zerop #'getpeername fd addr len) + (assert (= (mem-ref len :int) size-of-sockaddr-in)) + (with-foreign-slots ((sin-family sin-port sin-addr) addr (:struct sockaddr-in)) + (values (format nil "~a.~a.~a.~a:~a" + (ldb (byte 8 0) sin-addr) + (ldb (byte 8 8) sin-addr) + (ldb (byte 8 16) sin-addr) + (ldb (byte 8 24) sin-addr) + (htons sin-port))))) + (error () + (values "Unknown" 0))))) diff --git a/tests/frames/data.lisp b/tests/frames/data.lisp index 76ad5db..b2cd30d 100644 --- a/tests/frames/data.lisp +++ b/tests/frames/data.lisp @@ -28,3 +28,36 @@ #(0 0 4 0 8 0 0 0 42 3 10 11 12) (make-octet-buffer 0) :padded padding)))) + + +(defclass test-buffered-stream (http2-stream http2-connection) + ((snippets :accessor get-snippets :initarg :snippets)) + (:default-initargs :snippets nil)) + +(defmethod write-buffered-frame ((stream test-buffered-stream) buffer offset size end-stream) + (push (make-array size :initial-contents (subseq buffer offset (+ offset size))) + (get-snippets stream)) + (when end-stream (push :end-stream (get-snippets stream)))) + +(defmethod flush-http2-data ((stream test-buffered-stream)) + (push :end-stream (get-snippets stream))) + +(defun test-buffered-frame-output (window frame-size process-fn) + (let ((*default-stream-buffer-size* 20) + (test-stream (make-instance 'test-buffered-stream :peer-window-size window :max-peer-frame-size frame-size))) + (declare (dynamic-extent test-stream)) + (setf (get-connection test-stream) test-stream) + (funcall process-fn test-stream) + (reverse (mapcar (lambda (s) (if (vectorp s) (length s) s)) + (get-snippets test-stream))))) + +(fiasco:deftest buffered-output/test () + "Test that incoming buffered data are properly split to data frames." + (macrolet ((@ ((peer-window-size max-frame-size) &body body) + `(test-buffered-frame-output ,peer-window-size ,max-frame-size + (lambda (test-stream) ,@body)))) + (fiasco:is (equalp + '(4 4 :end-stream 2 :end-stream) + (@ (20 4) + (write-sequence-to-stream test-stream #(1 2 3 4 5 6 7 8 9 10) 0 10) + (flush-stream-buffer test-stream nil)))))) diff --git a/tests/high-level.lisp b/tests/high-level.lisp index eb010bc..2025166 100644 --- a/tests/high-level.lisp +++ b/tests/high-level.lisp @@ -36,14 +36,20 @@ (let ((http2/server:*poll-timeout* 0.5) (http2/server:*no-client-poll-timeout* 0.5)) (dolist (dispatcher-class '(http2/server::detached-poll-dispatcher http2/server::detached-tls-threaded-dispatcher)) - (multiple-value-bind (response code) - (multiple-value-bind (dispatcher url) - (start 0 :dispatcher dispatcher-class) - (unwind-protect - (retrieve-url (puri:merge-uris "/hello-world" url)) - (stop dispatcher))) - (is (= code 200)) - (is (search "Hello World, this is random" response)))))) + (handler-case + (multiple-value-bind (response code) + (multiple-value-bind (dispatcher url) + (start 0 :dispatcher dispatcher-class) + (unwind-protect + (handler-case + (retrieve-url (puri:merge-uris "/hello-world" url)) + (cl+ssl::ssl-error-ssl (e) (values (princ-to-string e) 0))) + (handler-bind + ;; server might be dead when stopping + ((SB-THREAD:INTERRUPT-THREAD-ERROR 'continue)) + (stop dispatcher)))) + (is (= code 200)) + (is (search "Hello World, this is random" response))))))) (define-exact-handler "/body-and-headers" (handler (foo :utf-8 nil) diff --git a/tests/poll-server.lisp b/tests/poll-server.lisp index a80aef5..7aee457 100644 --- a/tests/poll-server.lisp +++ b/tests/poll-server.lisp @@ -1,27 +1,31 @@ (in-package http2/tests/server) (deftest add-and-maybe-pass-data/test () - "Test adding new data to the chunks." + "Test adding new data to the chunks. + +New data is appended to an existing buffer that starts with a logical size of 10 +bytes. Check both flushed segments size, new buffer size, and return values." (flet ((@ (new-data-size expected-new-size chunk-sizes) (let* ((buffer (make-octet-buffer 100)) (new-data (make-octet-buffer new-data-size)) (outputs nil) (cleaner (lambda (client buffer start to) - (declare (ignore client)) - (push (subseq buffer start to) outputs) + "Note flushed octets and return their number" + (declare (ignore client buffer)) + (push (- to start) outputs) (- to start)))) (fill new-data 42) (fill buffer 10 :end 20) (multiple-value-bind (new-size processed) (http2/server/poll::add-and-maybe-pass-data nil buffer new-data 0 (length new-data) 10 cleaner) (is (= new-size expected-new-size)) - (is (equalp (mapcar 'length outputs) chunk-sizes)) - (is (= processed new-data-size)) - (values buffer outputs new-size processed))))) - (@ 10 20 nil) - (@ 50 60 nil) - (@ 95 5 '(100)) - (@ 200 0 '(110 100)))) + (is (equalp outputs chunk-sizes)) + (is (= processed new-data-size)))))) + (@ 10 20 nil) ; 10 existing plus 10 new → 20 total, stays under the flush threshold, nothing emitted. + (@ 50 60 nil) ; plus 50 new → 60 total, still under threshold, nothing emitted. + (@ 95 5 '(100)) ; 10 + 95 = 105 over max size, emits one full chunk of size 100 via cleaner, leaving 5 buffered. + (@ 200 0 '(110 100)) ; fill to full and send (100), other chunks send as-is without using the buffer + (values))) ;;;; Sandbox (defsection @poll-pair ()) @@ -53,7 +57,6 @@ MAKE-HTTP2-TLS-CONTEXT." (http2/server/poll::ssl-connect (http2/server/poll:client-ssl client)) (http2/server/poll::add-state client 'http2/server/poll::can-read-bio) (http2/server/poll::do-available-actions client) - (encrypt-and-send client) (sleep 0.1) ; Naggle (http2/server/poll::add-state server 'http2/server/poll::can-read-port) (http2/server/poll::do-available-actions server) @@ -145,6 +148,7 @@ AFTER-POLL-FN on them after data exchange." :server-context "")))) (is (member #xa0000c1 (http2/openssl::get-codes err))))) ; no shared cipher +#+fixme (defun test-send-in-advance (blob-size) "Send BLOB-SIZE octets from one TLS endpoint to another before the TLS connection is set up. This should be queued and used at the very start of the communication. @@ -169,9 +173,8 @@ Return number of received octets (that should be same as number of octets sent)" :after-poll-fn (constantly nil)) received)) +#+fixme (deftest send-in-advance () - - #+nil (dolist (size '(10 100 200 1000)) ;; note: fails for 2000 (is (equal size (test-send-in-advance size))))) diff --git a/tls/openssl.lisp b/tls/openssl.lisp index eadf0b5..e1b3d31 100644 --- a/tls/openssl.lisp +++ b/tls/openssl.lisp @@ -4,30 +4,12 @@ #-os-macosx (:unix "libssl.so") (t (:default "libssl.3"))) -(defsection @openssl (:title "Openssl interface") - "Wraps openssl calls." - (@openssl-endpoint section) - (@openssl-context section)) - -(export '(handle-ssl-errors* with-ssl-context encrypt-some* bio-should-retry)) - -(export '(neg-bio-needs-read peer-open has-data-to-encrypt can-write-ssl - can-read-bio - ; bio-s-mem bio-new ssl-new - ssl-set-accept-state - bio-write ssl-read% ssl-error-condition err-reason-error-string - bio-read% ssl-is-init-finished ssl-accept ssl-connect)) - -(defsection @openssl-endpoint (:title "TLS endpoint") - (tls-endpoint-core type) - (init-tls-endpoint-core function) - (make-tls-endpoint-core function) - (with-tls-endpoint-core macro) - - (close-openssl function)) - (use-foreign-library openssl) +(declaim (ftype (function * integer) ssl-get-error bio-test-flags err-get-error) + (inline ssl-write ssl-read% bio-read% bio-write ssl-is-init-finished + ssl-peek%)) + (defcfun "BIO_new" :pointer (bio-method :pointer)) (defcfun ("BIO_read" bio-read%) :int (bio-method :pointer) (data :pointer) (dlen :int)) (defcfun "BIO_s_mem" :pointer) @@ -50,20 +32,33 @@ (defcfun "SSL_set_bio" :void (ssl :pointer) (rbio :pointer) (wbio :pointer)) (defcfun "SSL_write" :int (ssl :pointer) (buffer :pointer) (bufsize :int)) -(defstruct (tls-endpoint-core (:constructor make-tls-endpoint-core%) - (:print-object +(defsection @openssl-endpoint (:title "TLS endpoint") + "Wrap the SSL parameter used in openssl functions." + (tls-endpoint-core type) + (init-tls-endpoint-core function) + (make-tls-endpoint-core function) + (with-tls-endpoint-core macro) + (close-openssl function) + (@poll-tls-states section)) + +(locally + (declare (special *initial-state*)) + (defstruct (tls-endpoint-core (:constructor make-tls-endpoint-core%) + (:print-object (lambda (object out) (format out (if (null-pointer-p (tls-endpoint-core-ssl object)) "#" "#"))))) - "Data of one TLS endpoint. This includes: + "Data of one TLS endpoint. This includes: - Opaque pointer to the openssl handle (SSL). See SSL-READ and ENCRYPT-SOME. -- Input and output BIO for exchanging data with OPENSSL (WBIO, RBIO)." - (ssl (null-pointer) :type cffi:foreign-pointer :read-only nil) ; mostly RO, but invalidated afterwards - (rbio (bio-new (bio-s-mem)) :type cffi:foreign-pointer :read-only t) - (wbio (bio-new (bio-s-mem)) :type cffi:foreign-pointer :read-only t)) +- Input and output BIO for exchanging data with OPENSSL (WBIO, RBIO). +- State flags." + (ssl (null-pointer) :type cffi:foreign-pointer :read-only nil) ; mostly RO, but invalidated afterwards + (rbio (bio-new (bio-s-mem)) :type cffi:foreign-pointer) + (wbio (bio-new (bio-s-mem)) :type cffi:foreign-pointer) + (state *initial-state* :type (unsigned-byte 16)))) (defmethod describe-object ((object tls-endpoint-core) stream) (let ((*print-length* (or *print-length* 30))) @@ -78,7 +73,7 @@ (when (plusp (ssl-is-init-finished (tls-endpoint-core-ssl object))) "" #+nil (ssl-peek object 100))))) (defun init-tls-endpoint-core (client context) - "Initialize freshly created TLS-CORE. + "Initialize existing freshly created TLS-CORE. That is, create a SSL context and bind it with RBIO and WBIO. @@ -88,7 +83,7 @@ This is factored out so that it can be used in structures that inherit TLS-CORE. (setf (tls-endpoint-core-ssl client) ssl))) (defun make-tls-endpoint-core (context) - "New TLS-ENDPOINT-CORE that has context derived from CONTEXT." + "Make a new TLS-ENDPOINT-CORE that has context derived from CONTEXT." (let ((ep (make-tls-endpoint-core%))) (init-tls-endpoint-core ep context) ep)) @@ -109,17 +104,117 @@ This is factored out so that it can be used in structures that inherit TLS-CORE. (close-openssl ,name)))) (defun close-openssl (client) - "Close the endpoint core CLIENT at drop the references." + "Close the endpoint core CLIENT and drop the references." (unless (null-pointer-p (tls-endpoint-core-ssl client)) (ssl-free (tls-endpoint-core-ssl client))) ; BIOs are closed automatically - (setf (tls-endpoint-core-ssl client) (null-pointer)) - ;; we set these as read-only, so do not touch - #+nil (tls-endpoint-core-rbio ,name) (null-pointer) - #+nil (tls-endpoint-core-wbio ,name) (null-pointer)) + (setf (tls-endpoint-core-ssl client) (null-pointer) + (tls-endpoint-core-rbio client) (null-pointer) + (tls-endpoint-core-wbio client) (null-pointer))) + +(defsection @poll-tls-states (:title "TLS endpoint states") + "The actions available for a specific endpoint are kept in STATE. + +Each state bit corresponds to one function that can be called." + "CAN-READ-PORT is set when there are data available on the input port. This can +be set by HANDLE-CLIENT-IO after poll, and is cleared by READ-FROM-PEER when there are +no longer data available. It allows PROCESS-DATA-ON-SOCKET to be called." + "CAN-READ-SSL is set when there are data available on SSL to read by the +application. It is set by PROCESS-DATA-ON-SOCKET, as it indicates that some data +to decrypt were written, and is cleared by SSL-READ. It triggers +ON-COMPLETE-SSL-DATA or RUN-USER-CALLBACK." + "CAN-WRITE-SSL is set when data can be written to SSL. It is set by +PROCESS-DATA-ON-SOCKET and cleared by ENCRYPT-SOME. Triggers ENCRYPT-DATA." + "CAN-READ-BIO is set when there are probably some data to read from the BIO. It +is set by ENCRYPT-SOME and PROCESS-DATA-ON-SOCKET and MAYBE-INIT-SSL. It is +cleared by READ-ENCRYPTED-FROM-OPENSSL. It triggets MOVE-ENCRYPTED-BYTES." + "CAN-WRITE is set when writing to the output socket is possible (which usually +is). It is set by HANDLE-CLIENT-IO and . It is cleared by SEND-TO-PEER and +WRITE-DATA-TO-SOCKET. It triggers WRITE-DATA-TO-SOCKET." + "NEG-BIO-NEEDS-READ is set by PROCESS-DATA-ON-SOCKET and triggers +MAYBE-INIT-SSL. It is cleared by an error condition in HANDLE-SSL-ERRORS." + "SSL-INIT-NEEDED is maybe not needed?" + (openssl-state type) + (*states* variable) + (if-state function) + (add-state function) + (remove-state function) + (select-next-action function) + (states-to-string function)) + +(export '(neg-bio-needs-read peer-open has-data-to-encrypt can-write-ssl + can-read-bio can-read-port can-read-ssl ssl-init-needed + ; bio-s-mem bio-new ssl-new + ssl-set-accept-state can-write + bio-write ssl-read% ssl-error-condition err-reason-error-string + bio-read% ssl-is-init-finished ssl-accept ssl-connect)) +;;;; Async TLS endpoint state +(eval-when (:load-toplevel :compile-toplevel) + (defparameter *states* + '(CAN-READ-PORT ; ① + CAN-READ-SSL ; ③ + CAN-WRITE-SSL ; ④ + CAN-READ-BIO ; ⑤ + CAN-WRITE ; ⑥ + HAS-DATA-TO-WRITE ; ⓤ + NEG-BIO-NEEDS-READ ; B + SSL-INIT-NEEDED ; S + ) + "List of state bits that can a TLS endpoint have.")) + +(export *states*) + +(defun states-to-string (state) + "Short string describing the state using codes on the diagram." + (with-output-to-string (*standard-output*) + (loop ;for state in *states* + for state-idx from 0 + for label across "①③④⑤⑥ⓤⒺBSO" + do (princ + (if (plusp (ldb (byte 1 state-idx) state)) label #\Space))))) + +(deftype openssl-state () + "Description of actions available to the endpoint." + `(unsigned-byte ,(length *states*))) + +(defmacro state-idx (state) + `(let ((idx (position ,state ',*states*))) + (or idx (error "No state ~a" ,state)))) + +(declaim (inline if-state add-state remove-state if-state* test-state*)) + +(defun if-state* (client state-idx) + (plusp (ldb (byte 1 state-idx) + (tls-endpoint-core-state client)))) + +(defun if-state (client state) + (if-state* client (state-idx state))) + +(defun set-state* (client idx value) + (declare (bit value) + (fixnum idx)) + (setf (ldb (byte 1 idx) + (tls-endpoint-core-state client)) + value)) + +(defun add-state (client state) + (set-state* client (state-idx state) 1)) + +(defun remove-state (client state) + (set-state* client (state-idx state) 0)) + +(defparameter *initial-state* + (loop with state = 0 + for item in + '(CAN-WRITE CAN-WRITE-SSL ssl-init-needed) + do (setf (ldb (byte 1 (state-idx item)) state) 1) + finally (return state))) + + (defsection @openssl-context (:title "TLS context") "TLS context is created with MAKE-HTTP2-TLS-CONTEXT, and its use should be wrapped in WITH-SSL-CONTEXT." + (with-ssl-context macro) (with-ssl-context mgl-pax:macro) (make-tls-context generic-function) "The details of the context are modified by the context mixins.") @@ -164,7 +259,7 @@ wrapped in WITH-SSL-CONTEXT." (clientlen :int)) (cffi:defcallback select-h2-callback - :int + :int ((ssl :pointer) (out (:pointer (:pointer :char))) (outlen (:pointer :char)) @@ -251,7 +346,8 @@ We should also limit allowed ciphers, but we do not.") (function make-http2-tls-context :replacement make-tls-context))) (defmacro with-ssl-context ((ctx dispatcher) &body body) - "Run body with SSL context created by MAKE-TLS-CONTEXT in CTX." + "Run body with SSL context created by MAKE-TLS-CONTEXT in CTX. Free the context +when leaving the BODY." (check-type ctx symbol) `(let ((,ctx (make-tls-context ,dispatcher))) (unwind-protect