1.1--- a/lisp/ffi/uring/constants.lisp Sun Jun 09 22:09:18 2024 -0400
1.2+++ b/lisp/ffi/uring/constants.lisp Tue Jun 11 15:47:38 2024 -0400
1.3@@ -230,7 +230,6 @@
1.4 (unsigned-int controllen "__u32" "controllen")
1.5 (unsigned-int payloadlen "__u32" "payloadlen")
1.6 (unsigned-int flags "__u32" "flags")))
1.7+ ;; (:integer liburing-udata-timeout "LIBURING_UDATA_TIMEOUT") ;; c macro trouble
1.8 (:enum socket-uring-op ((socket-uring-op-siocinq "SOCKET_URING_OP_SIOCINQ")
1.9- (socket-uring-op-siocoutq "SOCKET_URING_OP_SIOCOUTQ")))
1.10- ;; (:integer liburing-udata-timeout "LIBURING_UDATA_TIMEOUT") ;; c macro trouble
1.11- )
1.12+ (socket-uring-op-siocoutq "SOCKET_URING_OP_SIOCOUTQ"))))
2.1--- a/lisp/ffi/zstd/pkg.lisp Sun Jun 09 22:09:18 2024 -0400
2.2+++ b/lisp/ffi/zstd/pkg.lisp Tue Jun 11 15:47:38 2024 -0400
2.3@@ -147,9 +147,17 @@
2.4 (src (* t)) (src-size size-t))
2.5
2.6 ;;; Streaming API
2.7-(define-alien-type zstd-inbuffer (struct zstd-inbuffer-s))
2.8+(define-alien-type zstd-inbuffer
2.9+ (struct zstd-inbuffer-s
2.10+ (src (* t))
2.11+ (size size-t)
2.12+ (pos size-t)))
2.13
2.14-(define-alien-type zstd-outbuffer (struct zstd-outbuffer-s))
2.15+(define-alien-type zstd-outbuffer
2.16+ (struct zstd-outbuffer-s
2.17+ (dst (* t))
2.18+ (size size-t)
2.19+ (pos size-t)))
2.20
2.21 (define-alien-type zstd-cstream zstd-cctx)
2.22
3.1--- a/lisp/ffi/zstd/tests.lisp Sun Jun 09 22:09:18 2024 -0400
3.2+++ b/lisp/ffi/zstd/tests.lisp Tue Jun 11 15:47:38 2024 -0400
3.3@@ -45,10 +45,9 @@
3.4 (cst (* zstd-cstream) (zstd::zstd-createcstream))
3.5 (dst (* zstd-dstream) (zstd::zstd-createdstream)))
3.6 (with-zstd-cstream (cs cst)
3.7- (is (zerop (zstd::zstd-initcstream cst (zstd-defaultclevel))))
3.8+ (is (zerop (zstd::zstd-initcstream cst (zstd-defaultclevel))))
3.9 (with-zstd-dstream (ds dst)
3.10 (is (zerop (zstd::zstd-initdstream dst)))
3.11- ;; check
3.12 (zstd-compressstream cst out in)
3.13 (is (zerop (zstd-compressstream2 cst out in 0)))
3.14 (is (zerop (zstd-iserror (zstd-decompressstream dst out in))))))))
4.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
4.2+++ b/lisp/lib/dat/mime.lisp Tue Jun 11 15:47:38 2024 -0400
4.3@@ -0,0 +1,152 @@
4.4+;;; mime.lisp --- MIME Database
4.5+
4.6+;;
4.7+
4.8+;;; Code:
4.9+(in-package :dat/mime)
4.10+
4.11+(defun read-mime-match-offset (offset)
4.12+ "Mime offsets are encoded as single int or range N:N. Returns an integer of a
4.13+cons of two ints."
4.14+ (let ((len (length offset)))
4.15+ (if (= 1 len)
4.16+ (parse-integer offset)
4.17+ (multiple-value-bind (int1 pos) (parse-integer offset :junk-allowed t)
4.18+ (if (>= pos len)
4.19+ int1
4.20+ (cons int1 (parse-integer offset :start (1+ pos))))))))
4.21+
4.22+(defstruct mime-magic offset value type)
4.23+
4.24+(defstruct mime-type type name superclasses glob magic)
4.25+
4.26+(declaim (inline mime-type))
4.27+(defun mime-type (mime-type)
4.28+ (mime-type-type mime-type))
4.29+
4.30+(defun load-mime-info (&optional (path #p"/usr/share/mime/packages/freedesktop.org.xml"))
4.31+ (let ((types (xmlrep-find-child-tags "mime-type"
4.32+ (xml-parse (with-open-file (file path)
4.33+ (with-output-to-string (st)
4.34+ (loop for l = (read-line file nil)
4.35+ while l
4.36+ do (std:println l st)))))))
4.37+ (mime-types))
4.38+ ;; assumes all children have a single attribute - TYPE
4.39+ (dolist (mime types mime-types)
4.40+ (let ((type (xmlrep-attrib-value "type" mime)))
4.41+ (push (make-mime-type :type type
4.42+ :name (car (split-sequence #\/ type :count 1 :from-end t))
4.43+ :superclasses
4.44+ (mapcar (lambda (x) (xmlrep-attrib-value "type" x))
4.45+ (xmlrep-find-child-tags "sub-class-of" mime))
4.46+ :glob
4.47+ (mapcar (lambda (x) (xmlrep-attrib-value "pattern" x))
4.48+ (xmlrep-find-child-tags "glob" mime))
4.49+ :magic
4.50+ (loop for magic in (xmlrep-find-child-tags "magic" mime)
4.51+ while magic
4.52+ collect (loop for match in (xmlrep-find-child-tags "match" magic)
4.53+ collect (make-mime-magic
4.54+ :offset (read-mime-match-offset
4.55+ (xmlrep-attrib-value "offset" match))
4.56+ :value (xmlrep-attrib-value "value" match)
4.57+ :type (xmlrep-attrib-value "type" match)))))
4.58+ mime-types)))))
4.59+
4.60+(defvar *mime-types* (load-mime-info))
4.61+
4.62+(defvar *mime-database*
4.63+ (let ((tbl (make-hash-table :size (length *mime-types*) :test 'equal)))
4.64+ (dolist (mime *mime-types* tbl)
4.65+ (setf (gethash (mime-type mime) tbl) mime))))
4.66+
4.67+(defvar *mime-db*
4.68+ (let ((tbl (make-hash-table :test 'equal))) ;; at least as large as *MIME-DATABASE*
4.69+ (dolist (mime *mime-types* tbl)
4.70+ (when-let ((patterns (mime-type-glob mime)))
4.71+ (dolist (p patterns)
4.72+ (when (wild-pathname-p p) ;; drop '.*'
4.73+ (setf p (subseq p 2)))
4.74+ (setf (gethash p tbl) (mime-type mime)))))))
4.75+
4.76+(defun get-mime (value)
4.77+ "Return the name of a MIME-TYPE from *MIME-DB*. The resulting value is a string
4.78+which can be passed to MIME* to get the actual object from *MIME-DATABASE*."
4.79+ (gethash value *mime-db*))
4.80+
4.81+(defun get-mime* (value)
4.82+ "Return a MIME-TYPE from *MIME-DATABASE*."
4.83+ (gethash value *mime-database*))
4.84+
4.85+;; from TRIVIAL-MIMES
4.86+(defun mime-probe (pathname)
4.87+ "Attempts to get the mime-type through a call to the FILE shell utility.
4.88+If the file does not exist or the platform is not unix, NIL is returned."
4.89+ #+unix
4.90+ (when (probe-file pathname)
4.91+ (let ((output (uiop:run-program (list "file" #+darwin "-bI" #-darwin "-bi"
4.92+ (uiop:native-namestring pathname))
4.93+ :output :string)))
4.94+ (with-output-to-string (mime)
4.95+ (loop for c across output
4.96+ for char = (char-downcase c)
4.97+ ;; Allowed characters as per RFC6383
4.98+ while (find char "abcdefghijklmnopqrstuvwxyz0123456789!#$&-^_.+/")
4.99+ do (write-char char mime)))))
4.100+ #-unix
4.101+ NIL)
4.102+
4.103+(defun mime-lookup (path)
4.104+ (get-mime (pathname-type path)))
4.105+
4.106+(defun mime (path &optional (default "application/octet-stream"))
4.107+ (or (mime-lookup path)
4.108+ (mime-probe path)
4.109+ default))
4.110+
4.111+;; TODO 2024-06-11: from TRIVIAL-MIMES
4.112+(defun mime-equal (m1 m2)
4.113+ (or (equal "*" m1)
4.114+ (equal "*" m2)
4.115+ (equal "*/*" m1)
4.116+ (equal "*/*" m2)
4.117+ (destructuring-bind (type1 subtype1 &rest parameters1)
4.118+ (uiop:split-string m1 :separator '(#\/ #\;))
4.119+ (declare (ignorable parameters1))
4.120+ (destructuring-bind (type2 subtype2 &rest parameters2)
4.121+ (uiop:split-string m2 :separator '(#\/ #\;))
4.122+ (declare (ignorable parameters2))
4.123+ (cond
4.124+ ((or (equal "*" subtype1)
4.125+ (equal "*" subtype2)
4.126+ (equal "" subtype1)
4.127+ (equal "" subtype2))
4.128+ (string-equal type1 type2))
4.129+ ((string-equal type1 type2)
4.130+ (string-equal subtype1 subtype2))
4.131+ (t nil))))))
4.132+
4.133+(defmacro mime-case (file &body cases)
4.134+ "A case-like macro that works with MIME type of FILE.
4.135+
4.136+Otherwise clause is the last clause that starts with T or OTHERWISE,.
4.137+
4.138+Example:
4.139+\(mime-case #p\"~/CHANGES.txt\"
4.140+ ((\"application/json\" \"application/*\") \"Something opaque...\")
4.141+ (\"text/plain\" \"That's a plaintext file :D\")
4.142+ (t \"I don't know this type!\"))"
4.143+ (let ((mime (gensym "mime")))
4.144+ `(let ((,mime (mime ,file)))
4.145+ (cond
4.146+ ,@(loop for ((mimes . body) . rest) on cases
4.147+ when (member mimes '(T OTHERWISE))
4.148+ collect `(t ,@body) into clauses
4.149+ and do (if rest
4.150+ (warn "Clauses after T and OTHERWISE are not reachable.")
4.151+ (return clauses))
4.152+ collect `((member ,mime (list ,@(uiop:ensure-list mimes)) :test #'mime-equal)
4.153+ ,@body)
4.154+ into clauses
4.155+ finally (return clauses))))))
5.1--- a/lisp/lib/dat/pkg.lisp Sun Jun 09 22:09:18 2024 -0400
5.2+++ b/lisp/lib/dat/pkg.lisp Tue Jun 11 15:47:38 2024 -0400
5.3@@ -145,8 +145,6 @@
5.4 :to-xml
5.5 :write-xml
5.6 :xml-node-p
5.7- :nodelist->xml-node
5.8- :xml-node->nodelist
5.9 :xml-node ; needed to support use in typep
5.10 ;; processing instruction objects
5.11 :proc-inst-p
5.12@@ -165,6 +163,14 @@
5.13 :extract-path-list
5.14 :extract-path))
5.15
5.16+(defpackage :dat/mime
5.17+ (:use :cl :std :dat/proto :dat/xml)
5.18+ (:export :*mime-database*
5.19+ :load-mime-info :update-mime-database
5.20+ :mime-magic :mime-magic-offset :mime-magic-type :mime-magic-value
5.21+ :mime-type :mime-type-name :mime-type-superclasses :mime-type-glob
5.22+ :mime-type-glob :mime-type-magic))
5.23+
5.24 (defpackage :dat/bencode
5.25 (:use :cl :std :dat/proto :sb-gray)
5.26 (:export
6.1--- a/lisp/lib/io/flate.lisp Sun Jun 09 22:09:18 2024 -0400
6.2+++ b/lisp/lib/io/flate.lisp Tue Jun 11 15:47:38 2024 -0400
6.3@@ -31,7 +31,8 @@
6.4 ;;; Utils
6.5
6.6 ;;; Proto
6.7-(deferror flate-error () () (:auto t))
6.8+
6.9+(eval-always (deferror flate-error () () (:auto t)))
6.10
6.11 (deferror compression-error (flate-error) () (:auto t))
6.12 (deferror decompression-error (flate-error) () (:auto t))
7.1--- a/lisp/lib/io/pkg.lisp Sun Jun 09 22:09:18 2024 -0400
7.2+++ b/lisp/lib/io/pkg.lisp Tue Jun 11 15:47:38 2024 -0400
7.3@@ -19,21 +19,21 @@
7.4 (defpackage :io/ring
7.5 (:use :cl :uring :io/proto)
7.6 (:import-from :sb-alien :addr)
7.7- (:import-from :std/err :deferror))
7.8+ (:import-from :std :deferror :eval-always))
7.9
7.10 (defpackage :io/stream
7.11 (:use :cl :io/proto)
7.12- (:import-from :std/err :deferror)
7.13+ (:import-from :std :deferror :eval-always)
7.14 (:export :io-stream-error :io-stream))
7.15
7.16 (defpackage :io/socket
7.17 (:use :cl :io/proto)
7.18- (:import-from :std/err :deferror)
7.19+ (:import-from :std :deferror :eval-always)
7.20 (:export :io-socket-error :io-socket))
7.21
7.22 (defpackage :io/flate
7.23 (:use :cl :io/proto)
7.24- (:import-from :std/err :deferror)
7.25+ (:import-from :std :deferror :eval-always)
7.26 (:export :flate-error :compression-error :decompression-error
7.27 :*compression-buffer-size* :decompression-buffer-size* :finish-compression :finish-decompression
7.28 :reset-compressor :reset-decompressor :make-compressing-stream :make-decompressing-stream
7.29@@ -42,7 +42,7 @@
7.30
7.31 (defpackage :io/zstd
7.32 (:use :cl :io/proto :io/flate)
7.33- (:import-from :std/err :deferror)
7.34+ (:import-from :std :deferror :eval-always)
7.35 (:export :zstd-error :zstd-compressor :zstd-decompressor))
7.36
7.37 (pkg:defpkg :io
8.1--- a/lisp/lib/io/zstd.lisp Sun Jun 09 22:09:18 2024 -0400
8.2+++ b/lisp/lib/io/zstd.lisp Tue Jun 11 15:47:38 2024 -0400
8.3@@ -5,7 +5,7 @@
8.4 ;;; Code:
8.5 (in-package :io/zstd)
8.6
8.7-(deferror zstd-error (io-error) () (:auto t))
8.8+(eval-always (deferror zstd-error (io-error) () (:auto t)))
8.9
8.10 (deferror zstd-input-error (zstd-error) () (:auto t))
8.11 (deferror zstd-output-error (zstd-error) () (:auto t))
9.1--- a/lisp/lib/net/net.asd Sun Jun 09 22:09:18 2024 -0400
9.2+++ b/lisp/lib/net/net.asd Tue Jun 11 15:47:38 2024 -0400
9.3@@ -6,7 +6,6 @@
9.4 :depends-on
9.5 (:sb-concurrency :sb-posix
9.6 :sb-bsd-sockets :cl-ppcre
9.7- :trivial-mimes
9.8 :fast-io
9.9 :dat :obj :io :parse
9.10 ;; #+swank :swank-client ;; HACK 2024-05-12: temporarily disable, incompatible with current upstream
9.11@@ -17,7 +16,6 @@
9.12 :components ((:file "pkg")
9.13 (:file "err")
9.14 (:file "obj")
9.15- (:file "sans-io")
9.16 (:file "util")
9.17 (:file "udp")
9.18 (:file "tcp")
10.1--- a/lisp/lib/net/pkg.lisp Sun Jun 09 22:09:18 2024 -0400
10.2+++ b/lisp/lib/net/pkg.lisp Tue Jun 11 15:47:38 2024 -0400
10.3@@ -19,23 +19,6 @@
10.4 (:use :cl :obj :dat/proto :std :log :net/core :sb-bsd-sockets)
10.5 (:export :get-address-by-name))
10.6
10.7-(defpackage :net/sans-io
10.8- (:use :cl :obj :dat/proto :std :net/core :sb-bsd-sockets)
10.9- (:export :sans-io-protocol :protocol-version :protocol-name :protocol-features
10.10- :*max-connection-id* :*initial-mtu* :*max-stream-count* :*max-udp-payload*
10.11- :*word-length* :sans-io-error :packet-serializer-error :packet-deserializer-error
10.12- :packet-header-serializer-error :packet-header-deserializer-error :frame-serializer-error :frame-deserializer-error
10.13- :stream-id :stream-direction :event-id :event
10.14- :endpoint-event :connection-event :connection-id :connection-id-generator
10.15- :connection :connection-idle-timeout :peer-id :peer-address
10.16- :peer :clientp :serverp :endpoint-config
10.17- :transport-config :server-config :client-config :endpoint
10.18- :handle-event :handle :connect :default-client-config
10.19- :packet-number :packet-header :packet-payload :packet
10.20- :frame :size-bound :frame-type :with-endpoint
10.21- :with-client :define-protocol :define-endpoint :define-event
10.22- :define-handler))
10.23-
10.24 (defpackage :net/udp
10.25 (:nicknames :udp)
10.26 (:use :cl :std :net/core :sb-bsd-sockets)
10.27@@ -297,6 +280,7 @@
10.28 (defpackage :net/req
10.29 (:nicknames :req)
10.30 (:shadowing-import-from :std/type :octet :octet-vector)
10.31+ (:import-from :dat/mime :mime)
10.32 (:shadow :get :delete)
10.33 (:use :cl :std :obj/uri
10.34 :obj/url :net/proto/http :babel :net/cookie
10.35@@ -333,7 +317,7 @@
10.36
10.37 (defpackage :net/srv
10.38 (:nicknames :srv)
10.39- (:use :cl :std :obj/uri :net/core :net/proto/http :net/sans-io :net/cookie :dat/base64 :sb-gray)
10.40+ (:use :cl :std :obj/uri :net/core :net/proto/http :net/cookie :dat/base64 :sb-gray)
10.41 (:export))
10.42
10.43 (in-package :std-user)
10.44@@ -343,7 +327,6 @@
10.45 :net/core
10.46 :net/tcp
10.47 :net/udp
10.48- :net/sans-io
10.49 :net/codec/dns
10.50 :net/codec/osc
10.51 :net/codec/tlv
11.1--- a/lisp/lib/net/proto/http.lisp Sun Jun 09 22:09:18 2024 -0400
11.2+++ b/lisp/lib/net/proto/http.lisp Tue Jun 11 15:47:38 2024 -0400
11.3@@ -8,8 +8,7 @@
11.4
11.5 ;; Fukamachi has implemented the current state-of-the-art HTTP libraries
11.6 ;; (fast-http, dexador, etc). For the time being we'll be using these with
11.7-;; minimal changes. At some point in the future it would be ideal to
11.8-;; re-implement this in a sans-io style.
11.9+;; minimal changes.
11.10
11.11 ;;; Code:
11.12 (in-package :net/proto/http)
12.1--- a/lisp/lib/net/req.lisp Sun Jun 09 22:09:18 2024 -0400
12.2+++ b/lisp/lib/net/req.lisp Tue Jun 11 15:47:38 2024 -0400
12.3@@ -573,7 +573,7 @@
12.4 (defun content-type (value)
12.5 (typecase value
12.6 (pathname (or (lookup-in-content-type-cache value)
12.7- (setf (lookup-in-content-type-cache value) (mimes:mime value))))
12.8+ (setf (lookup-in-content-type-cache value) (mime value))))
12.9 (otherwise nil)))
12.10
12.11 (defun multipart-value-content-type (value)
12.12@@ -1020,6 +1020,7 @@
12.13 (format nil "Basic ~A"
12.14 (dat/base64:string-to-base64-string proxy-auth)))))
12.15 (eval-always
12.16+ (defconstant +socks5-version+ 5)
12.17 (defconstant +socks5-reserved+ 0)
12.18 (defconstant +socks5-no-auth+ 0)
12.19 (defconstant +socks5-connect+ 1)
13.1--- a/lisp/lib/net/sans-io.lisp Sun Jun 09 22:09:18 2024 -0400
13.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
13.3@@ -1,149 +0,0 @@
13.4-;;; net/sans-io.lisp --- No-I/O protocol abstraction
13.5-
13.6-;; https://sans-io.readthedocs.io/
13.7-
13.8-;;; Commentary:
13.9-
13.10-;;
13.11-
13.12-;;; Code:
13.13-(in-package :net/sans-io)
13.14-
13.15-;;; Abstract
13.16-(defclass sans-io-protocol ()
13.17- ((version :initarg :version :accessor protocol-version)
13.18- (features :initarg :features :accessor protocol-features)))
13.19-
13.20-(defmethod protocol-name ((self sans-io-protocol)) (class-name (class-of self)))
13.21-
13.22-;;; Parameters
13.23-(defvar *word-length* 64)
13.24-(defvar *max-connection-id* sb-ext:most-positive-word)
13.25-(defvar *initial-mtu* 1200)
13.26-(defvar *max-udp-payload* 65527)
13.27-(defvar *max-stream-count* (ash 1 60))
13.28-
13.29-;;; Errors
13.30-(define-condition sans-io-error (protocol-error) ())
13.31-(define-condition packet-serializer-error (sans-io-error serializer-error) ())
13.32-(define-condition packet-deserializer-error (sans-io-error deserializer-error) ())
13.33-(define-condition packet-header-serializer-error (sans-io-error serializer-error) ())
13.34-(define-condition packet-header-deserializer-error (sans-io-error deserializer-error) ())
13.35-(define-condition frame-serializer-error (sans-io-error serializer-error) ())
13.36-(define-condition frame-deserializer-error (sans-io-error deserializer-error) ())
13.37-
13.38-;;; IO
13.39-(defclass stream-id (id) ())
13.40-(defclass byte-buffer () ())
13.41-(defclass datagram-buffer () ())
13.42-
13.43-(defgeneric stream-direction ())
13.44-
13.45-;;; Events
13.46-(defclass event-id (id) ())
13.47-
13.48-(defmethod make-id ((self (eql :event)))
13.49- (declare (ignorable self))
13.50- (make-instance 'event-id))
13.51-(defmethod reset-id ((self event-id)) (setf (id self) 0))
13.52-(defmethod update-id ((self event-id)) (setf (id self) (hash-object self)))
13.53-
13.54-(defclass event (event-id) ())
13.55-
13.56-(defclass endpoint-event (event) ())
13.57-(defclass connection-event (event) ())
13.58-
13.59-;;; Connections
13.60-(defclass connection-id (id) ())
13.61-
13.62-(defclass connection-id-generator () ())
13.63-(defmethod make-id ((self (eql :connection)))
13.64- (declare (ignorable self))
13.65- (make-instance 'connection-id))
13.66-(defmethod reset-id ((self connection-id)) (setf (id self) 0))
13.67-(defmethod update-id ((self connection-id)) (setf (id self) (hash-object self)))
13.68-
13.69-(defclass connection (connection-id) ())
13.70-
13.71-(defclass connection-idle-timeout ()
13.72- ((timeout :initform 10000 ;; 10 seconds
13.73- :type (integer 0 *))))
13.74-
13.75-;;; Peers
13.76-(defclass peer-id (id) ())
13.77-
13.78-(defmethod make-id ((self (eql :peer)))
13.79- (declare (ignorable self))
13.80- (make-instance 'peer-id))
13.81-(defmethod reset-id ((self peer-id)) (setf (id self) 0))
13.82-(defmethod update-id ((self peer-id)) (setf (id self) (hash-object self)))
13.83-
13.84-(defclass peer-address () ((address :initarg :address)))
13.85-
13.86-(defclass peer (peer-id peer-address) ())
13.87-
13.88-(defgeneric clientp (self)
13.89- (:documentation "Return non-nil if SELF is a valid CLIENT."))
13.90-
13.91-(defgeneric serverp ()
13.92- (:documentation "Return non-nil if SELF is a valid SERVER."))
13.93-
13.94-;;; Endpoints
13.95-(defclass endpoint-config ()
13.96- ((socket :initarg :socket :type socket)
13.97- (id-factory :initarg :id-factory :type id-factory)
13.98- (features :initarg :features))
13.99- (:documentation "Configuration for ENDPOINTs, affecting all connections."))
13.100-
13.101-(defclass transport-config () ()
13.102- (:documentation "Configuration for a network protocol state machine."))
13.103-
13.104-(defclass server-config (transport-config) ())
13.105-
13.106-(defclass client-config (transport-config) ())
13.107-
13.108-(defclass endpoint (endpoint-config connection-id-generator)
13.109- ((connections :initform #() :type (array connection))
13.110- (server :initarg :server)
13.111- (client :initarg :client)))
13.112-
13.113-(defgeneric handle-event ())
13.114-(defgeneric handle ())
13.115-(defgeneric connect ())
13.116-(defgeneric default-client-config ())
13.117-
13.118-;;; Packets
13.119-(defclass packet-number (id) ())
13.120-(defclass packet-header (packet-number) (header))
13.121-(defclass packet-payload () (payload))
13.122-(defclass packet (packet-payload) ())
13.123-
13.124-(defmethod serialize ((self packet) format &key &allow-other-keys))
13.125-(defmethod deserialize ((self packet) format &key &allow-other-keys))
13.126-
13.127-(defmethod serialize ((self packet-header) format &key &allow-other-keys))
13.128-(defmethod deserialize ((self packet-header) format &key &allow-other-keys))
13.129-
13.130-;;; Frames
13.131-(defclass frame () ())
13.132-
13.133-(defgeneric size-bound ())
13.134-(defgeneric frame-type ())
13.135-
13.136-(defmethod serialize ((self frame) format &key &allow-other-keys))
13.137-(defmethod deserialize ((self frame) format &key &allow-other-keys))
13.138-
13.139-;;; Macros
13.140-(defmacro define-protocol (name superclasses slots &key version features)
13.141- "Define a network protocol based on SANS-IO-PROTOCOL."
13.142- `(defclass ,name (,@(or superclasses (list 'sans-io-protocol)))
13.143- ,slots
13.144- (:default-initargs
13.145- :version ,version
13.146- :features ,features)))
13.147-
13.148-;; (defmacro define-endpoint (name &rest options))
13.149-;; (defmacro define-event (name &rest options))
13.150-;; (defmacro define-handler (name &body body))
13.151-(defmacro with-endpoint ())
13.152-(defmacro with-client ())
14.1--- a/lisp/lib/net/srv.lisp Sun Jun 09 22:09:18 2024 -0400
14.2+++ b/lisp/lib/net/srv.lisp Tue Jun 11 15:47:38 2024 -0400
14.3@@ -19,17 +19,21 @@
14.4 (srv:start ws))
14.5 |#
14.6
14.7-;;;; NET/SANS-IO
14.8-;; This package contains the low-level base classes which are extended by this
14.9-;; library.
14.10-
14.11 ;;; Code:
14.12 (in-package :net/srv)
14.13
14.14-(defmacro define-service (name &rest initargs)
14.15- "Define a subclass of NET/SRV:SERVICE."
14.16- `(defclass ,name ,@initargs))
14.17+;;; Errors
14.18+;; from hunchentoot
14.19+(define-condition srv-error () ())
14.20+
14.21+(define-condition srv-simple-error (srv-error simple-condition) ())
14.22
14.23+(defun srv-simple-error (format-control &rest format-arguments)
14.24+ (error 'srv-simple-error
14.25+ :format-control format-control
14.26+ :format-arguments format-arguments))
14.27+
14.28+;;; Protocol
14.29 (defgeneric start-service (self)
14.30 (:documentation "Start a service."))
14.31
14.32@@ -41,3 +45,13 @@
14.33 (:method ((self t))
14.34 (stop-service self)
14.35 (start-service self)))
14.36+
14.37+(defgeneric add-route (self uri handler &key &allow-other-keys))
14.38+
14.39+(defvar *routes*)
14.40+(defvar *dispatch-table*)
14.41+
14.42+;;; Macros
14.43+(defmacro define-service (name &rest initargs)
14.44+ "Define a subclass of NET/SRV:SERVICE."
14.45+ `(defclass ,name ,@initargs))
15.1--- a/lisp/lib/net/tests.lisp Sun Jun 09 22:09:18 2024 -0400
15.2+++ b/lisp/lib/net/tests.lisp Tue Jun 11 15:47:38 2024 -0400
15.3@@ -6,39 +6,9 @@
15.4 (defsuite :net)
15.5 (in-suite :net)
15.6 (in-readtable :std)
15.7+
15.8 (deftest sanity ())
15.9
15.10-(deftest sans-io ()
15.11- (define-protocol mockz () (data) :version 2 :features (list :foo :bar :baz))
15.12- (is (eql 'mockz (protocol-name (make-instance 'mockz))))
15.13- (is (null (protocol-features (make-instance 'sans-io-protocol :features nil))))
15.14- (is (= 3 (length (protocol-features (make-instance 'mockz)))))
15.15- (is (= 2 (protocol-version (make-instance 'mockz))))
15.16- (defclass mock-transport-config (transport-config)
15.17- (max-bidi-streams
15.18- max-uni-streams
15.19- max-idle-timeout
15.20- rx-window
15.21- tx-window
15.22- (packet-threshold :initform 3)
15.23- (time-threshold :initform (/ 9 8))
15.24- (initial-rtt :initform 333)
15.25- initial-mtu
15.26- min-mtu
15.27- (datagram-rx-buffer-size :initform 1250000)
15.28- (datagram-tx-buffer-size :initform (* 1024 1024))))
15.29- (defclass mock-server-config (server-config)
15.30- ((port :initarg :port :initform 0)))
15.31- (defclass mock-client-config (client-config)
15.32- ((port :initarg :port :initform 0)))
15.33- (defclass mock-endpoint (endpoint)
15.34- ((tx :initarg :tx)
15.35- (rx :initarg :rx))
15.36- (:default-initargs
15.37- :server (make-instance 'mock-server-config)))
15.38- (let ((ent (make-instance 'mock-endpoint)))
15.39- (is (equal (class-name (class-of ent)) 'mock-endpoint))))
15.40-
15.41 (deftest dns ())
15.42
15.43 (deftest tcp ()
16.1--- a/lisp/lib/obj/direction.lisp Sun Jun 09 22:09:18 2024 -0400
16.2+++ b/lisp/lib/obj/direction.lisp Tue Jun 11 15:47:38 2024 -0400
16.3@@ -1,3 +1,23 @@
16.4 ;;; obj/direction.lisp --- Physical and Metaphysical Directions
16.5
16.6+;;
16.7+
16.8+;;; Commentary:
16.9+
16.10+;;; Code:
16.11 (in-package :obj/direction)
16.12+
16.13+(deftype direction-designator () '(or symbol string boolean number))
16.14+
16.15+(defclass direction () ())
16.16+
16.17+(defgeneric direction (self))
16.18+(defgeneric (setf direction) (self))
16.19+
16.20+(defgeneric directions (self))
16.21+(defgeneric (setf directions) (self))
16.22+
16.23+(defgeneric left (self))
16.24+(defgeneric right (self))
16.25+(defgeneric up (self))
16.26+(defgeneric down (self))
17.1--- a/lisp/lib/obj/hash/hasher.lisp Sun Jun 09 22:09:18 2024 -0400
17.2+++ b/lisp/lib/obj/hash/hasher.lisp Tue Jun 11 15:47:38 2024 -0400
17.3@@ -28,7 +28,9 @@
17.4 (char-code (schar string n)))))))
17.5 hash)))
17.6
17.7-(defgeneric hash-object (obj))
17.8+(defgeneric hash-object (obj)
17.9+ (:method ((obj t))
17.10+ (hash-object-address obj)))
17.11
17.12 (defun hash-object-address (obj &optional (test *global-hasher*))
17.13 "Given some object OBJ, lookup the address with
18.1--- a/lisp/std/file.lisp Sun Jun 09 22:09:18 2024 -0400
18.2+++ b/lisp/std/file.lisp Tue Jun 11 15:47:38 2024 -0400
18.3@@ -326,7 +326,7 @@
18.4 :element-type (stream-element-type output)
18.5 :if-does-not-exist if-does-not-exist
18.6 :external-format external-format)
18.7- (copy-stream input output)))
18.8+ (copy-stream input output :end (file-size-in-octets pathname))))
18.9
18.10 (defun file= (file1 file2 &key (buffer-size 4096))
18.11 "Compare FILE1 and FILE2 octet by octet, \(possibly) using buffers
19.1--- a/lisp/std/stream.lisp Sun Jun 09 22:09:18 2024 -0400
19.2+++ b/lisp/std/stream.lisp Tue Jun 11 15:47:38 2024 -0400
19.3@@ -42,9 +42,9 @@
19.4 (error "~@<Could not read enough bytes from the input to fulfill ~
19.5 the :END ~S requirement in ~S.~:@>" 'copy-stream end)
19.6 (return)))
19.7- (incf input-position n)
19.8+ (print (incf input-position n))
19.9 (write-sequence buffer output :end n)
19.10- (incf output-position n)))
19.11+ (print (incf output-position n))))
19.12 (when finish-output
19.13 (finish-output output))
19.14 output-position))
