From 84746e69d22d08911b9a9fd98ca6e44f844ae213 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Sat, 20 Dec 2025 14:31:10 +0100 Subject: [PATCH 01/32] Available-Window-Size function --- core/payload-streams.lisp | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/core/payload-streams.lisp b/core/payload-streams.lisp index d3bccc9..3ab74e5 100644 --- a/core/payload-streams.lisp +++ b/core/payload-streams.lisp @@ -16,11 +16,20 @@ (mgl-pax:defsection @overlay () - (http2-stream-with-input-stream class)) + (http2-stream-with-input-stream class) + (available-window-size function)) + +(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))) + + (defmethod stream-element-type ((stream binary-stream)) '(unsigned-byte 8)) + (defclass payload-stream (binary-stream) ((base-http2-stream :accessor get-base-http2-stream :initarg :base-http2-stream)) @@ -78,7 +87,7 @@ Special cases: (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)) + (available-window-size stream connection) base-http2-stream connection)))) (defmethod close ((stream payload-output-stream) &key &allow-other-keys) @@ -123,15 +132,14 @@ Return new START." (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 ()))))) (define-condition window-is-closed (condition) From 8abcf70e826c7a38cf4bf4f06a5bd0257c4fed1c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Tue, 23 Dec 2025 15:37:32 +0100 Subject: [PATCH 02/32] Documentation and small changes. --- core/payload-streams.lisp | 92 ++++++++++++++++++++++++++++----------- overview.lisp | 7 +-- package.lisp | 2 +- server/dispatch.lisp | 52 +++++++++++++++------- 4 files changed, 105 insertions(+), 48 deletions(-) diff --git a/core/payload-streams.lisp b/core/payload-streams.lisp index 3ab74e5..ea499b5 100644 --- a/core/payload-streams.lisp +++ b/core/payload-streams.lisp @@ -14,21 +14,44 @@ ;;;; -> transport stream ;;;; -(mgl-pax:defsection @overlay - () - (http2-stream-with-input-stream class) - (available-window-size function)) +(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)) (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))) - - -(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) @@ -37,11 +60,12 @@ frame for the stream more than this." "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)) + ((output-buffer :accessor get-output-buffer)) (: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) ")) + "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.")) (defmethod initialize-instance :after ((stream payload-output-stream) &key @@ -57,12 +81,6 @@ enough to send the data as a data frame on BASE-HTTP2-STREAM (or forced to by cl (with-slots (connection peer-window-size state) 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 @@ -141,23 +159,41 @@ Return new START." (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) + "Write binary sequence to the payload stream. + +The stream possibly already has some data in its OUTPUT-BUFFER, and we add some. + +Write out as many maximum size data frames as possible. +Cases: + +- We have more than max-peer-frame-size data, and peer window is above it -> we can send a frame or more +- 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 +" (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 (let ((total-length (- (+ (or end (length sequence)) (length (get-output-buffer stream))) start))) @@ -165,6 +201,10 @@ Return new START." 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/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..51c60e2 100644 --- a/package.lisp +++ b/package.lisp @@ -27,7 +27,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..7dc6791 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. @@ -415,7 +430,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 +463,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, From 5bd0306f6275832a1aa5d25afe8f62abbd1c34ee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Tue, 30 Dec 2025 18:03:17 +0100 Subject: [PATCH 03/32] Window management is now part of the HTTP/2 stream class. --- core/classes.lisp | 2 +- core/frames.lisp | 8 +- core/frames/data.lisp | 189 +++++++++++++++++++++++++++++++++++--- core/payload-streams.lisp | 112 +++++++--------------- core/utils.lisp | 8 +- 5 files changed, 222 insertions(+), 97 deletions(-) diff --git a/core/classes.lisp b/core/classes.lisp index 3b1021e..c962f1d 100644 --- a/core/classes.lisp +++ b/core/classes.lisp @@ -113,7 +113,7 @@ 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) diff --git a/core/frames.lisp b/core/frames.lisp index 8f54c26..00240b6 100644 --- a/core/frames.lisp +++ b/core/frames.lisp @@ -12,9 +12,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)) diff --git a/core/frames/data.lisp b/core/frames/data.lisp index 60b4740..3489f57 100644 --- a/core/frames/data.lisp +++ b/core/frames/data.lisp @@ -17,11 +17,16 @@ 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-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-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 @@ -30,7 +35,138 @@ handler for /long in the demo.lisp example.")) "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-OPEN-FN).")) + +(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 and +FLUSH-STREAM-BUFFER uses generic functions WRITE-BUFFERED-FRAME and 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 sufficient window not available.") + (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 + (when (= (fill-pointer output-buffer)) (array-dimension output-buffer 0) + (adjust-array output-buffer (* 2 (array-dimension output-buffer 0)))) + (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))) + (when (>= new-fill (array-dimension output-buffer 0)) + (adjust-array output-buffer (min new-fill + (* 2 (array-dimension output-buffer 0))))) + (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) @@ -49,7 +185,6 @@ also tracks a callback to be called when window is increased (WINDOW-OPEN-FN).") ((or null compiled-function) action)) (with-slots (peer-window-size window-open-fn connection) stream (with-slots ((connection-window peer-window-size)) connection - (loop (cond ((null action) (setf window-open-fn nil) @@ -97,8 +232,18 @@ the stream or connection, and possibly calls WINDOW-OPEN-FN.") (:method ((object flow-control-mixin) increment) (with-slots (window-open-fn peer-window-size) object (incf peer-window-size increment) + ;; 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-open-fn (continue-long-write object window-open-fn (get-max-peer-frame-size (get-connection object)))))) + (:method ((object buffered-stream) increment) + (with-slots (window-open-fn peer-window-size) object + (incf peer-window-size increment) + (when (and (send-available-data object) window-open-fn) + (funcall window-open-fn)))) (:method :after ((object multi-part-data-stream) increment) (with-slots (window-size-increment-callback) object @@ -465,7 +610,7 @@ 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 &rest keys &key padded end-stream (start 0) (length (length data))) "``` +---------------+-----------------------------------------------+ | Data (*) ... @@ -477,13 +622,31 @@ 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-frame stream length +data-frame+ keys + (lambda (buffer frame-start data) + (account-write-window-contribution (get-connection stream) + stream length) + (replace buffer data :start1 frame-start :start2 start)) + data)) + +(defun write-data-frame-region (stream data start length &rest keys &key padded end-stream) + "``` + +---------------+-----------------------------------------------+ + | 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." + (declare (ignore padded end-stream) + (octet-vector data)) + (write-frame stream length +data-frame+ keys + (lambda (buffer frame-start data) + (account-write-window-contribution (get-connection stream) + stream length) + (replace buffer data :start1 frame-start :start2 start)) + data)) (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/payload-streams.lisp b/core/payload-streams.lisp index ea499b5..7e79f4d 100644 --- a/core/payload-streams.lisp +++ b/core/payload-streams.lisp @@ -46,11 +46,6 @@ stream, but not for the server." (payload-output-stream class) (http2-stream-with-input-stream class)) -(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))) - (defmethod stream-element-type ((stream binary-stream)) '(unsigned-byte 8)) @@ -60,36 +55,18 @@ frame for the stream more than this." "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 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.")) -(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))) - (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))) -(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. @@ -97,57 +74,46 @@ 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 - (available-window-size stream 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 = (available-window-size http-stream connection) @@ -182,20 +148,10 @@ to sent. Tracks DATA to sent and number of octets actually SENT.")) (defmethod trivial-gray-streams:stream-write-sequence ((stream payload-output-stream) sequence start end &key) - "Write binary sequence to the payload stream. - -The stream possibly already has some data in its OUTPUT-BUFFER, and we add some. - -Write out as many maximum size data frames as possible. -Cases: - -- We have more than max-peer-frame-size data, and peer window is above it -> we can send a frame or more -- 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 -" - (with-output-payload-slots stream + (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) diff --git a/core/utils.lisp b/core/utils.lisp index e0bad56..1638581 100644 --- a/core/utils.lisp +++ b/core/utils.lisp @@ -14,6 +14,7 @@ (aref/wide function) (vector-from-hex-text function) (frame-size type) + (window-size type) (octet-vector type) (trace-object macro) @@ -23,9 +24,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 +31,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 From 2adebd5b78ab0d67adce704fe19a8455a4af02d1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Sun, 15 Feb 2026 18:34:27 +0100 Subject: [PATCH 04/32] Use maybe-grow-buffer. --- core/frames/data.lisp | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/core/frames/data.lisp b/core/frames/data.lisp index 3489f57..739d0fc 100644 --- a/core/frames/data.lisp +++ b/core/frames/data.lisp @@ -139,8 +139,7 @@ Special cases: - Buffer is full -> extend it - Buffer contains more that max peer frame size octets -> send the data out " (with-buffer-slots stream - (when (= (fill-pointer output-buffer)) (array-dimension output-buffer 0) - (adjust-array output-buffer (* 2 (array-dimension output-buffer 0)))) + (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)) @@ -154,9 +153,7 @@ Special cases: (with-buffer-slots stream (let* ((old-fill (fill-pointer output-buffer)) (new-fill (+ (- end start) old-fill))) - (when (>= new-fill (array-dimension output-buffer 0)) - (adjust-array output-buffer (min new-fill - (* 2 (array-dimension output-buffer 0))))) + (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)) From 4c3247645084bcd3800de63b2190df3e3a653c63 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Sun, 15 Feb 2026 18:34:42 +0100 Subject: [PATCH 05/32] Add a test for buffered output. --- tests/frames/data.lisp | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) 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)))))) From caafcda8bd62c9f68f1924d1d9f9a789146985b5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Sun, 15 Feb 2026 18:46:57 +0100 Subject: [PATCH 06/32] Slots of tls-endpoint-core are now invalidated after free. --- tls/openssl.lisp | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/tls/openssl.lisp b/tls/openssl.lisp index eadf0b5..5081e3d 100644 --- a/tls/openssl.lisp +++ b/tls/openssl.lisp @@ -62,8 +62,8 @@ - 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)) + (rbio (bio-new (bio-s-mem)) :type cffi:foreign-pointer) + (wbio (bio-new (bio-s-mem)) :type cffi:foreign-pointer)) (defmethod describe-object ((object tls-endpoint-core) stream) (let ((*print-length* (or *print-length* 30))) @@ -109,13 +109,12 @@ 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 @openssl-context (:title "TLS context") "TLS context is created with MAKE-HTTP2-TLS-CONTEXT, and its use should be From dc1d28c1f4e0d850f1f1dccc9c40aa8cb67d0060 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Sun, 22 Feb 2026 19:06:05 +0100 Subject: [PATCH 07/32] Move aroung logging. --- core/frames/headers.lisp | 13 +++++++++++++ core/utils.lisp | 6 ++++++ server/logging.lisp | 12 ------------ 3 files changed, 19 insertions(+), 12 deletions(-) diff --git a/core/frames/headers.lisp b/core/frames/headers.lisp index 23b5888..7411fd8 100644 --- a/core/frames/headers.lisp +++ b/core/frames/headers.lisp @@ -89,6 +89,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) diff --git a/core/utils.lisp b/core/utils.lisp index 1638581..8f4dd1b 100644 --- a/core/utils.lisp +++ b/core/utils.lisp @@ -367,3 +367,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/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*)) From 4b5730d8fc81d39334b46f2df999b2f7e77e71e0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Sun, 22 Feb 2026 19:48:25 +0100 Subject: [PATCH 08/32] Documentation of openssl wrappers. --- server/poll-openssl.lisp | 15 +++++++++++++-- tls/openssl.lisp | 24 ++++++++++++++++-------- 2 files changed, 29 insertions(+), 10 deletions(-) diff --git a/server/poll-openssl.lisp b/server/poll-openssl.lisp index 454acd1..e12cb8b 100644 --- a/server/poll-openssl.lisp +++ b/server/poll-openssl.lisp @@ -12,7 +12,8 @@ See manual page for SSL_get_error for the overview." (communication-error condition) (ssl-blocked condition) (ssl-wants-read condition) - (ssl-wants-write condition)) + (ssl-wants-write condition) + (simple-communication-error condition)) (define-condition ssl-error-condition (communication-error) ((codes :accessor get-codes :initarg :codes)) @@ -106,7 +107,17 @@ nothing was added to the error stack, and errno was 0.")) (: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." + "Raise appropriate error after a failed openssl call. + +Raises one of SIMPLE-COMMUNICATION-ERROR, SSL-WANTS-WRITE, SSL-WANTS-READ, +PEER-SENT-CLOSE-NOTIFY, SSL-ERROR-CONDITION, SSL-SYSCALL-ERROR, or +OTHER-SSL-ERROR. + +If ret>0 (no fail), returns nil." + ;; 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))) diff --git a/tls/openssl.lisp b/tls/openssl.lisp index 5081e3d..51cdfab 100644 --- a/tls/openssl.lisp +++ b/tls/openssl.lisp @@ -5,11 +5,18 @@ (t (:default "libssl.3"))) (defsection @openssl (:title "Openssl interface") - "Wraps openssl calls." - (@openssl-endpoint section) - (@openssl-context section)) + "Wrapper library over openssl functions. + +@OPENSSL-ENDPOINT wraps the SSL parameter used in openssl functions. -(export '(handle-ssl-errors* with-ssl-context encrypt-some* bio-should-retry)) +@OPENSSL-CONTEXT wraps the CTX parameter used in openssl functions" + (handle-ssl-errors* function) + (encrypt-some* function) + (bio-should-retry function) + (with-ssl-context macro) + (@openssl-endpoint section) + (@openssl-context section) + (@ssl-errors section)) (export '(neg-bio-needs-read peer-open has-data-to-encrypt can-write-ssl can-read-bio @@ -19,11 +26,11 @@ bio-read% ssl-is-init-finished ssl-accept ssl-connect)) (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)) (use-foreign-library openssl) @@ -78,7 +85,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 +95,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)) @@ -250,7 +257,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 From 4e3cc321b1b820a1b53b2bdb74b5a7ff619162e2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Sun, 22 Feb 2026 19:59:36 +0100 Subject: [PATCH 09/32] Documentation of openssl wrappers. --- server/poll-openssl.lisp | 20 ++++++++++++++++++-- tls/openssl.lisp | 15 +-------------- 2 files changed, 19 insertions(+), 16 deletions(-) diff --git a/server/poll-openssl.lisp b/server/poll-openssl.lisp index e12cb8b..5afb8c2 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. + +@OPENSSL-ENDPOINT wraps the SSL parameter used in openssl functions. + +@OPENSSL-CONTEXT wraps the CTX parameter used in openssl functions" + (bio-should-retry function) + (@openssl-endpoint section) + (@openssl-context section) + (@ssl-ops section) (@ssl-errors section)) (defsection @SSL-errors (:title "Signalled errors") @@ -9,11 +17,16 @@ 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) + (simple-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)) @@ -146,6 +159,9 @@ If ret>0 (no fail), returns nil." (error 'ssl-syscall-error :codes (get-ssl-errors) :errno errno :medium client)))) (t (error 'other-ssl-error :code err-code :medium client))))) +(defsection @ssl-ops () + (encrypt-some* function)) + (defun encrypt-some* (client vector from to) "Encrypt octets in VECTOR between FROM and TO. Return number of octets processed, or raise appropriate error." diff --git a/tls/openssl.lisp b/tls/openssl.lisp index 51cdfab..9decb4e 100644 --- a/tls/openssl.lisp +++ b/tls/openssl.lisp @@ -4,20 +4,6 @@ #-os-macosx (:unix "libssl.so") (t (:default "libssl.3"))) -(defsection @openssl (:title "Openssl interface") - "Wrapper library over openssl functions. - -@OPENSSL-ENDPOINT wraps the SSL parameter used in openssl functions. - -@OPENSSL-CONTEXT wraps the CTX parameter used in openssl functions" - (handle-ssl-errors* function) - (encrypt-some* function) - (bio-should-retry function) - (with-ssl-context macro) - (@openssl-endpoint section) - (@openssl-context section) - (@ssl-errors section)) - (export '(neg-bio-needs-read peer-open has-data-to-encrypt can-write-ssl can-read-bio ; bio-s-mem bio-new ssl-new @@ -126,6 +112,7 @@ This is factored out so that it can be used in structures that inherit TLS-CORE. (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.") From 83f3e8a20c1e74e2aa38a46b4e79ba1ddddea089 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Mon, 23 Feb 2026 07:41:16 +0100 Subject: [PATCH 10/32] SSL states are now in general openssl code. --- server/poll-openssl.lisp | 15 ++++- server/poll-server.lisp | 105 +---------------------------- tls/openssl.lisp | 140 +++++++++++++++++++++++++++++++++------ 3 files changed, 133 insertions(+), 127 deletions(-) diff --git a/server/poll-openssl.lisp b/server/poll-openssl.lisp index 5afb8c2..dc9fe9e 100644 --- a/server/poll-openssl.lisp +++ b/server/poll-openssl.lisp @@ -17,7 +17,7 @@ conditions. They are descended from the COMMUNICATION-ERROR. See manual page for SSL_get_error for the overview." - (handle-ssl-errors* function) + (handle-ssl-errors function) (communication-error condition) (simple-communication-error condition) (ssl-blocked condition) @@ -159,6 +159,19 @@ If ret>0 (no fail), returns nil." (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." + (handler-case (handle-ssl-errors* client ret) + (ssl-wants-read () (remove-state client 'neg-bio-needs-read)))) + (defsection @ssl-ops () (encrypt-some* function)) diff --git a/server/poll-server.lisp b/server/poll-server.lisp index 98f6c13..bd756ac 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,7 +124,7 @@ 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) +; (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 @@ -631,19 +541,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 diff --git a/tls/openssl.lisp b/tls/openssl.lisp index 9decb4e..63c4b2b 100644 --- a/tls/openssl.lisp +++ b/tls/openssl.lisp @@ -4,21 +4,6 @@ #-os-macosx (:unix "libssl.so") (t (:default "libssl.3"))) -(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") - "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)) - (use-foreign-library openssl) (defcfun "BIO_new" :pointer (bio-method :pointer)) @@ -43,20 +28,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)) + +(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) - (wbio (bio-new (bio-s-mem)) :type cffi:foreign-pointer)) +- 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))) @@ -109,6 +107,104 @@ This is factored out so that it can be used in structures that inherit TLS-CORE. (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." + "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)) + +(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)) + +;;;; 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) + (tls-endpoint-core-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) + (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." From 91f4e1e5b66fbf77a006f7c9e06d756d864deb9c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Mon, 23 Feb 2026 10:40:34 +0100 Subject: [PATCH 11/32] Move or factor out non-server ssl code to proper file. --- server/poll-openssl.lisp | 85 ++++++++++++++++++++++++++++++++++++---- server/poll-server.lisp | 69 ++------------------------------ tls/openssl.lisp | 32 +++++++++------ 3 files changed, 99 insertions(+), 87 deletions(-) diff --git a/server/poll-openssl.lisp b/server/poll-openssl.lisp index dc9fe9e..364d112 100644 --- a/server/poll-openssl.lisp +++ b/server/poll-openssl.lisp @@ -172,19 +172,88 @@ Raise error otherwise." (handler-case (handle-ssl-errors* client ret) (ssl-wants-read () (remove-state client 'neg-bio-needs-read)))) + (defsection @ssl-ops () - (encrypt-some* function)) + "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)) (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 read the encrypted octets later by READ-ENCRYPTED-FROM-OPENSSL*." (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) - 0))))) + (handler-case + (let* ((ssl (tls-endpoint-core-ssl client)) + (res (ssl-write ssl (inc-pointer buffer from) (- to from)))) + (cond + ((plusp res) + (add-state client 'can-read-bio) + res) + ;; no-star handle-ssl-errors masks SSL-WANTS-READ + (t (handle-ssl-errors* client res) + 0))) + (ssl-blocked () + (remove-state client 'can-write-ssl))))) (defun bio-should-retry (wbio) (bio-test-flags wbio bio-flags-should-retry)) + +(defun read-encrypted-from-openssl* (client vec size) + (declare ((simple-array (unsigned-byte 8)) vec) + (fixnum size)) + (with-pointer-to-vector-data (buffer vec) + (let ((res (bio-read% (tls-endpoint-core-wbio client) buffer size))) + (cond ((plusp res) + (add-state client 'has-data-to-write) + res) + ((zerop (bio-should-retry (tls-endpoint-core-wbio client))) + (error "Failed to read from bio, and cant retry")) + (t + (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." + (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")) + 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)))) + +;;;; 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% (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) + "Move up to SIZE octets from the decrypted SSL ③ to the VEC. + +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) + (http2/openssl::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 bd756ac..d226f3c 100644 --- a/server/poll-server.lisp +++ b/server/poll-server.lisp @@ -124,7 +124,6 @@ The actions are in general indicated by arrows in the diagram: (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 @@ -226,18 +225,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 ." @@ -254,31 +243,6 @@ available. Raise an error on error." vector destination) (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)))) - ;;;; Encrypt queue (defun add-and-maybe-pass-data (client buffer new-data from to old-size cleaner) "Add new data to buffer if they fit. @@ -332,16 +296,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. @@ -358,18 +314,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 Ⓔ. @@ -541,14 +486,6 @@ Repeat on partial write." ((zerop written) (return from)))))) -(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)) diff --git a/tls/openssl.lisp b/tls/openssl.lisp index 63c4b2b..b7499eb 100644 --- a/tls/openssl.lisp +++ b/tls/openssl.lisp @@ -133,15 +133,18 @@ 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) - + (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-bio can-read-port can-read-ssl ssl-init-needed ; bio-s-mem bio-new ssl-new - ssl-set-accept-state + ssl-set-accept-state can-write has-data-to-write bio-write ssl-read% ssl-error-condition err-reason-error-string bio-read% ssl-is-init-finished ssl-accept ssl-connect)) @@ -159,16 +162,18 @@ MAYBE-INIT-SSL. It is cleared by an error condition in HANDLE-SSL-ERRORS." ) "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))))) + (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 () +(deftype openssl-state () "Description of actions available to the endpoint." `(unsigned-byte ,(length *states*))) @@ -176,12 +181,12 @@ MAYBE-INIT-SSL. It is cleared by an error condition in HANDLE-SSL-ERRORS." `(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)))) -(declaim (inline if-state add-state remove-state if-state* test-state*)) - (defun if-state (client state) (if-state* client (state-idx state))) @@ -205,6 +210,7 @@ MAYBE-INIT-SSL. It is cleared by an error condition in HANDLE-SSL-ERRORS." 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." @@ -253,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)) From 9352c5c58340dc5461aefed011bd805db9ad0c02 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Mon, 23 Feb 2026 17:25:24 +0100 Subject: [PATCH 12/32] Documentation in openssl --- server/poll-openssl.lisp | 36 +++++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 15 deletions(-) diff --git a/server/poll-openssl.lisp b/server/poll-openssl.lisp index 364d112..04aec03 100644 --- a/server/poll-openssl.lisp +++ b/server/poll-openssl.lisp @@ -140,6 +140,7 @@ If ret>0 (no fail), returns nil." (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)) ((= err-code ssl-error-want-read) ;; This is relevant for accept call and handled in loop @@ -182,22 +183,25 @@ Raise error otherwise." (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. You can read the encrypted octets later by READ-ENCRYPTED-FROM-OPENSSL*." +processed, or raise appropriate error. You can read the encrypted octets later +by READ-ENCRYPTED-FROM-OPENSSL*." (with-pointer-to-vector-data (buffer vector) - (handler-case - (let* ((ssl (tls-endpoint-core-ssl client)) - (res (ssl-write ssl (inc-pointer buffer from) (- to from)))) - (cond - ((plusp res) - (add-state client 'can-read-bio) - res) - ;; no-star handle-ssl-errors masks SSL-WANTS-READ - (t (handle-ssl-errors* client res) - 0))) - (ssl-blocked () - (remove-state client 'can-write-ssl))))) + (handler-case + (let* ((ssl (tls-endpoint-core-ssl client)) + (res (ssl-write ssl (inc-pointer buffer from) (- to from)))) + (cond + ((plusp res) + (add-state client 'can-read-bio) + res) + ;; no-star handle-ssl-errors masks SSL-WANTS-READ + (t (handle-ssl-errors* client res) + 0))) + (ssl-blocked () + ;; CAN-WRITE-SSL is not same as NEG-BIO-NEEDS-READ + (remove-state client 'can-write-ssl))))) (defun bio-should-retry (wbio) (bio-test-flags wbio bio-flags-should-retry)) @@ -233,7 +237,7 @@ processed, or raise appropriate error. You can read the encrypted octets later b (t (remove-state client 'ssl-init-needed) (add-state client 'can-read-bio)))) -;;;; Read SSL +;;;; Read decrypted data (defun ssl-read (client vec size) "Move up to SIZE octets from the decrypted SSL ③ to the VEC. @@ -247,7 +251,9 @@ NEG-BIO-NEEDS-READ flags." (max 0 res))) (defun ssl-peek (client max-size) - "Move up to SIZE octets from the decrypted SSL ③ to the VEC. + "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)) From 020862e2150358c612a2155e38f096d0880e76dd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Mon, 23 Feb 2026 18:45:34 +0100 Subject: [PATCH 13/32] More openssl cleanup. --- server/poll-openssl.lisp | 91 +++++++++++++++------------------------- 1 file changed, 33 insertions(+), 58 deletions(-) diff --git a/server/poll-openssl.lisp b/server/poll-openssl.lisp index 04aec03..2ed22a7 100644 --- a/server/poll-openssl.lisp +++ b/server/poll-openssl.lisp @@ -20,9 +20,6 @@ See manual page for SSL_get_error for the overview." (handle-ssl-errors function) (communication-error condition) (simple-communication-error condition) - (ssl-blocked condition) - (ssl-wants-read condition) - (ssl-wants-write condition) (peer-sent-close-notify condition) (ssl-error-condition condition) (ssl-syscall-error condition) @@ -88,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 ")) @@ -119,14 +99,21 @@ 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) +(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. -Raises one of SIMPLE-COMMUNICATION-ERROR, SSL-WANTS-WRITE, SSL-WANTS-READ, -PEER-SENT-CLOSE-NOTIFY, SSL-ERROR-CONDITION, SSL-SYSCALL-ERROR, or -OTHER-SSL-ERROR. +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. -If ret>0 (no fail), returns nil." +" ;; 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() @@ -137,19 +124,14 @@ If ret>0 (no fail), returns nil." (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))) @@ -170,8 +152,7 @@ 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)))) + (handle-ssl-errors* client ret (state-idx 'neg-bio-needs-read) nil)) ; FIXME: write status (defsection @ssl-ops () @@ -186,37 +167,31 @@ Raise error otherwise." ; 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. You can read the encrypted octets later -by READ-ENCRYPTED-FROM-OPENSSL*." +processed, or raise appropriate error. You can try to read the encrypted octets +later by READ-ENCRYPTED-FROM-OPENSSL*." + (declare (type (integer 0 #.array-dimension-limit) from to)) (with-pointer-to-vector-data (buffer vector) - (handler-case - (let* ((ssl (tls-endpoint-core-ssl client)) - (res (ssl-write ssl (inc-pointer buffer from) (- to from)))) - (cond - ((plusp res) - (add-state client 'can-read-bio) - res) - ;; no-star handle-ssl-errors masks SSL-WANTS-READ - (t (handle-ssl-errors* client res) - 0))) - (ssl-blocked () - ;; CAN-WRITE-SSL is not same as NEG-BIO-NEEDS-READ - (remove-state client 'can-write-ssl))))) - -(defun bio-should-retry (wbio) - (bio-test-flags wbio bio-flags-should-retry)) + (let* ((ssl (tls-endpoint-core-ssl client)) + (res (ssl-write ssl (inc-pointer buffer from) (- to from)))) + (cond + ((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 read-encrypted-from-openssl* (client vec size) (declare ((simple-array (unsigned-byte 8)) vec) (fixnum size)) (with-pointer-to-vector-data (buffer vec) - (let ((res (bio-read% (tls-endpoint-core-wbio client) buffer size))) + (let* ((wbio (tls-endpoint-core-wbio client)) + (res (bio-read% wbio buffer size))) (cond ((plusp res) (add-state client 'has-data-to-write) res) - ((zerop (bio-should-retry (tls-endpoint-core-wbio client))) - (error "Failed to read from bio, and cant retry")) (t + (bio-should-retry wbio client) (remove-state client 'can-read-bio) 0))))) @@ -260,6 +235,6 @@ Return 0 when no data are available." (let* ((vec (make-octet-buffer max-size)) (res (with-pointer-to-vector-data (buffer vec) - (http2/openssl::ssl-peek% (tls-endpoint-core-ssl client) buffer max-size)))) + (ssl-peek% (tls-endpoint-core-ssl client) buffer max-size)))) (handle-ssl-errors client res) (values (subseq vec 0 (max 0 res)) res)))) From a169a2ce72a6b14fd02915f7e61437ecc3f4401a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Sun, 1 Mar 2026 14:45:08 +0100 Subject: [PATCH 14/32] poll-openssl doc --- server/poll-openssl.lisp | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/server/poll-openssl.lisp b/server/poll-openssl.lisp index 2ed22a7..5764f9a 100644 --- a/server/poll-openssl.lisp +++ b/server/poll-openssl.lisp @@ -3,10 +3,10 @@ (defsection @SSL (:title "SSL handling") "Wrapper library over openssl functions. -@OPENSSL-ENDPOINT wraps the SSL parameter used in openssl functions. +TLS-ENDPOINT-CORE wraps the SSL parameter used in openssl functions. The functions that use it are listed in @SSL-OPS. -@OPENSSL-CONTEXT wraps the CTX parameter used in openssl functions" - (bio-should-retry function) +" +#+nil (bio-should-retry function) (@openssl-endpoint section) (@openssl-context section) (@ssl-ops section) From aab7bc90009ca3383cd98addea76dc72817db03e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Sun, 1 Mar 2026 14:46:41 +0100 Subject: [PATCH 15/32] WRITE-OCTETS-TO-DECRYPT* handles its states. --- server/poll-openssl.lisp | 7 ++++++- server/poll-server.lisp | 7 +------ 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/server/poll-openssl.lisp b/server/poll-openssl.lisp index 5764f9a..c963eb1 100644 --- a/server/poll-openssl.lisp +++ b/server/poll-openssl.lisp @@ -196,12 +196,17 @@ later by READ-ENCRYPTED-FROM-OPENSSL*." 0))))) (defun write-octets-to-decrypt* (client vector from to) - "Send octets in VECTOR for decryption. Read result with SSL-READ later." + "Send octets in VECTOR for decryption. Read result with SSL-READ later. + +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)." (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-write-ssl) written))) (defun maybe-init-ssl (client) diff --git a/server/poll-server.lisp b/server/poll-server.lisp index d226f3c..b19e108 100644 --- a/server/poll-server.lisp +++ b/server/poll-server.lisp @@ -236,12 +236,7 @@ available. Raise an error on error." vector destination) (defun process-data-on-socket (client) "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))) + (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) From 01f3850c32a82ffcfc545f24525488aa347a4519 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Mon, 2 Mar 2026 18:15:26 +0100 Subject: [PATCH 16/32] Cleanup of ssl states. --- server/poll-openssl.lisp | 37 ++++++++++++++++++++++++++----------- server/poll-server.lisp | 17 +++++++---------- 2 files changed, 33 insertions(+), 21 deletions(-) diff --git a/server/poll-openssl.lisp b/server/poll-openssl.lisp index c963eb1..98f0ac1 100644 --- a/server/poll-openssl.lisp +++ b/server/poll-openssl.lisp @@ -152,7 +152,7 @@ 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 'neg-bio-needs-read) nil)) ; FIXME: write status + (handle-ssl-errors* client ret (state-idx 'can-read-ssl) nil)) ; FIXME: write status (defsection @ssl-ops () @@ -168,8 +168,10 @@ Raise error otherwise." (defun encrypt-some* (client vector from to) "Encrypt octets in VECTOR between FROM and TO. Return number of octets processed, or raise appropriate error. You can try to read the encrypted octets -later by READ-ENCRYPTED-FROM-OPENSSL*." +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)))) @@ -182,13 +184,19 @@ later by READ-ENCRYPTED-FROM-OPENSSL*." 0))))) (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 'has-data-to-write) + (add-state client 'can-read-ssl) + (add-state client 'can-write-ssl) res) (t (bio-should-retry wbio client) @@ -198,14 +206,19 @@ later by READ-ENCRYPTED-FROM-OPENSSL*." (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)." +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))) @@ -215,20 +228,22 @@ written to again (or at least it could be tried)." ((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-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 and/or -NEG-BIO-NEEDS-READ flags." - (let ((res +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))) + (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. diff --git a/server/poll-server.lisp b/server/poll-server.lisp index b19e108..9e02743 100644 --- a/server/poll-server.lisp +++ b/server/poll-server.lisp @@ -124,9 +124,6 @@ The actions are in general indicated by arrows in the diagram: (octets-needed 0 :type fixnum) (encrypt-buf-size 0 :type fixnum) (start-time (get-internal-real-time) :type fixnum) - ;; 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* @@ -235,6 +232,7 @@ 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)) @@ -317,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) @@ -351,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) @@ -386,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)) @@ -398,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))) @@ -613,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)) From 7f45bace94e47f6c470af2fe5fb84e2dd3fe702a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Mon, 2 Mar 2026 18:16:38 +0100 Subject: [PATCH 17/32] Add some ftypes. --- server/tcpip.lisp | 2 ++ tls/openssl.lisp | 4 ++++ 2 files changed, 6 insertions(+) diff --git a/server/tcpip.lisp b/server/tcpip.lisp index 40ed820..0fa6a4a 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)) diff --git a/tls/openssl.lisp b/tls/openssl.lisp index b7499eb..d9856c7 100644 --- a/tls/openssl.lisp +++ b/tls/openssl.lisp @@ -6,6 +6,10 @@ (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) From 861ab828715802129ccc78acde370174c476e974 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Mon, 2 Mar 2026 18:16:55 +0100 Subject: [PATCH 18/32] More robust test code. --- tests/high-level.lisp | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) 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) From 311d2386ef476e5ba8a5a0097a9c7aceb20c29dd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Mon, 2 Mar 2026 18:17:56 +0100 Subject: [PATCH 19/32] Fix test, doc update. --- tests/poll-server.lisp | 1 - tls/openssl.lisp | 10 +++------- 2 files changed, 3 insertions(+), 8 deletions(-) diff --git a/tests/poll-server.lisp b/tests/poll-server.lisp index a80aef5..a29c3da 100644 --- a/tests/poll-server.lisp +++ b/tests/poll-server.lisp @@ -53,7 +53,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) diff --git a/tls/openssl.lisp b/tls/openssl.lisp index d9856c7..e1b3d31 100644 --- a/tls/openssl.lisp +++ b/tls/openssl.lisp @@ -32,14 +32,14 @@ (defcfun "SSL_set_bio" :void (ssl :pointer) (rbio :pointer) (wbio :pointer)) (defcfun "SSL_write" :int (ssl :pointer) (buffer :pointer) (bufsize :int)) - (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)) + (close-openssl function) + (@poll-tls-states section)) (locally (declare (special *initial-state*)) @@ -130,10 +130,6 @@ 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?" @@ -148,7 +144,7 @@ MAYBE-INIT-SSL. It is cleared by an error condition in HANDLE-SSL-ERRORS." (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 has-data-to-write + 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)) From 39fe4d190d29ef1c971acadd8e9ea33ae7e2f321 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Wed, 1 Apr 2026 21:39:15 +0200 Subject: [PATCH 20/32] Some items in poll-server tests were commented out. --- tests/poll-server.lisp | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/tests/poll-server.lisp b/tests/poll-server.lisp index a29c3da..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 ()) @@ -144,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. @@ -168,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))))) From a7b1cb40a90645985c07c3c5fc74b58819080aeb Mon Sep 17 00:00:00 2001 From: John Mallery Date: Wed, 1 Apr 2026 19:17:38 +0200 Subject: [PATCH 21/32] Add http2/resources: lock-free buffer pool with fill-pointer arrays and regions Global buffer pool for octet buffers with three size classes: Small (16B, max 64 free), Medium (1KB, max 32), Large (16KB, max 32). Lock-free via CAS (Treiber stack): sb-ext:cas on SBCL, sys:compare-and-swap on LW, generic lock fallback. allocate-buffer returns fill-pointer arrays with fp = requested size. (length buffer) returns the requested size; array-total-size returns the size-class capacity. deallocate-buffer resets fp before pooling. with-resource-usage-region: scope-based deallocation for buffers that escape local management (e.g., HEADERS continuation closures). region-track-buffer transfers ownership to the region. Measured on SBCL (50 H2 GET + 10 POST, Apple M3): Small: 2 allocated, 2402 recycled (1201:1) Medium: 5 allocated, 1419 recycled (284:1) Large: 1 allocated, 9 recycled (9:1) --- core/buffer-pool.lisp | 283 +++++++++++++++++++++++++++++ core/frames.lisp | 5 +- core/frames/headers.lisp | 4 +- core/hpack.lisp | 2 +- core/stream-based-connections.lisp | 9 +- 5 files changed, 295 insertions(+), 8 deletions(-) create mode 100644 core/buffer-pool.lisp diff --git a/core/buffer-pool.lisp b/core/buffer-pool.lisp new file mode 100644 index 0000000..c694d88 --- /dev/null +++ b/core/buffer-pool.lisp @@ -0,0 +1,283 @@ +;;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: http2/resources; Base: 10 -*- +;;;; +;;;; 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. +;;;; + +(defpackage http2/resources + (:use :common-lisp) + (:export + ;; CAS primitives (available for other lock-free patterns) + "ATOMIC-PUSH" + "ATOMIC-POP" + ;; Buffer pool + "ALLOCATE-BUFFER" + "DEALLOCATE-BUFFER" + "WITH-POOLED-BUFFER" + "BUFFER-POOL-STATS" + "CLEAR-BUFFER-POOL" + ;; Buffer regions (scope-based deallocation) + "WITH-RESOURCE-USAGE-REGION" + "REGION-TRACK-BUFFER")) + +(in-package :http2/resources) + +;;;------------------------------------------------------------------- +;;; +;;; COMPARE-AND-SWAP PRIMITIVES +;;; +;;; Lock-free atomic push/pop on a cons cell head pointer. +;;; Port-specific CAS with generic fallback. +;;; + +#+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))))) + +;;;------------------------------------------------------------------- +;;; +;;; 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. +;;; + +(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/frames.lisp b/core/frames.lisp index 00240b6..7f96333 100644 --- a/core/frames.lisp +++ b/core/frames.lisp @@ -406,6 +406,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)))) @@ -447,7 +448,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)) @@ -486,7 +487,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/headers.lisp b/core/frames/headers.lisp index 7411fd8..c00e753 100644 --- a/core/frames/headers.lisp +++ b/core/frames/headers.lisp @@ -333,7 +333,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) @@ -369,7 +369,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/hpack.lisp b/core/hpack.lisp index 247b9d7..8d1516e 100644 --- a/core/hpack.lisp +++ b/core/hpack.lisp @@ -544,7 +544,7 @@ 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) diff --git a/core/stream-based-connections.lisp b/core/stream-based-connections.lisp index 52c41d6..05cd71c 100644 --- a/core/stream-based-connections.lisp +++ b/core/stream-based-connections.lisp @@ -35,15 +35,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 From 935398a6f3f69a3a8fcea6c3a8b4c77c44c33147 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Thu, 2 Apr 2026 11:26:21 +0200 Subject: [PATCH 22/32] Align buffer pool to project conventions. - Add to .asd and package.lisp - Move documentation to mgl-pax. - Align file and package name - Use buffer-pool package from core --- core/buffer-pool.lisp | 89 ++++++++++++++++++------------------------- http2.asd | 1 + package.lisp | 8 +++- 3 files changed, 45 insertions(+), 53 deletions(-) diff --git a/core/buffer-pool.lisp b/core/buffer-pool.lisp index c694d88..e8b8cf2 100644 --- a/core/buffer-pool.lisp +++ b/core/buffer-pool.lisp @@ -1,44 +1,33 @@ ;;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: http2/resources; Base: 10 -*- -;;;; -;;;; 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. -;;;; - -(defpackage http2/resources - (:use :common-lisp) - (:export - ;; CAS primitives (available for other lock-free patterns) - "ATOMIC-PUSH" - "ATOMIC-POP" - ;; Buffer pool - "ALLOCATE-BUFFER" - "DEALLOCATE-BUFFER" - "WITH-POOLED-BUFFER" - "BUFFER-POOL-STATS" - "CLEAR-BUFFER-POOL" - ;; Buffer regions (scope-based deallocation) - "WITH-RESOURCE-USAGE-REGION" - "REGION-TRACK-BUFFER")) - -(in-package :http2/resources) -;;;------------------------------------------------------------------- -;;; -;;; COMPARE-AND-SWAP PRIMITIVES -;;; -;;; Lock-free atomic push/pop on a cons cell head pointer. -;;; Port-specific CAS with generic fallback. -;;; +(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) @@ -210,18 +199,16 @@ VAR may be larger than SIZE — use :end to delimit the active region." (progn ,@body) (deallocate-buffer ,buf-var))))) -;;;------------------------------------------------------------------- -;;; -;;; 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. -;;; +(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. 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/package.lisp b/package.lisp index 51c60e2..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) From 854be29e2cc61fcd5706bae28049a2291a801291 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Thu, 2 Apr 2026 19:48:18 +0200 Subject: [PATCH 23/32] HTTP-STREAM-ERROR now derives from ERROR and error reporting changes. HTTP-STREAM-ERROR now derives from ERROR. There is a specific subclass to be raised when we receive the stream error from the peer, as opposed from when we detect it. --- core/errors.lisp | 40 ++++++++++++++++++++++++--------- core/frames/rst-and-goaway.lisp | 16 ++++++++----- 2 files changed, 39 insertions(+), 17 deletions(-) diff --git a/core/errors.lisp b/core/errors.lisp index 6c0879e..f546588 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) @@ -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,33 +213,45 @@ 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))))) + (format out "~a" + (or (documentation (class-of err) t) + (documentation (get-error-name code) 'variable)))))) + +(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.")) + "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.")) + "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.")) + "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.")) + "Received PING frame with a length field value other than 8 (Section 5.4.1)")) (define-condition incorrect-window-update-frame-size (connection-error) () @@ -253,18 +269,20 @@ size (2^24-1 or 16,777,215 octets), inclusive.")) (define-condition stream-protocol-error (http-stream-error) () - (:default-initargs :code +protocol-error+)) + (:default-initargs :code +protocol-error+) + (:documentation "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/rst-and-goaway.lisp b/core/frames/rst-and-goaway.lisp index 7fc54e1..0d2b3fe 100644 --- a/core/frames/rst-and-goaway.lisp +++ b/core/frames/rst-and-goaway.lisp @@ -64,16 +64,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 "``` From 4b8ce7e2cfe8c38d38aadd1772642e6de4cb534e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Fri, 3 Apr 2026 21:39:57 +0200 Subject: [PATCH 24/32] Streamline writing DATA payload (one data copy removed) New generic function QUEUE-FRAME-REGION to write only part of the provided data. Falls back to QUEUE-FRAME. WRITE-VECTOR-FRAME can be now used to send prepared data vector without copying it, providing QUEUE-FRAME-REGION is specialized for the connection to avoid copying. QUEUE-FRAME-REGION uses WRITE-VECTOR-FRAME now. --- core/frames.lisp | 29 +++++++++++++++++++++++++++++ core/frames/data.lisp | 20 +++++--------------- 2 files changed, 34 insertions(+), 15 deletions(-) diff --git a/core/frames.lisp b/core/frames.lisp index 7f96333..2d68e34 100644 --- a/core/frames.lisp +++ b/core/frames.lisp @@ -77,6 +77,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: @@ -396,6 +406,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 diff --git a/core/frames/data.lisp b/core/frames/data.lisp index 739d0fc..8b517db 100644 --- a/core/frames/data.lisp +++ b/core/frames/data.lisp @@ -607,7 +607,7 @@ As always, use untrace to stop tracing." nil nil) -(defun write-data-frame (stream data &rest keys &key padded end-stream (start 0) (length (length data))) +(defun write-data-frame (stream data &key padded end-stream (start 0) (length (length data))) "``` +---------------+-----------------------------------------------+ | Data (*) ... @@ -617,14 +617,7 @@ As always, use untrace to stop tracing." 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." - (declare (ignore padded end-stream) - (octet-vector data)) - (write-frame stream length +data-frame+ keys - (lambda (buffer frame-start data) - (account-write-window-contribution (get-connection stream) - stream length) - (replace buffer data :start1 frame-start :start2 start)) - data)) + (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) "``` @@ -638,12 +631,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)) - (write-frame stream length +data-frame+ keys - (lambda (buffer frame-start data) - (account-write-window-contribution (get-connection stream) - stream length) - (replace buffer data :start1 frame-start :start2 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." From 626de2b4a6de86cff86cfdfff026215e76d96526 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Sat, 4 Apr 2026 09:24:57 +0200 Subject: [PATCH 25/32] Documentation --- core/classes.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/classes.lisp b/core/classes.lisp index c962f1d..9526edc 100644 --- a/core/classes.lisp +++ b/core/classes.lisp @@ -1,4 +1,4 @@ -;;;; Copyright 2022-2024 by Tomáš Zellerin +;;;; Copyright 2022-2026 by Tomáš Zellerin (in-package :http2/core) From eefdc3b7c44fd1c096ff3480fa6f343d35a55683 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Sat, 4 Apr 2026 09:25:12 +0200 Subject: [PATCH 26/32] Improve errors reporting --- core/errors.lisp | 41 +++++++++++++++++++---------------------- 1 file changed, 19 insertions(+), 22 deletions(-) diff --git a/core/errors.lisp b/core/errors.lisp index f546588..f714a0f 100644 --- a/core/errors.lisp +++ b/core/errors.lisp @@ -109,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) () @@ -119,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) @@ -216,9 +216,7 @@ Base class for more detailed errors.")) (or (documentation (class-of err) t) (documentation (get-error-name code) 'variable)) stream)) - (format out "~a" - (or (documentation (class-of err) t) - (documentation (get-error-name code) 'variable)))))) + (call-next-method)))) (define-condition http-stream-error-received (http-stream-error) ()) @@ -232,32 +230,30 @@ Base class for more detailed errors.")) (define-condition incorrect-frame-size (http-stream-error) () (:default-initargs :code +frame-size-error+) - (:documentation - "Received a PRIORITY frame with a length other than 5 octets (Section 5.4.2)")) + (: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 - "Received a RST_STREAM frame with a length other than 4 octets (Section 5.4.1)")) + (: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 - "Received a SETTINGS frame with a length other than a multiple of 6 (Section 5.4.1)")) + "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 - "Received PING frame with a length field value other than 8 (Section 5.4.1)")) + "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) () @@ -265,12 +261,13 @@ Base class for more detailed errors.")) "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+) - (:documentation "We detected some kind of protocol error.")) + (:report "We detected some kind of protocol error.")) (define-condition header-error (stream-protocol-error) ((name :accessor get-name :initarg :name) From b0c745f06981e6d1da9a352706ff3e4fede2a686 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Sat, 4 Apr 2026 15:33:01 +0200 Subject: [PATCH 27/32] window-open-fn and window-size-increment-callback merged. There were two functions with same interpretation and it did not work. --- core/frames/data.lisp | 76 +++++++++++++++++++------------------------ server/dispatch.lisp | 3 +- 2 files changed, 35 insertions(+), 44 deletions(-) diff --git a/core/frames/data.lisp b/core/frames/data.lisp index 8b517db..cfb9ccc 100644 --- a/core/frames/data.lisp +++ b/core/frames/data.lisp @@ -27,16 +27,14 @@ the windows is maintained by the FLOW-CONTROL-MIXIN." :type window-size) (peer-window-size :accessor get-peer-window-size :initarg :peer-window-size :type 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-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 has an output buffer and tracks a callback to be called when window is -increased (WINDOW-OPEN-FN).")) +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 @@ -46,8 +44,9 @@ frame for the stream more than this." (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 and -FLUSH-STREAM-BUFFER uses generic functions WRITE-BUFFERED-FRAME and to pass the +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) @@ -68,7 +67,7 @@ size for buffers, which is 65536.") (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 sufficient window not available.") +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 @@ -177,75 +176,68 @@ Special cases: 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) ;; 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-open-fn - (continue-long-write object window-open-fn (get-max-peer-frame-size (get-connection object)))))) + (when window-size-increment-callback + (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-open-fn peer-window-size) object + (with-slots (window-size-increment-callback peer-window-size) object (incf peer-window-size increment) - (when (and (send-available-data object) window-open-fn) - (funcall window-open-fn)))) - - (:method :after ((object multi-part-data-stream) increment) - (with-slots (window-size-increment-callback) object - (when window-size-increment-callback - (funcall window-size-increment-callback object))))) + (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." diff --git a/server/dispatch.lisp b/server/dispatch.lisp index 7dc6791..4f7939c 100644 --- a/server/dispatch.lisp +++ b/server/dispatch.lisp @@ -258,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 From 0a47af6263d5ba6f74be12371219b62fb57dcd3c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Zellerin?= Date: Sat, 4 Apr 2026 15:36:19 +0200 Subject: [PATCH 28/32] Fix errors due to closed sockets not having a peer. --- server/tcpip.lisp | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/server/tcpip.lisp b/server/tcpip.lisp index 0fa6a4a..fafd311 100644 --- a/server/tcpip.lisp +++ b/server/tcpip.lisp @@ -343,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))))) From 2892fd888364e57a2c2ff34a484a45b3c0d81338 Mon Sep 17 00:00:00 2001 From: John Mallery Date: Sun, 5 Apr 2026 06:45:38 +0200 Subject: [PATCH 29/32] Move request pseudo-header slots to http2-stream superclass Relocate the method, scheme, authority, path slots from server-stream up to the http2-stream common superclass. Both server-stream and client-stream instances now inherit the slots (and their accessor generic functions). Rationale: log-closed-stream in core/frames/headers.lisp calls (get-path stream), (get-method stream) etc. on any h2-stream during http-stream-error handling. The slots were only on server-stream, so these calls signalled no-applicable-method-error on client streams, killing client reactors. Moving to http2-stream keeps the existing server-stream API (all slots still accessible via the same accessor GFs) while making the accessors work uniformly on client streams for diagnostics and debugging. Backward-compatible: server-stream instances retain all slots via inheritance, and no existing code paths change. --- core/classes.lisp | 47 +++++++++++++++++++++++++++-------------------- 1 file changed, 27 insertions(+), 20 deletions(-) diff --git a/core/classes.lisp b/core/classes.lisp index 9526edc..f870007 100644 --- a/core/classes.lisp +++ b/core/classes.lisp @@ -119,7 +119,28 @@ pretending that connection of connection is the same connection can be useful." (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 +148,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 +162,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* From a596e7ed32df5c8c06695d323f469e798d398053 Mon Sep 17 00:00:00 2001 From: John Mallery Date: Tue, 17 Mar 2026 07:29:58 +0100 Subject: [PATCH 30/32] Add (optimize (speed 3) (safety 1)) to all core modules Frame parsing, HPACK encoding/decoding, stream management, and connection processing had no optimization declarations. Default optimization runs generic dispatch, type checks, and no inlining on the H2 framing hot path. 13 core files: classes, frames (main + 6 frame types), hpack, stream-based-connections, payload-streams, pipe, utils. Co-Authored-By: Claude Opus 4.6 (1M context) --- core/classes.lisp | 2 ++ core/frames.lisp | 2 ++ core/frames/data.lisp | 2 ++ core/frames/headers.lisp | 2 ++ core/frames/http2-stream.lisp | 3 +++ core/frames/ping.lisp | 2 ++ core/frames/rst-and-goaway.lisp | 2 ++ core/frames/settings.lisp | 2 ++ core/hpack.lisp | 2 ++ core/payload-streams.lisp | 2 ++ core/pipe.lisp | 2 ++ core/stream-based-connections.lisp | 2 ++ core/utils.lisp | 2 ++ 13 files changed, 27 insertions(+) diff --git a/core/classes.lisp b/core/classes.lisp index f870007..8624bcc 100644 --- a/core/classes.lisp +++ b/core/classes.lisp @@ -2,6 +2,8 @@ (in-package :http2/core) +(declaim (optimize (speed 3) (safety 1))) + (defsection @implementation/overview (:title "Overview") "There are three core groups of classes: diff --git a/core/frames.lisp b/core/frames.lisp index 2d68e34..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) diff --git a/core/frames/data.lisp b/core/frames/data.lisp index cfb9ccc..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 diff --git a/core/frames/headers.lisp b/core/frames/headers.lisp index c00e753..60448d3 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) 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 0d2b3fe..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)) 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 8d1516e..522e0fd 100644 --- a/core/hpack.lisp +++ b/core/hpack.lisp @@ -2,6 +2,8 @@ (in-package :http2/hpack) +(declaim (optimize (speed 3) (safety 1))) + (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: diff --git a/core/payload-streams.lisp b/core/payload-streams.lisp index 7e79f4d..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 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 05cd71c..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) diff --git a/core/utils.lisp b/core/utils.lisp index 8f4dd1b..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) From 49d60f813a8b4503071485214277c15a9b637fef Mon Sep 17 00:00:00 2001 From: John Mallery Date: Sat, 4 Apr 2026 06:52:55 +0200 Subject: [PATCH 31/32] Fix mode line: Package http2/resources -> http2/buffer-pool The mode line attribute said Package: http2/resources but the in-package form uses http2/buffer-pool. Genera reads the mode line to set the package, so the mismatch causes compilation in the wrong package. --- core/buffer-pool.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/buffer-pool.lisp b/core/buffer-pool.lisp index e8b8cf2..122e89f 100644 --- a/core/buffer-pool.lisp +++ b/core/buffer-pool.lisp @@ -1,4 +1,4 @@ -;;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: http2/resources; Base: 10 -*- +;;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: http2/buffer-pool; Base: 10 -*- (in-package :http2/buffer-pool) From 582db095589434646c5e6d57abe357653e85bcae Mon Sep 17 00:00:00 2001 From: John Mallery Date: Wed, 20 May 2026 14:37:57 -0300 Subject: [PATCH 32/32] Add (eql :closed) no-op method on apply-stream-priority FIND-JUST-STREAM-BY-ID returns the keyword :CLOSED when the stream-id is absent from the streams table (the stream was already closed and reaped). APPLY-STREAM-PRIORITY then ran the default method, which calls (SETF (GET-WEIGHT stream) WEIGHT) and (SETF (GET-DEPENDS-ON stream) ...) -- neither has a method specialised on a keyword. Symptom in production: a PRIORITY-bearing frame (or a HEADERS frame with the priority flag) for a closed stream made the H2 writer thread die with SIMPLE-ERROR -- No applicable methods for # with args (WEIGHT :CLOSED) RFC 9113 sec 5.5 explicitly permits PRIORITY frames on closed streams, and RFC 9218 deprecates stream priority entirely, so the right behaviour is "do nothing" -- there is no per-stream state to update. The library already follows this pattern for the three other generics that FIND-JUST-STREAM-BY-ID's keyword return value reaches: - update-window-size (eql :closed) - peer-resets-stream (eql :closed) - get-peer-window-size (eql :closed) apply-stream-priority was missing one. Adding it fixes the crash without changing behaviour on live streams. --- core/frames/headers.lisp | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/core/frames/headers.lisp b/core/frames/headers.lisp index 60448d3..c4ddb2a 100644 --- a/core/frames/headers.lisp +++ b/core/frames/headers.lisp @@ -65,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."))