1.1--- a/lisp/lib/dat/base64.lisp Wed May 22 18:19:23 2024 -0400
1.2+++ b/lisp/lib/dat/base64.lisp Wed May 22 22:16:26 2024 -0400
1.3@@ -9,6 +9,7 @@
1.4 ;;; Code:
1.5 (in-package :dat/base64)
1.6
1.7+;;; encode
1.8 (eval-when (:compile-toplevel :load-toplevel :execute)
1.9 (defvar *encode-table*
1.10 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
1.11@@ -66,18 +67,18 @@
1.12 `(defun ,(intern (concatenate 'string (symbol-name input-type)
1.13 (symbol-name :-to-base64-)
1.14 (symbol-name output-type)))
1.15- (input
1.16+ (input
1.17 ,@(when (eq output-type :stream)
1.18- '(output))
1.19+ '(output))
1.20 &key (uri nil) (columns 0))
1.21 "Encode a string array to base64. If columns is > 0, designates
1.22 maximum number of columns in a line and the string will be terminated
1.23 with a #\Newline."
1.24 (declare ,@(case input-type
1.25- (:string
1.26- '((string input)))
1.27- (:usb8-array
1.28- '((type (array (unsigned-byte 8) (*)) input))))
1.29+ (:string
1.30+ '((string input)))
1.31+ (:usb8-array
1.32+ '((type (array (unsigned-byte 8) (*)) input))))
1.33 (fixnum columns)
1.34 (optimize (speed 3) (safety 1) (space 0)))
1.35 (let ((pad (if uri *uri-pad-char* *pad-char*))
1.36@@ -89,140 +90,140 @@
1.37 (remainder (nth-value 1 (truncate string-length 3)))
1.38 (padded-length (* 4 (truncate (+ string-length 2) 3)))
1.39 ,@(when (eq output-type :string)
1.40- '((num-lines (if (plusp columns)
1.41- (truncate (+ padded-length (1- columns)) columns)
1.42- 0))
1.43- (num-breaks (if (plusp num-lines)
1.44- (1- num-lines)
1.45- 0))
1.46- (strlen (+ padded-length num-breaks))
1.47- (result (make-string strlen))
1.48- (ioutput 0)))
1.49+ '((num-lines (if (plusp columns)
1.50+ (truncate (+ padded-length (1- columns)) columns)
1.51+ 0))
1.52+ (num-breaks (if (plusp num-lines)
1.53+ (1- num-lines)
1.54+ 0))
1.55+ (strlen (+ padded-length num-breaks))
1.56+ (result (make-string strlen))
1.57+ (ioutput 0)))
1.58 (col (if (plusp columns)
1.59 0
1.60 (the fixnum (1+ padded-length)))))
1.61 (declare (fixnum string-length padded-length col
1.62 ,@(when (eq output-type :string)
1.63- '(ioutput)))
1.64+ '(ioutput)))
1.65 ,@(when (eq output-type :string)
1.66- '((simple-string result))))
1.67+ '((simple-string result))))
1.68 (labels ((output-char (ch)
1.69 (if (= col columns)
1.70 (progn
1.71 ,@(case output-type
1.72- (:stream
1.73- '((write-char #\Newline output)))
1.74- (:string
1.75- '((setf (schar result ioutput) #\Newline)
1.76- (incf ioutput))))
1.77+ (:stream
1.78+ '((write-char #\Newline output)))
1.79+ (:string
1.80+ '((setf (schar result ioutput) #\Newline)
1.81+ (incf ioutput))))
1.82 (setq col 1))
1.83- (incf col))
1.84- ,@(case output-type
1.85- (:stream
1.86- '((write-char ch output)))
1.87- (:string
1.88- '((setf (schar result ioutput) ch)
1.89- (incf ioutput)))))
1.90- (output-group (svalue chars)
1.91- (declare (fixnum svalue chars))
1.92- (output-char
1.93- (schar encode-table
1.94- (the fixnum
1.95- (logand #x3f
1.96- (the fixnum (ash svalue -18))))))
1.97- (output-char
1.98- (schar encode-table
1.99- (the fixnum
1.100- (logand #x3f
1.101- (the fixnum (ash svalue -12))))))
1.102- (if (> chars 2)
1.103- (output-char
1.104- (schar encode-table
1.105- (the fixnum
1.106- (logand #x3f
1.107- (the fixnum (ash svalue -6))))))
1.108- (output-char pad))
1.109- (if (> chars 3)
1.110- (output-char
1.111- (schar encode-table
1.112- (the fixnum
1.113- (logand #x3f svalue))))
1.114- (output-char pad))))
1.115- (do ((igroup 0 (the fixnum (1+ igroup)))
1.116- (isource 0 (the fixnum (+ isource 3))))
1.117- ((= igroup complete-group-count)
1.118- (cond
1.119- ((= remainder 2)
1.120- (output-group
1.121- (the fixnum
1.122- (+
1.123- (the fixnum
1.124- (ash
1.125- ,(case input-type
1.126- (:string
1.127- '(char-code (the character (char input isource))))
1.128- (:usb8-array
1.129- '(the fixnum (aref input isource))))
1.130- 16))
1.131- (the fixnum
1.132- (ash
1.133+ (incf col))
1.134+ ,@(case output-type
1.135+ (:stream
1.136+ '((write-char ch output)))
1.137+ (:string
1.138+ '((setf (schar result ioutput) ch)
1.139+ (incf ioutput)))))
1.140+ (output-group (svalue chars)
1.141+ (declare (fixnum svalue chars))
1.142+ (output-char
1.143+ (schar encode-table
1.144+ (the fixnum
1.145+ (logand #x3f
1.146+ (the fixnum (ash svalue -18))))))
1.147+ (output-char
1.148+ (schar encode-table
1.149+ (the fixnum
1.150+ (logand #x3f
1.151+ (the fixnum (ash svalue -12))))))
1.152+ (if (> chars 2)
1.153+ (output-char
1.154+ (schar encode-table
1.155+ (the fixnum
1.156+ (logand #x3f
1.157+ (the fixnum (ash svalue -6))))))
1.158+ (output-char pad))
1.159+ (if (> chars 3)
1.160+ (output-char
1.161+ (schar encode-table
1.162+ (the fixnum
1.163+ (logand #x3f svalue))))
1.164+ (output-char pad))))
1.165+ (do ((igroup 0 (the fixnum (1+ igroup)))
1.166+ (isource 0 (the fixnum (+ isource 3))))
1.167+ ((= igroup complete-group-count)
1.168+ (cond
1.169+ ((= remainder 2)
1.170+ (output-group
1.171+ (the fixnum
1.172+ (+
1.173+ (the fixnum
1.174+ (ash
1.175+ ,(case input-type
1.176+ (:string
1.177+ '(char-code (the character (char input isource))))
1.178+ (:usb8-array
1.179+ '(the fixnum (aref input isource))))
1.180+ 16))
1.181+ (the fixnum
1.182+ (ash
1.183+ ,(case input-type
1.184+ (:string
1.185+ '(char-code (the character (char input
1.186+ (the fixnum (1+ isource))))))
1.187+ (:usb8-array
1.188+ '(the fixnum (aref input (the fixnum
1.189+ (1+ isource))))))
1.190+ 8))))
1.191+ 3))
1.192+ ((= remainder 1)
1.193+ (output-group
1.194+ (the fixnum
1.195+ (ash
1.196+ ,(case input-type
1.197+ (:string
1.198+ '(char-code (the character (char input isource))))
1.199+ (:usb8-array
1.200+ '(the fixnum (aref input isource))))
1.201+ 16))
1.202+ 2)))
1.203+ ,(case output-type
1.204+ (:string
1.205+ 'result)
1.206+ (:stream
1.207+ 'output)))
1.208+ (declare (fixnum igroup isource))
1.209+ (output-group
1.210+ (the fixnum
1.211+ (+
1.212+ (the fixnum
1.213+ (ash
1.214+ (the fixnum
1.215+ ,(case input-type
1.216+ (:string
1.217+ '(char-code (the character (char input isource))))
1.218+ (:usb8-array
1.219+ '(aref input isource))))
1.220+ 16))
1.221+ (the fixnum
1.222+ (ash
1.223+ (the fixnum
1.224+ ,(case input-type
1.225+ (:string
1.226+ '(char-code (the character (char input
1.227+ (the fixnum (1+ isource))))))
1.228+ (:usb8-array
1.229+ '(aref input (1+ isource)))))
1.230+ 8))
1.231+ (the fixnum
1.232 ,(case input-type
1.233- (:string
1.234- '(char-code (the character (char input
1.235- (the fixnum (1+ isource))))))
1.236- (:usb8-array
1.237- '(the fixnum (aref input (the fixnum
1.238- (1+ isource))))))
1.239- 8))))
1.240- 3))
1.241- ((= remainder 1)
1.242- (output-group
1.243- (the fixnum
1.244- (ash
1.245- ,(case input-type
1.246- (:string
1.247- '(char-code (the character (char input isource))))
1.248- (:usb8-array
1.249- '(the fixnum (aref input isource))))
1.250- 16))
1.251- 2)))
1.252- ,(case output-type
1.253- (:string
1.254- 'result)
1.255- (:stream
1.256- 'output)))
1.257- (declare (fixnum igroup isource))
1.258- (output-group
1.259- (the fixnum
1.260- (+
1.261- (the fixnum
1.262- (ash
1.263- (the fixnum
1.264- ,(case input-type
1.265- (:string
1.266- '(char-code (the character (char input isource))))
1.267- (:usb8-array
1.268- '(aref input isource))))
1.269- 16))
1.270- (the fixnum
1.271- (ash
1.272- (the fixnum
1.273- ,(case input-type
1.274- (:string
1.275- '(char-code (the character (char input
1.276- (the fixnum (1+ isource))))))
1.277- (:usb8-array
1.278- '(aref input (1+ isource)))))
1.279- 8))
1.280- (the fixnum
1.281- ,(case input-type
1.282- (:string
1.283- '(char-code (the character (char input
1.284+ (:string
1.285+ '(char-code (the character (char input
1.286 (the fixnum (+ 2 isource))))))
1.287- (:usb8-array
1.288- '(aref input (+ 2 isource))))
1.289- )))
1.290- 4)))))))
1.291+ (:usb8-array
1.292+ '(aref input (+ 2 isource))))
1.293+ )))
1.294+ 4)))))))
1.295
1.296 (def-*-to-base64-* :string :string)
1.297 (def-*-to-base64-* :string :stream)
1.298@@ -263,7 +264,7 @@
1.299 (last-char (1- strlen))
1.300 (str (make-string strlen))
1.301 (col (if (zerop last-line-len)
1.302- columns
1.303+ columns
1.304 last-line-len)))
1.305 (declare (fixnum padded-length num-lines col last-char
1.306 padding-chars last-line-len))
1.307@@ -388,7 +389,7 @@
1.308 collect (list var value))
1.309 (declare ,@(loop for (var nil type) in vars
1.310 when type
1.311- collect (list 'type type var)))
1.312+ collect (list 'type type var)))
1.313 ,@body))
1.314
1.315 (defmacro define-base64-decoder (hose sink)
1.316@@ -428,7 +429,7 @@
1.317 (ecase hose
1.318 (:stream
1.319 `((result (make-array 1024
1.320- :element-type '(unsigned-byte 8)
1.321+ :element-type '(unsigned-byte 8)
1.322 :adjustable t
1.323 :fill-pointer 0)
1.324 (array (unsigned-byte 8) (*)))))
1.325@@ -437,9 +438,9 @@
1.326 :element-type '(unsigned-byte 8))
1.327 (simple-array (unsigned-byte 8) (*)))
1.328 (rpos 0 array-index)))))
1.329- (:string
1.330+ (:string
1.331 (case hose
1.332- (:stream
1.333+ (:stream
1.334 `((result (make-array 1024
1.335 :element-type 'character
1.336 :adjustable t
1.337@@ -474,83 +475,83 @@
1.338 (padchar 0 (integer 0 3))
1.339 (code 0 fixnum))
1.340 (loop
1.341- ,@(ecase hose
1.342- (:string
1.343- `((if (< ipos length)
1.344- (setq code (char-code (aref input ipos)))
1.345- (return))))
1.346- (:stream
1.347- `((let ((char (read-char input nil nil)))
1.348- (if char
1.349- (setq code (char-code char))
1.350- (return))))))
1.351- (cond
1.352- ((or (< 127 code)
1.353- (= -1 (setq svalue (aref decode-table code))))
1.354- (bad-char ipos code))
1.355- ((= -2 svalue)
1.356- (cond ((<= (incf padchar) 2)
1.357- (unless (<= 2 bitcount)
1.358- (bad-char ipos code))
1.359- (decf bitcount 2))
1.360- (t
1.361- (bad-char ipos code))))
1.362- ((= -3 svalue)
1.363- (ecase whitespace
1.364- (:ignore
1.365- ;; Do nothing.
1.366- )
1.367- (:error
1.368- (bad-char ipos code :error))
1.369- (:signal
1.370- (bad-char ipos code :signal))))
1.371- ((not (zerop padchar))
1.372- (bad-char ipos code))
1.373- (t
1.374- (setf bitstore (logior (the (unsigned-byte 24)
1.375- (ash bitstore 6))
1.376- svalue))
1.377- (incf bitcount 6)
1.378- (when (>= bitcount 8)
1.379- (decf bitcount 8)
1.380- (let ((byte (logand (the (unsigned-byte 24)
1.381- (ash bitstore (- bitcount)))
1.382- #xFF)))
1.383- (declare (type (unsigned-byte 8) byte))
1.384- ,@(ecase sink
1.385- (:usb8-array
1.386- (ecase hose
1.387- (:string
1.388- `((setf (aref result rpos) byte)
1.389- (incf rpos)))
1.390- (:stream
1.391- `((vector-push-extend byte result)))))
1.392- (:string
1.393- (ecase hose
1.394- (:string
1.395- `((setf (schar result rpos)
1.396- (code-char byte))
1.397- (incf rpos)))
1.398- (:stream
1.399- `((vector-push-extend (code-char byte)
1.400- result)))))
1.401- (:integer
1.402- `((setq result
1.403- (logior (ash result 8) byte))))
1.404- (:stream
1.405- '((write-char (code-char byte) stream)))))
1.406- (setf bitstore (logand bitstore #xFF)))))
1.407- (incf ipos))
1.408+ ,@(ecase hose
1.409+ (:string
1.410+ `((if (< ipos length)
1.411+ (setq code (char-code (aref input ipos)))
1.412+ (return))))
1.413+ (:stream
1.414+ `((let ((char (read-char input nil nil)))
1.415+ (if char
1.416+ (setq code (char-code char))
1.417+ (return))))))
1.418+ (cond
1.419+ ((or (< 127 code)
1.420+ (= -1 (setq svalue (aref decode-table code))))
1.421+ (bad-char ipos code))
1.422+ ((= -2 svalue)
1.423+ (cond ((<= (incf padchar) 2)
1.424+ (unless (<= 2 bitcount)
1.425+ (bad-char ipos code))
1.426+ (decf bitcount 2))
1.427+ (t
1.428+ (bad-char ipos code))))
1.429+ ((= -3 svalue)
1.430+ (ecase whitespace
1.431+ (:ignore
1.432+ ;; Do nothing.
1.433+ )
1.434+ (:error
1.435+ (bad-char ipos code :error))
1.436+ (:signal
1.437+ (bad-char ipos code :signal))))
1.438+ ((not (zerop padchar))
1.439+ (bad-char ipos code))
1.440+ (t
1.441+ (setf bitstore (logior (the (unsigned-byte 24)
1.442+ (ash bitstore 6))
1.443+ svalue))
1.444+ (incf bitcount 6)
1.445+ (when (>= bitcount 8)
1.446+ (decf bitcount 8)
1.447+ (let ((byte (logand (the (unsigned-byte 24)
1.448+ (ash bitstore (- bitcount)))
1.449+ #xFF)))
1.450+ (declare (type (unsigned-byte 8) byte))
1.451+ ,@(ecase sink
1.452+ (:usb8-array
1.453+ (ecase hose
1.454+ (:string
1.455+ `((setf (aref result rpos) byte)
1.456+ (incf rpos)))
1.457+ (:stream
1.458+ `((vector-push-extend byte result)))))
1.459+ (:string
1.460+ (ecase hose
1.461+ (:string
1.462+ `((setf (schar result rpos)
1.463+ (code-char byte))
1.464+ (incf rpos)))
1.465+ (:stream
1.466+ `((vector-push-extend (code-char byte)
1.467+ result)))))
1.468+ (:integer
1.469+ `((setq result
1.470+ (logior (ash result 8) byte))))
1.471+ (:stream
1.472+ '((write-char (code-char byte) stream)))))
1.473+ (setf bitstore (logand bitstore #xFF)))))
1.474+ (incf ipos))
1.475 (unless (zerop bitcount)
1.476 (incomplete-input ipos))
1.477 ,(ecase sink
1.478 ((:string :usb8-array)
1.479 (ecase hose
1.480- (:string
1.481+ (:string
1.482 `(if (= rpos (length result))
1.483 result
1.484 (subseq result 0 rpos)))
1.485- (:stream
1.486+ (:stream
1.487 `(copy-seq result))))
1.488 (:integer
1.489 'result)
2.1--- a/lisp/lib/dat/dat.asd Wed May 22 18:19:23 2024 -0400
2.2+++ b/lisp/lib/dat/dat.asd Wed May 22 22:16:26 2024 -0400
2.3@@ -22,6 +22,7 @@
2.4 (:file "toml")
2.5 (:file "arff")
2.6 (:file "midi")
2.7+ (:file "base64")
2.8 #+nil (:file "bencode"))
2.9 :in-order-to ((test-op (test-op "dat/tests"))))
2.10
3.1--- a/lisp/lib/io/smart-buffer.lisp Wed May 22 18:19:23 2024 -0400
3.2+++ b/lisp/lib/io/smart-buffer.lisp Wed May 22 22:16:26 2024 -0400
3.3@@ -20,7 +20,7 @@
3.4 #:delete-temporary-files
3.5
3.6 #:buffer-limit-exceeded))
3.7-(in-package :smart-buffer)
3.8+(in-package :io/smart-buffer)
3.9
3.10 (defvar *default-memory-limit* (expt 2 20))
3.11 (defvar *default-disk-limit* (expt 2 30))
4.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
4.2+++ b/lisp/lib/net/cookie.lisp Wed May 22 22:16:26 2024 -0400
4.3@@ -0,0 +1,322 @@
4.4+;;; net/cookie.lisp --- HTTP Cookies
4.5+
4.6+;; Based on Fukamachi's CL-COOKIE
4.7+
4.8+;;; Code:
4.9+(in-package :net/cookie)
4.10+
4.11+(defun cookie-domain-p (domain cookie-domain)
4.12+ (unless cookie-domain
4.13+ (return-from cookie-domain-p t))
4.14+ (if (ip-addr-p domain)
4.15+ (ip-addr= domain cookie-domain)
4.16+ (progn
4.17+ ;; ignore the preceding "."
4.18+ (when (char= (aref cookie-domain 0) #\.)
4.19+ (setq cookie-domain (subseq cookie-domain 1)))
4.20+ (when-let (registered-domain (parse-domain domain))
4.21+ (cond
4.22+ ((= (length registered-domain) (length cookie-domain))
4.23+ (string= registered-domain cookie-domain))
4.24+ ((= (length domain) (length cookie-domain))
4.25+ (string= domain cookie-domain))
4.26+ (t (and (std/seq:ends-with-subseq domain cookie-domain)
4.27+ (char= #\.
4.28+ (aref cookie-domain (- (length cookie-domain)
4.29+ (length registered-domain)))))))))))
4.30+
4.31+(defun same-site-p (same-site)
4.32+ "Predicate for allowed values of same-site attribute"
4.33+ (member same-site (list "Strict" "Lax" "None") :test #'string-equal))
4.34+
4.35+(deftype same-site nil
4.36+ '(satisfies same-site-p))
4.37+
4.38+(defstruct cookie
4.39+ (name nil :type (or null string))
4.40+ (value nil :type (or null string))
4.41+ (path nil :type (or null string))
4.42+ (domain nil :type (or null string))
4.43+ (origin-host nil :type (or null string))
4.44+ (expires nil :type (or null integer))
4.45+ (max-age nil :type (or null integer))
4.46+ (same-site nil :type (or null same-site))
4.47+ (partitioned nil :type boolean)
4.48+ (secure-p nil :type boolean)
4.49+ (httponly-p nil :type boolean)
4.50+ (creation-timestamp (get-universal-time) :type integer :read-only t))
4.51+
4.52+(defstruct cookie-jar
4.53+ cookies)
4.54+
4.55+(defun cookie= (cookie1 cookie2)
4.56+ "Equality check for the attributes name, domain, host and path."
4.57+ (and (string= (cookie-name cookie1)
4.58+ (cookie-name cookie2))
4.59+ (if (cookie-domain cookie1)
4.60+ (equalp (cookie-domain cookie1)
4.61+ (cookie-domain cookie2))
4.62+ (equalp (cookie-origin-host cookie1)
4.63+ (cookie-origin-host cookie2)))
4.64+ (equal (cookie-path cookie1)
4.65+ (cookie-path cookie2))))
4.66+
4.67+(defun cookie-equal (cookie1 cookie2)
4.68+ "Equality check as in cookie= plus also secure-p, same-site, partitioned, as well as httponly-p."
4.69+ (and (cookie= cookie1 cookie2)
4.70+ (eq (cookie-secure-p cookie1) (cookie-secure-p cookie2))
4.71+ (string= (cookie-same-site cookie1)
4.72+ (cookie-same-site cookie2))
4.73+ (eq (cookie-partitioned cookie1)
4.74+ (cookie-partitioned cookie2))
4.75+ (eq (cookie-httponly-p cookie1) (cookie-httponly-p cookie2))))
4.76+
4.77+(defun expired-cookie-p (cookie)
4.78+ "Check if cookie is expired, whereas max-age has priority over expires."
4.79+ (if-let (max-age
4.80+ (cookie-max-age cookie))
4.81+ (< (+ max-age
4.82+ (cookie-creation-timestamp cookie))
4.83+ (get-universal-time))
4.84+ (when-let (expires
4.85+ (cookie-expires cookie))
4.86+ (< expires (get-universal-time)))))
4.87+
4.88+(defun delete-old-cookies (cookie-jar)
4.89+ (setf (cookie-jar-cookies cookie-jar)
4.90+ (delete-if #'expired-cookie-p
4.91+ (cookie-jar-cookies cookie-jar))))
4.92+
4.93+(defun match-cookie-path (request-path cookie-path)
4.94+ (flet ((last-char (str)
4.95+ (aref str (1- (length str)))))
4.96+ (when (= 0 (length request-path))
4.97+ (setf request-path "/"))
4.98+ (when (= 0 (length cookie-path))
4.99+ (setf cookie-path "/"))
4.100+ (or (string= request-path cookie-path)
4.101+ (and (starts-with-subseq cookie-path request-path)
4.102+ (or (char= (last-char cookie-path) #\/)
4.103+ (char= (aref request-path (length cookie-path)) #\/))))))
4.104+
4.105+(defun match-cookie (cookie host path &key securep)
4.106+ "Get all available cookies for a specific host and path."
4.107+ (and (if (cookie-secure-p cookie)
4.108+ securep
4.109+ t)
4.110+ (match-cookie-path path (cookie-path cookie))
4.111+ (if (cookie-domain cookie)
4.112+ (cookie-domain-p host (cookie-domain cookie))
4.113+ (equalp host (cookie-origin-host cookie)))))
4.114+
4.115+(defun cookie-jar-host-cookies (cookie-jar host path &key securep)
4.116+ (delete-old-cookies cookie-jar)
4.117+ (remove-if-not (lambda (cookie)
4.118+ (match-cookie cookie host path :securep securep))
4.119+ (cookie-jar-cookies cookie-jar)))
4.120+
4.121+(defun write-cookie-header (cookies &optional stream)
4.122+ (labels ((write-cookie (cookie s)
4.123+ (format s "~A=~A"
4.124+ (cookie-name cookie)
4.125+ (cookie-value cookie)))
4.126+ (main (cookies stream)
4.127+ (write-cookie (pop cookies) stream)
4.128+ (dolist (cookie cookies)
4.129+ (write-string "; " stream)
4.130+ (write-cookie cookie stream))))
4.131+ (when cookies
4.132+ (if stream
4.133+ (main (ensure-cons cookies) stream)
4.134+ (with-output-to-string (s)
4.135+ (main (ensure-cons cookies) s))))))
4.136+
4.137+(defparameter +set-cookie-date-format+
4.138+ '(:short-weekday ", " (:day 2) #\space :short-month #\space (:year 4) #\space
4.139+ (:hour 2) #\: (:min 2) #\: (:sec 2) #\space "GMT")
4.140+ "The date format used in RFC 6265. For example: Wed, 09 Jun 2021 10:18:14 GMT.")
4.141+
4.142+(defun write-set-cookie-header (cookie &optional stream)
4.143+ "Writes full header in conformance with RFC 6265 plus some additional attributes."
4.144+ (labels ((format-cookie-date (universal-time s)
4.145+ (when universal-time
4.146+ (format-timestring s (universal-to-timestamp universal-time)
4.147+ :format +set-cookie-date-format+ :timezone local-time:+gmt-zone+))))
4.148+ (format stream
4.149+ "~A=~A~@[; Expires=~A~]~@[; Max-age=~A~]~@[; Path=~A~]~@[; Domain=~A~]~@[; SameSite=~A~]~:[~;; Partitioned~]~:[~;; Secure~]~:[~;; HttpOnly~]"
4.150+ (cookie-name cookie)
4.151+ (cookie-value cookie)
4.152+ (format-cookie-date (cookie-expires cookie) stream)
4.153+ (cookie-max-age cookie)
4.154+ (cookie-path cookie)
4.155+ (cookie-domain cookie)
4.156+ (cookie-same-site cookie)
4.157+ (cookie-partitioned cookie)
4.158+ (cookie-secure-p cookie)
4.159+ (cookie-httponly-p cookie))))
4.160+
4.161+(defun merge-cookies (cookie-jar cookies)
4.162+ (setf (cookie-jar-cookies cookie-jar)
4.163+ (delete-duplicates
4.164+ (nconc (cookie-jar-cookies cookie-jar)
4.165+ cookies)
4.166+ :test #'cookie=)))
4.167+
4.168+(define-condition invalid-set-cookie (error)
4.169+ ((header :initarg :header))
4.170+ (:report (lambda (condition stream)
4.171+ (format stream "Invalid Set-Cookie header: ~S"
4.172+ (slot-value condition 'header)))))
4.173+
4.174+(define-condition invalid-expires-date (error)
4.175+ ((expires :initarg :expires))
4.176+ (:report (lambda (condition stream)
4.177+ (format stream "Invalid expires date: ~S. Ignoring."
4.178+ (slot-value condition 'expires)))))
4.179+
4.180+(defun integer-char-p (char)
4.181+ (char<= #\0 char #\9))
4.182+
4.183+(defun get-tz-offset (tz-abbrev)
4.184+ (symbol-macrolet ((timezones local-time::*abbreviated-subzone-name->timezone-list*))
4.185+ (let* ((tz (gethash tz-abbrev timezones nil))
4.186+ (tz (if tz
4.187+ (car tz)
4.188+ (when (zerop (hash-table-count timezones))
4.189+ (local-time::reread-timezone-repository
4.190+ :timezone-repository (asdf:system-relative-pathname :local-time #P"zoneinfo/"))
4.191+ (first (gethash tz-abbrev timezones nil))))))
4.192+ (when tz
4.193+ (loop for sub across (local-time::timezone-subzones tz)
4.194+ when (equal tz-abbrev (local-time::subzone-abbrev sub))
4.195+ do (return (local-time::subzone-offset sub)))))))
4.196+
4.197+(defparameter *current-century-offset*
4.198+ (* (1- (timestamp-century (today)))
4.199+ 100))
4.200+
4.201+(defun parse-cookie-date (cookie-date)
4.202+ (let (year month day hour min sec offset)
4.203+ (handler-case
4.204+ (with-vector-parsing (cookie-date)
4.205+ (labels ((parse-month ()
4.206+ (if (integer-char-p (current))
4.207+ (parse-int)
4.208+ (match-case
4.209+ ("Jan" (match? "uary") 1)
4.210+ ("Feb" (match? "ruary") 2)
4.211+ ("Mar" (match? "ch") 3)
4.212+ ("Apr" (match? "il") 4)
4.213+ ("May" 5)
4.214+ ("Jun" (match? "e") 6)
4.215+ ("Jul" (match? "y") 7)
4.216+ ("Aug" (match? "ust") 8)
4.217+ ("Sep" (match? "tember") 9)
4.218+ ("Oct" (match? "ober") 10)
4.219+ ("Nov" (match? "ember") 11)
4.220+ ("Dec" (match? "ember") 12))))
4.221+ (parse-int ()
4.222+ (bind (int (skip-while integer-char-p))
4.223+ (parse-integer int))))
4.224+ (skip? #\")
4.225+ (match-case
4.226+ ("Sun" (match? "day"))
4.227+ ("Mon" (match? "day"))
4.228+ ("Tue" (match? "sday"))
4.229+ ("Wed" (match? "nesday"))
4.230+ ("Thu" (match? "rsday"))
4.231+ ("Fri" (match? "day"))
4.232+ ("Sat" (match? "urday")))
4.233+ (skip? #\,)
4.234+ (skip #\Space)
4.235+ (if (integer-char-p (current))
4.236+ (progn
4.237+ (setq day (parse-int))
4.238+ (skip #\Space #\-)
4.239+ (setq month (parse-month))
4.240+ (skip #\Space #\-)
4.241+ (setq year (parse-int))
4.242+ (skip #\Space)
4.243+ (setq hour (parse-int))
4.244+ (skip #\:)
4.245+ (setq min (parse-int))
4.246+ (skip #\:)
4.247+ (setq sec (parse-int)))
4.248+ (progn
4.249+ (setq month (parse-month))
4.250+ (skip #\Space #\-)
4.251+ (setq day (parse-int))
4.252+ (skip #\Space)
4.253+ (setq hour (parse-int))
4.254+ (skip #\:)
4.255+ (setq min (parse-int))
4.256+ (skip #\:)
4.257+ (setq sec (parse-int))
4.258+ (skip #\Space)
4.259+ (setq year (parse-int))))
4.260+ (skip #\Space)
4.261+ (bind (tz-abbrev (skip-while alpha-char-p))
4.262+ (setq offset (get-tz-offset tz-abbrev))
4.263+ (skip? #\")
4.264+ ;; Shorthand year, default to current century
4.265+ (when (< year 100)
4.266+ (incf year *current-century-offset*))
4.267+ (return-from parse-cookie-date
4.268+ (local-time:timestamp-to-universal
4.269+ (local-time:encode-timestamp 0 sec min hour day month year :timezone local-time:+gmt-zone+
4.270+ :offset offset))))))
4.271+ (error ()
4.272+ (error 'invalid-expires-date
4.273+ :expires cookie-date)))))
4.274+
4.275+(defun parse-set-cookie-header (set-cookie-string origin-host origin-path)
4.276+ "Parse cookie header string and return a cookie struct instance populated with
4.277+the respective slots."
4.278+ (check-type origin-host string)
4.279+ (let ((cookie (make-cookie :origin-host origin-host :path origin-path)))
4.280+ (handler-case
4.281+ (with-vector-parsing (set-cookie-string)
4.282+ (bind (name (skip+ (not #\=)))
4.283+ (setf (cookie-name cookie) name))
4.284+ (skip #\=)
4.285+ (bind (value (skip* (not #\;)))
4.286+ (setf (cookie-value cookie) value))
4.287+ (skip #\;)
4.288+ (loop
4.289+ (skip* #\Space)
4.290+ (match-i-case
4.291+ ("expires" (skip #\=)
4.292+ ;; Assume there're both the Max-Age and the Expires attribute if cookie-expires has already set.
4.293+ ;; In that case, just ignores Expires header.
4.294+ (if (cookie-expires cookie)
4.295+ (skip* (not #\;))
4.296+ (bind (expires (skip* (not #\;)))
4.297+ (setf (cookie-expires cookie)
4.298+ (parse-cookie-date expires)))))
4.299+ ("max-age" (skip #\=)
4.300+ (bind (max-age (skip* (not #\;)))
4.301+ (setf (cookie-max-age cookie)
4.302+ (parse-integer max-age))))
4.303+ ("path" (skip #\=)
4.304+ (bind (path (skip* (not #\;)))
4.305+ (setf (cookie-path cookie) path)))
4.306+ ("domain" (skip #\=)
4.307+ (bind (domain (skip* (not #\;)))
4.308+ (setf (cookie-domain cookie) domain)))
4.309+ ("samesite" (skip #\=)
4.310+ (bind (samesite (skip* (not #\;)))
4.311+ (setf (cookie-same-site cookie) samesite)))
4.312+ ("partitioned" (setf (cookie-partitioned cookie) t))
4.313+ ("secure" (setf (cookie-secure-p cookie) t))
4.314+ ("httponly" (setf (cookie-httponly-p cookie) t))
4.315+ (otherwise ;; Ignore unknown attributes
4.316+ (skip* (not #\=))
4.317+ (skip #\=)
4.318+ (skip* (not #\;))))
4.319+ (skip? #\;)))
4.320+ (match-failed ()
4.321+ (error 'invalid-set-cookie :header set-cookie-string))
4.322+ (invalid-expires-date (e)
4.323+ (warn (princ-to-string e))
4.324+ (return-from parse-set-cookie-header nil)))
4.325+ cookie))
5.1--- a/lisp/lib/net/net.asd Wed May 22 18:19:23 2024 -0400
5.2+++ b/lisp/lib/net/net.asd Wed May 22 22:16:26 2024 -0400
5.3@@ -9,6 +9,7 @@
5.4 ;; :swank ;; HACK 2024-05-12: temporarily disable, incompatible with current upstream
5.5 ;; :swank-client
5.6 :dexador ;; fetch
5.7+ :chipz :babel :chunga
5.8 :hunchentoot :std :log)
5.9 :serial t
5.10 :components ((:file "pkg")
5.11@@ -28,6 +29,8 @@
5.12 (:file "http")
5.13 (:file "dns")
5.14 (:file "ssh")))
5.15+ (:file "cookie")
5.16+ (:file "req")
5.17 (:file "fetch"))
5.18 :in-order-to ((test-op (test-op :net/tests))))
5.19
6.1--- a/lisp/lib/net/pkg.lisp Wed May 22 18:19:23 2024 -0400
6.2+++ b/lisp/lib/net/pkg.lisp Wed May 22 22:16:26 2024 -0400
6.3@@ -233,6 +233,73 @@
6.4 :invalid-parameter-key
6.5 :invalid-parameter-value))
6.6
6.7+(defpackage net/cookie
6.8+ (:use :cl :parse/bytes)
6.9+ (:import-from :obj/time
6.10+ :today
6.11+ :timestamp-century
6.12+ :timestamp-to-universal
6.13+ :universal-to-timestamp
6.14+ :format-timestring
6.15+ :encode-timestamp
6.16+ :*abbreviated-subzone-name->timezone-list*
6.17+ :reread-timezone-repository
6.18+ :timezone-subzones
6.19+ :subzone-abbrev
6.20+ :subzone-offset
6.21+ :+gmt-zone+)
6.22+ (:export :parse-set-cookie-header
6.23+ :write-cookie-header
6.24+ :write-set-cookie-header
6.25+ :cookie
6.26+ :make-cookie
6.27+ :cookie=
6.28+ :cookie-equal
6.29+ :cookie-name
6.30+ :cookie-value
6.31+ :cookie-expires
6.32+ :cookie-path
6.33+ :cookie-domain
6.34+ :cookie-same-site
6.35+ :cookie-max-age
6.36+ :cookie-partitioned
6.37+ :cookie-secure-p
6.38+ :cookie-httponly-p
6.39+ :cookie-origin-host
6.40+ :cookie-jar
6.41+ :make-cookie-jar
6.42+ :cookie-jar-cookies
6.43+ :cookie-jar-host-cookies
6.44+ :merge-cookies))
6.45+
6.46+(defpackage :net/req
6.47+ (:nicknames :req)
6.48+ (:shadowing-import-from :babel :string-to-octets)
6.49+ (:shadowing-import-from :std/type :octet :octet-vector)
6.50+ (:shadow :get :delete)
6.51+ (:use :cl :std :obj/uri :net/proto/http :sb-ext :babel :net/cookie :fast-io :dat/base64)
6.52+ (:export
6.53+ :request
6.54+ :get
6.55+ :post
6.56+ :head
6.57+ :put
6.58+ :patch
6.59+ :delete
6.60+ :fetch
6.61+ :*default-connect-timeout*
6.62+ :*default-read-timeout*
6.63+ :*default-proxy*
6.64+ :*verbose*
6.65+ :*not-verify-ssl*
6.66+ :*connection-pool*
6.67+ :*use-connection-pool*
6.68+ :make-connection-pool
6.69+ :clear-connection-pool
6.70+ ;; Restarts
6.71+ :retry-request
6.72+ :ignore-and-continue))
6.73+
6.74 (uiop:define-package :net/fetch
6.75 (:nicknames :fetch)
6.76 (:use :cl :std :obj/uri)
7.1--- a/lisp/lib/net/proto/http.lisp Wed May 22 18:19:23 2024 -0400
7.2+++ b/lisp/lib/net/proto/http.lisp Wed May 22 22:16:26 2024 -0400
7.3@@ -249,7 +249,7 @@
7.4 (type simple-byte-vector data)
7.5 (type pointer start end))
7.6 (xnconcf header-value-buffer
7.7- (subseq (subseq (the simple-byte-vector data) start end) 0)))
7.8+ (xsubseq (subseq (the octet-vector data) start end) 0)))
7.9 :headers-complete (lambda (http)
7.10 (collect-prev-header-value)
7.11 (setq header-value-buffer nil)
7.12@@ -810,7 +810,7 @@
7.13 status-text)
7.14
7.15 ;;; Errors
7.16-(define-condition http-error (simple-error)
7.17+(define-condition http-error (net-error)
7.18 (description)
7.19 (:report
7.20 (lambda (condition stream)
8.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
8.2+++ b/lisp/lib/net/req.lisp Wed May 22 22:16:26 2024 -0400
8.3@@ -0,0 +1,1717 @@
8.4+;;; net/req.lisp --- HTTP Request API
8.5+
8.6+;; based on Fukamachi's DEXADOR
8.7+
8.8+;;; Code:
8.9+(in-package :net/req)
8.10+
8.11+;;; errors
8.12+(define-condition http-request-failed (error)
8.13+ ((body :initarg :body
8.14+ :reader response-body)
8.15+ (status :initarg :status
8.16+ :reader response-status)
8.17+ (headers :initarg :headers
8.18+ :reader response-headers)
8.19+ (uri :initarg :uri
8.20+ :reader request-uri)
8.21+ (method :initarg :method
8.22+ :reader request-method))
8.23+ (:report (lambda (condition stream)
8.24+ (with-slots (uri status) condition
8.25+ (format stream "An HTTP request to ~S has failed (status=~D)."
8.26+ (render-uri uri nil)
8.27+ status)))))
8.28+
8.29+(defmacro define-request-failed-condition (name code)
8.30+ `(define-condition ,(intern (format nil "~A-~A" :http-request name)) (http-request-failed)
8.31+ ()
8.32+ (:report (lambda (condition stream)
8.33+ (with-slots (body uri) condition
8.34+ (format stream ,(format nil "An HTTP request to ~~S returned ~D ~A.~~2%~~A"
8.35+ code
8.36+ (substitute #\Space #\- (string-downcase name)))
8.37+ (render-uri uri nil)
8.38+ body))))))
8.39+
8.40+
8.41+(defvar *request-failed-error* (make-hash-table :test 'eql))
8.42+
8.43+#.`(progn
8.44+ ,@(loop for (name . code) in '(;; 4xx (Client Errors)
8.45+ (bad-request . 400)
8.46+ (unauthorized . 401)
8.47+ (payment-required . 402)
8.48+ (forbidden . 403)
8.49+ (not-found . 404)
8.50+ (method-not-allowed . 405)
8.51+ (not-acceptable . 406)
8.52+ (proxy-authentication-required . 407)
8.53+ (request-timeout . 408)
8.54+ (conflict . 409)
8.55+ (gone . 410)
8.56+ (length-required . 411)
8.57+ (precondition-failed . 412)
8.58+ (payload-too-large . 413)
8.59+ (uri-too-long . 414)
8.60+ (unsupported-media-type . 415)
8.61+ (range-not-satisfiable . 416)
8.62+ (expectation-failed . 417)
8.63+ (misdirected-request . 421)
8.64+ (upgrade-required . 426)
8.65+ (too-many-requests . 429)
8.66+
8.67+ ;; 5xx (Server Errors)
8.68+ (internal-server-error . 500)
8.69+ (not-implemented . 501)
8.70+ (bad-gateway . 502)
8.71+ (service-unavailable . 503)
8.72+ (gateway-timeout . 504)
8.73+ (http-version-not-supported . 505))
8.74+ collect `(define-request-failed-condition ,name ,code)
8.75+ collect `(setf (gethash ,code *request-failed-error*)
8.76+ ',(intern (format nil "~A-~A" :http-request name)))))
8.77+
8.78+(defun http-request-failed (status &key body headers uri method)
8.79+ (cerror
8.80+ "Ignore and continue"
8.81+ (gethash status *request-failed-error* 'http-request-failed)
8.82+ :body body
8.83+ :status status
8.84+ :headers headers
8.85+ :uri uri
8.86+ :method method))
8.87+
8.88+(define-condition socks5-proxy-request-failed (http-request-failed)
8.89+ ((reason :initarg :reason))
8.90+ (:report (lambda (condition stream)
8.91+ (with-slots (uri reason) condition
8.92+ (format stream "An HTTP request to ~S via SOCKS5 has failed (reason=~S)."
8.93+ (render-uri uri nil)
8.94+ reason)))))
8.95+
8.96+;;; utils
8.97+(defvar *default-connect-timeout* 10)
8.98+(defvar *default-read-timeout* 10)
8.99+(defvar *verbose* nil)
8.100+(defvar *no-ssl* nil)
8.101+
8.102+(defvar *default-proxy* (or #-windows (uiop:getenv "HTTPS_PROXY")
8.103+ #-windows (uiop:getenv "HTTP_PROXY"))
8.104+ "If specified will be used as the default value of PROXY in calls to dexador. Defaults to
8.105+ the value of the environment variable HTTPS_PROXY or HTTP_PROXY if not on Windows.")
8.106+
8.107+(define-constant +crlf+ (string-to-octets (format nil "~C~C" #\Return #\Newline)) :test 'equalp)
8.108+
8.109+(eval-always
8.110+ (defparameter *default-user-agent*
8.111+ (format nil "cc/req (~A~@[ ~A~]); ~A;~@[ ~A~]"
8.112+ (lisp-implementation-type)
8.113+ (lisp-implementation-version)
8.114+ (software-type)
8.115+ (software-version))))
8.116+
8.117+(defparameter *header-buffer* nil)
8.118+
8.119+(defun write-first-line (method uri version &optional (buffer *header-buffer*))
8.120+ (fast-write-sequence (string-to-octets (string method)) buffer)
8.121+ (fast-write-byte #.(char-code #\Space) buffer)
8.122+ (fast-write-sequence (string-to-octets
8.123+ (format nil "~A~:[~;~:*?~A~]"
8.124+ (or (uri-path uri) "/")
8.125+ (uri-query uri)))
8.126+ buffer)
8.127+ (fast-write-byte #.(char-code #\Space) buffer)
8.128+ (fast-write-sequence (ecase version
8.129+ (1.1 (string-to-octets "HTTP/1.1"))
8.130+ (1.0 (string-to-octets "HTTP/1.0")))
8.131+ buffer)
8.132+ (fast-write-sequence +crlf+ buffer))
8.133+
8.134+(defun write-header-field (name buffer)
8.135+ (fast-write-sequence (if (typep name 'octet-vector)
8.136+ name
8.137+ (string-to-octets (string-capitalize name)))
8.138+ buffer))
8.139+
8.140+(defun write-header-value (value buffer)
8.141+ (fast-write-sequence (if (typep value 'octet-vector)
8.142+ value
8.143+ (string-to-octets (princ-to-string value)))
8.144+ buffer))
8.145+
8.146+(defun write-header (name value &optional (buffer *header-buffer*))
8.147+ (write-header-field name buffer)
8.148+ (fast-write-sequence (string-to-octets ": ") buffer)
8.149+ (write-header-value value buffer)
8.150+ (fast-write-sequence +crlf+ buffer))
8.151+
8.152+(define-compiler-macro write-header (name value &optional (buffer '*header-buffer*))
8.153+ `(progn
8.154+ ,(if (and (constantp name)
8.155+ (typep name '(or keyword string)))
8.156+ `(fast-write-sequence (string-to-octets ,(string-capitalize name)) ,buffer)
8.157+ `(write-header-field ,name ,buffer))
8.158+ (fast-write-sequence (string-to-octets ": ") ,buffer)
8.159+ ,(if (constantp value)
8.160+ `(fast-write-sequence (string-to-octets ,(string value)) ,buffer)
8.161+ `(write-header-value ,value ,buffer))
8.162+ (fast-write-sequence +crlf+ ,buffer)))
8.163+
8.164+(defmacro with-header-output ((buffer &optional output) &body body)
8.165+ `(fast-io:with-fast-output (,buffer ,output)
8.166+ (declare (ignorable ,buffer))
8.167+ (let ((*header-buffer* ,buffer))
8.168+ ,@body)))
8.169+
8.170+(defun write-connect-header (uri version buffer &optional proxy-auth)
8.171+ (fast-write-sequence (string-to-octets "CONNECT") buffer)
8.172+ (fast-write-byte #.(char-code #\Space) buffer)
8.173+ (fast-write-sequence (string-to-octets (format nil "~A:~A"
8.174+ (uri-host uri)
8.175+ (uri-port uri)))
8.176+ buffer)
8.177+ (fast-write-byte #.(char-code #\Space) buffer)
8.178+ (fast-write-sequence (ecase version
8.179+ (1.1 (string-to-octets "HTTP/1.1"))
8.180+ (1.0 (string-to-octets "HTTP/1.0")))
8.181+ buffer)
8.182+ (fast-write-sequence +crlf+ buffer)
8.183+ (fast-write-sequence (string-to-octets "Host:") buffer)
8.184+ (fast-write-byte #.(char-code #\Space) buffer)
8.185+ (fast-write-sequence (string-to-octets (format nil "~A:~A"
8.186+ (uri-host uri)
8.187+ (uri-port uri)))
8.188+ buffer)
8.189+ (when proxy-auth
8.190+ (fast-write-sequence +crlf+ buffer)
8.191+ (fast-write-sequence (string-to-octets "Proxy-Authorization:") buffer)
8.192+ (fast-write-byte #.(char-code #\Space) buffer)
8.193+ (fast-write-sequence (string-to-octets proxy-auth) buffer))
8.194+ (fast-write-sequence +crlf+ buffer)
8.195+ (fast-write-sequence +crlf+ buffer))
8.196+
8.197+(defun make-random-string (&optional (length 12))
8.198+ (declare (type fixnum length))
8.199+ (let ((result (make-string length)))
8.200+ (declare (type simple-string result))
8.201+ (dotimes (i length result)
8.202+ (setf (aref result i)
8.203+ (ecase (random 5)
8.204+ ((0 1) (code-char (+ #.(char-code #\a) (random 26))))
8.205+ ((2 3) (code-char (+ #.(char-code #\A) (random 26))))
8.206+ ((4) (code-char (+ #.(char-code #\0) (random 10)))))))))
8.207+
8.208+;;; encoding
8.209+(defun parse-content-type (content-type)
8.210+ (let ((types
8.211+ (nth-value 1
8.212+ (ppcre:scan-to-strings "^\\s*?(\\w+)/([^;\\s]+)(?:\\s*;\\s*charset=([A-Za-z0-9_-]+))?"
8.213+ content-type))))
8.214+ (when types
8.215+ (values (aref types 0)
8.216+ (aref types 1)
8.217+ (aref types 2)))))
8.218+
8.219+(defun charset-to-encoding (charset &optional
8.220+ (default *default-external-format*))
8.221+ (cond
8.222+ ((null charset)
8.223+ default)
8.224+ ((string-equal charset "utf-8")
8.225+ :utf-8)
8.226+ ((string-equal charset "euc-jp")
8.227+ :eucjp)
8.228+ ((or (string-equal charset "shift_jis")
8.229+ (string-equal charset "shift-jis"))
8.230+ :cp932)
8.231+ ((string-equal charset "windows-31j")
8.232+ :cp932)
8.233+ (t (or (when (sb-impl::get-external-format (keywordicate charset)) charset)
8.234+ default))))
8.235+
8.236+(defun detect-charset (content-type body)
8.237+ (multiple-value-bind (type subtype charset)
8.238+ (parse-content-type content-type)
8.239+ (cond
8.240+ ((charset-to-encoding charset nil))
8.241+ ((string-equal type "text")
8.242+ (or (charset-to-encoding charset nil)
8.243+ (if (and (string-equal subtype "html")
8.244+ (typep body '(array (unsigned-byte 8) (*))))
8.245+ (charset-to-encoding (detect-charset-from-html body) nil)
8.246+ nil)
8.247+ :utf-8))
8.248+ ((and (string-equal type "application")
8.249+ (or (string-equal subtype "json")
8.250+ (string-equal subtype "javascript")))
8.251+ ;; According to RFC4627 (http://www.ietf.org/rfc/rfc4627.txt),
8.252+ ;; JSON text SHALL be encoded in Unicode. The default encoding is UTF-8.
8.253+ ;; It's possible to determine if the encoding is UTF-16 or UTF-36
8.254+ ;; by looking at the first four octets, however, I leave it to the future.
8.255+ ;;
8.256+ ;; According to RFC4329 (https://datatracker.ietf.org/doc/html/rfc4329),
8.257+ ;; javascript also is specified by charset, or defaults to UTF-8
8.258+ ;; It's also possible to specify in the first four octets, but
8.259+ ;; like application/json I leave it to the future.
8.260+ (charset-to-encoding charset :utf-8))
8.261+ ((and (string-equal type "application")
8.262+ (ppcre:scan "(?:[^+]+\\+)?xml" subtype))
8.263+ (charset-to-encoding charset)))))
8.264+
8.265+(defun detect-charset-from-html (body)
8.266+ "Detect the body's charset by (roughly) searching meta tags which has \"charset\" attribute."
8.267+ (labels ((find-meta (start)
8.268+ (search #.(string-to-octets "<meta ") body :start2 start))
8.269+ (main (start)
8.270+ (let ((start (find-meta start)))
8.271+ (unless start
8.272+ (return-from main nil))
8.273+ (let ((end (position (char-code #\>) body :start start :test #'=)))
8.274+ (unless end
8.275+ (return-from main nil))
8.276+ (incf end)
8.277+ (let ((match (nth-value 1 (ppcre:scan-to-strings
8.278+ "charset=[\"']?([^\\s\"'>]+)[\"']?"
8.279+ (octets-to-string body :start start :end end)))))
8.280+ (if match
8.281+ (aref match 0)
8.282+ (main end)))))))
8.283+ (main 0)))
8.284+
8.285+;;; keep-alive-stream
8.286+(defclass keep-alive-stream (fundamental-input-stream)
8.287+ ((stream :type (or null stream)
8.288+ :initarg :stream
8.289+ :initform (error ":stream is required")
8.290+ :accessor keep-alive-stream-stream
8.291+ :documentation "A stream; when we read END elements from it, we call CLOSE-ACTION on it and
8.292+ set this slot to nil.")
8.293+ (end :initarg :end
8.294+ :initform nil
8.295+ :accessor keep-alive-stream-end)
8.296+ (close-action :initarg :on-close-or-eof :reader close-action
8.297+ :documentation "A (lambda (stream abort)) which will be called with keep-alive-stream-stream
8.298+ when the stream is either closed or we hit end of file or we hit end")))
8.299+
8.300+(defun keep-alive-stream-close-underlying-stream (underlying-stream abort)
8.301+ (when (and underlying-stream (open-stream-p underlying-stream))
8.302+ (close underlying-stream :abort abort)))
8.303+
8.304+(defclass keep-alive-chunked-stream (keep-alive-stream)
8.305+ ((chunga-stream :initarg :chunga-stream :accessor chunga-stream)))
8.306+
8.307+(defun make-keep-alive-stream (stream &key end chunked-stream (on-close-or-eof #'keep-alive-stream-close-underlying-stream))
8.308+ "ON-CLOSE-OR-EOF takes a single parameter, STREAM (the stream passed in here, not the
8.309+keep-alive-stream), and should handle clean-up of it"
8.310+ (assert (xor end chunked-stream))
8.311+ (if chunked-stream
8.312+ (make-instance 'keep-alive-chunked-stream :stream stream :chunga-stream chunked-stream :on-close-or-eof on-close-or-eof)
8.313+ (make-instance 'keep-alive-stream :stream stream :end end :on-close-or-eof on-close-or-eof)))
8.314+
8.315+(defun maybe-close (stream &optional (close-if nil))
8.316+ "Will close the underlying stream if close-if is T (unless it is already closed).
8.317+ If the stream is already closed or we closed it returns :EOF otherwise NIL."
8.318+ (let ((underlying-stream (keep-alive-stream-stream stream)))
8.319+ (cond
8.320+ ((not underlying-stream)
8.321+ :eof)
8.322+ (close-if
8.323+ (funcall (close-action stream) underlying-stream nil)
8.324+ (setf (keep-alive-stream-stream stream) nil)
8.325+ :eof)
8.326+ (t nil))))
8.327+
8.328+(defmethod stream-read-byte ((stream keep-alive-stream))
8.329+ "Return :EOF or byte read. When we hit EOF or finish reading our allowed content,
8.330+ call the close-action on our underlying-stream and return EOF."
8.331+ (let ((byte :eof)
8.332+ (underlying-stream (keep-alive-stream-stream stream)))
8.333+ (or (maybe-close stream (<= (keep-alive-stream-end stream) 0))
8.334+ (progn
8.335+ (setf byte (read-byte underlying-stream nil :eof))
8.336+ (decf (keep-alive-stream-end stream) 1)
8.337+ (maybe-close stream (or (<= (keep-alive-stream-end stream) 0) (eql byte :eof)))
8.338+ byte))))
8.339+
8.340+(defmethod stream-read-byte ((stream keep-alive-chunked-stream))
8.341+ "Return :EOF or byte read. When we hit :EOF or finish reading our chunk,
8.342+ call the close-action on our underlying-stream and return :EOF"
8.343+ (or (maybe-close stream)
8.344+ (if (chunga:chunked-stream-input-chunking-p (chunga-stream stream))
8.345+ (let ((byte (read-byte (chunga-stream stream) nil :eof)))
8.346+ (if (eql byte :eof)
8.347+ (prog1
8.348+ byte
8.349+ (maybe-close stream t))
8.350+ byte))
8.351+ (or (maybe-close stream t) :eof))))
8.352+
8.353+(defmethod stream-read-sequence ((stream keep-alive-stream) sequence start end &key)
8.354+ (declare (optimize speed))
8.355+ (if (null (keep-alive-stream-stream stream)) ;; we already closed it
8.356+ start
8.357+ (let* ((to-read (min (- end start) (keep-alive-stream-end stream)))
8.358+ (n (read-sequence sequence (keep-alive-stream-stream stream)
8.359+ :start start
8.360+ :end (+ start to-read))))
8.361+ (decf (keep-alive-stream-end stream) (- n start))
8.362+ (maybe-close stream (<= (keep-alive-stream-end stream) 0))
8.363+ n)))
8.364+
8.365+(defmethod stream-read-sequence ((stream keep-alive-chunked-stream) sequence start end &key)
8.366+ (declare (optimize speed))
8.367+ (if (null (keep-alive-stream-stream stream)) ;; we already closed it
8.368+ start
8.369+ (if (chunga:chunked-stream-input-chunking-p (chunga-stream stream))
8.370+ (prog1
8.371+ (let ((num-read (read-sequence sequence (chunga-stream stream) :start start :end end)))
8.372+ num-read)
8.373+ (maybe-close stream (not (chunga:chunked-stream-input-chunking-p (chunga-stream stream)))))
8.374+ start)))
8.375+
8.376+(defmethod stream-element-type ((stream keep-alive-chunked-stream))
8.377+ (stream-element-type (chunga-stream stream)))
8.378+
8.379+(defmethod stream-element-type ((stream keep-alive-stream))
8.380+ '(unsigned-byte 8))
8.381+
8.382+(defmethod open-stream-p ((stream keep-alive-stream))
8.383+ (let ((underlying-stream (keep-alive-stream-stream stream)))
8.384+ (and underlying-stream (open-stream-p underlying-stream))))
8.385+
8.386+(defmethod close ((stream keep-alive-stream) &key abort)
8.387+ (funcall (close-action stream) (keep-alive-stream-stream stream) abort)
8.388+ (setf (keep-alive-stream-stream stream) nil))
8.389+
8.390+;;; decoding-stream
8.391+(declaim (type fixnum +buffer-size+))
8.392+(eval-when (:compile-toplevel :load-toplevel :execute)
8.393+ (defconstant +buffer-size+ 128))
8.394+
8.395+(defclass decoding-stream (fundamental-character-input-stream)
8.396+ ((stream :type stream
8.397+ :initarg :stream
8.398+ :initform (error ":stream is required")
8.399+ :accessor decoding-stream-stream)
8.400+ (encoding :initarg :encoding
8.401+ :initform (error ":encoding is required")
8.402+ :accessor decoding-stream-encoding)
8.403+ (buffer :type (simple-array (unsigned-byte 8) (#.+buffer-size+))
8.404+ :initform (make-array +buffer-size+ :element-type '(unsigned-byte 8))
8.405+ :accessor decoding-stream-buffer)
8.406+ (buffer-position :type fixnum
8.407+ :initform +buffer-size+
8.408+ :accessor decoding-stream-buffer-position)
8.409+ (buffer-end-position :type fixnum
8.410+ :initform -1
8.411+ :accessor decoding-stream-buffer-end-position)
8.412+ (last-char :type character
8.413+ :initform #\Nul
8.414+ :accessor decoding-stream-last-char)
8.415+ (last-char-size :type fixnum
8.416+ :initform 0
8.417+ :accessor decoding-stream-last-char-size)
8.418+ (on-close :type (or null function) :initform nil :initarg :on-close)))
8.419+
8.420+(defmethod initialize-instance :after ((stream decoding-stream) &rest initargs)
8.421+ (declare (ignore initargs))
8.422+ (with-slots (encoding) stream
8.423+ (when (keywordp encoding)
8.424+ (setf encoding (babel-encodings:get-character-encoding encoding)))))
8.425+
8.426+(defun make-decoding-stream (stream &key (encoding babel-encodings:*default-character-encoding*)
8.427+ (on-close))
8.428+ (let ((decoding-stream (make-instance 'decoding-stream
8.429+ :stream stream
8.430+ :encoding encoding
8.431+ :on-close on-close)))
8.432+ (fill-buffer decoding-stream)
8.433+ decoding-stream))
8.434+
8.435+(defun fill-buffer (stream)
8.436+ (declare (optimize speed))
8.437+ (with-slots (stream buffer buffer-position buffer-end-position) stream
8.438+ (declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+)) buffer)
8.439+ (type fixnum buffer-position))
8.440+ (let ((to-read (- +buffer-size+ buffer-position)))
8.441+ (declare (type fixnum to-read))
8.442+ (replace buffer buffer
8.443+ :start1 0
8.444+ :start2 buffer-position
8.445+ :end2 +buffer-size+)
8.446+ (setf buffer-position 0)
8.447+ (let ((n (read-sequence buffer stream :start to-read)))
8.448+ (declare (type fixnum n))
8.449+ (unless (= n +buffer-size+)
8.450+ (setf buffer-end-position n))))))
8.451+
8.452+(defun needs-to-fill-buffer-p (stream)
8.453+ (declare (optimize speed))
8.454+ (when (/= -1 (the fixnum (decoding-stream-buffer-end-position stream)))
8.455+ (return-from needs-to-fill-buffer-p nil))
8.456+
8.457+ (with-slots (buffer-position encoding) stream
8.458+ (< (- +buffer-size+ (the fixnum buffer-position))
8.459+ (the fixnum (babel-encodings:enc-max-units-per-char encoding)))))
8.460+
8.461+
8.462+(defmethod stream-read-char ((stream decoding-stream))
8.463+ (declare (optimize speed))
8.464+ (when (needs-to-fill-buffer-p stream)
8.465+ (fill-buffer stream))
8.466+
8.467+ (when (= (the fixnum (decoding-stream-buffer-end-position stream))
8.468+ (the fixnum (decoding-stream-buffer-position stream)))
8.469+ (return-from stream-read-char :eof))
8.470+
8.471+ (with-slots (buffer buffer-position encoding last-char last-char-size)
8.472+ stream
8.473+ (declare (fixnum buffer-position))
8.474+ (let* ((mapping (babel-encodings:lookup-mapping babel::*string-vector-mappings* encoding))
8.475+ (counter (babel-encodings:code-point-counter mapping)))
8.476+ (declare (type function counter))
8.477+ (multiple-value-bind (chars new-end)
8.478+ (funcall counter buffer buffer-position +buffer-size+ 1)
8.479+ (declare (ignore chars) (fixnum new-end))
8.480+ (let ((string (make-string 1 :element-type 'babel:unicode-char))
8.481+ (size (the fixnum (- new-end buffer-position))))
8.482+ (funcall (the function (babel-encodings:decoder mapping))
8.483+ buffer buffer-position new-end string 0)
8.484+ (setf buffer-position new-end
8.485+ last-char (aref string 0)
8.486+ last-char-size size)
8.487+ (aref string 0))))))
8.488+
8.489+(defmethod stream-unread-char ((stream decoding-stream) char)
8.490+ (let ((last-char (decoding-stream-last-char stream)))
8.491+ (when (char= last-char #\Nul)
8.492+ (error "No character to unread from this stream"))
8.493+ (unless (char= char last-char)
8.494+ (error "Last character read (~S) was different from ~S"
8.495+ last-char char))
8.496+ (with-slots (buffer-position last-char-size) stream
8.497+ (decf buffer-position last-char-size))
8.498+ (with-slots (last-char last-char-size) stream
8.499+ (setf last-char #\Nul
8.500+ last-char-size 0))
8.501+ nil))
8.502+
8.503+#+(or abcl clasp ecl)
8.504+(defmethod stream-read-sequence ((stream decoding-stream) sequence start end &key)
8.505+ (loop for i from start to end
8.506+ for char = (stream-read-char stream)
8.507+ if (eq char :eof)
8.508+ do (return i)
8.509+ else do (setf (aref sequence i) char)
8.510+ finally (return end)))
8.511+
8.512+#+(or clasp ecl)
8.513+(defmethod stream-read-byte ((stream decoding-stream))
8.514+ (with-slots (last-char last-char-size) stream
8.515+ (setf last-char #\Nul
8.516+ last-char-size 0))
8.517+ (read-byte (decoding-stream-stream stream) nil :eof))
8.518+
8.519+(defmethod open-stream-p ((stream decoding-stream))
8.520+ (open-stream-p (decoding-stream-stream stream)))
8.521+
8.522+(defmethod stream-element-type ((stream decoding-stream))
8.523+ 'unicode-char)
8.524+
8.525+(defmethod close ((stream decoding-stream) &key abort)
8.526+ ;; TODO: modify me to return the connection to the connection pool
8.527+ (with-slots (stream) stream
8.528+ (when (open-stream-p stream)
8.529+ (close stream :abort abort))))
8.530+
8.531+;;; body
8.532+(defun decode-body (content-type body &key default-charset on-close)
8.533+ (let ((charset (or (and content-type
8.534+ (detect-charset content-type body))
8.535+ default-charset))
8.536+ (babel-encodings:*suppress-character-coding-errors* t))
8.537+ (if charset
8.538+ (handler-case
8.539+ (if (streamp body)
8.540+ (make-decoding-stream body :encoding charset :on-close on-close)
8.541+ (babel:octets-to-string body :encoding (keywordicate charset)))
8.542+ (babel:character-decoding-error (e)
8.543+ (warn (format nil "Failed to decode the body to ~S due to the following error (falling back to binary):~% ~A"
8.544+ charset
8.545+ e))
8.546+ (return-from decode-body body)))
8.547+ body)))
8.548+
8.549+(defun content-disposition (key val)
8.550+ (typecase val
8.551+ (cons (content-disposition key (first val)))
8.552+ (pathname
8.553+ (let* ((filename (file-namestring val))
8.554+ (utf8-filename-p (find-if (lambda (char)
8.555+ (< 127 (char-code char)))
8.556+ filename)))
8.557+ (format nil "Content-Disposition: form-data; name=\"~A\"; ~:[filename=\"~A\"~;filename*=UTF-8''~A~]~C~C"
8.558+ key
8.559+ utf8-filename-p
8.560+ (if utf8-filename-p
8.561+ (obj/uri:parse-uri filename)
8.562+ filename)
8.563+ #\Return #\Newline)))
8.564+ (otherwise
8.565+ (format nil "Content-Disposition: form-data; name=\"~A\"~C~C"
8.566+ key
8.567+ #\Return #\Newline))))
8.568+
8.569+(defmacro define-alist-cache (cache-name)
8.570+ (let ((var (intern (format nil "*~A*" cache-name))))
8.571+ `(progn
8.572+ (defvar ,var)
8.573+ (defun ,(intern (format nil "LOOKUP-IN-~A" cache-name)) (elt)
8.574+ (when (boundp ',var)
8.575+ (alexandria:assoc-value ,var elt)))
8.576+ (defun (setf ,(intern (format nil "LOOKUP-IN-~A" cache-name))) (val elt)
8.577+ (when (boundp ',var)
8.578+ (setf (alexandria:assoc-value ,var elt) val))
8.579+ val))))
8.580+
8.581+;; If bound, an alist mapping content to content-type,
8.582+;; used to avoid determining content type multiple times
8.583+(define-alist-cache content-type-cache)
8.584+;; If bound, an alist mapping content to encoded content, to avoid
8.585+;; double converting content when we must calculate its length first
8.586+(define-alist-cache content-encoding-cache)
8.587+
8.588+(defmacro with-content-caches (&body body)
8.589+ `(let ((*content-type-cache* nil)
8.590+ (*content-encoding-cache* nil))
8.591+ ,@body))
8.592+
8.593+(defun content-type (value)
8.594+ (typecase value
8.595+ (pathname (or (lookup-in-content-type-cache value)
8.596+ (setf (lookup-in-content-type-cache value) (mimes:mime value))))
8.597+ (otherwise nil)))
8.598+
8.599+(defun multipart-value-content-type (value)
8.600+ (typecase value
8.601+ (cons
8.602+ (destructuring-bind (val &key content-type)
8.603+ value
8.604+ (or content-type (content-type val))))
8.605+ (otherwise (content-type value))))
8.606+
8.607+(defun convert-to-octets (val)
8.608+ (or (lookup-in-content-encoding-cache val)
8.609+ (setf (lookup-in-content-encoding-cache val)
8.610+ (typecase val
8.611+ (string (babel:string-to-octets val))
8.612+ ((array (unsigned-byte 8) (*)) val)
8.613+ (symbol (babel:string-to-octets (princ-to-string val)))
8.614+ (cons (convert-to-octets (first val)))
8.615+ (otherwise (babel:string-to-octets (princ-to-string val)))))))
8.616+
8.617+(defun write-as-octets (stream val)
8.618+ (typecase val
8.619+ ((array (unsigned-byte 8) (*)) (write-sequence val stream))
8.620+ (pathname
8.621+ (with-open-file (in val :element-type '(unsigned-byte 8))
8.622+ (copy-stream in stream)))
8.623+ (string
8.624+ (write-sequence (convert-to-octets val) stream))
8.625+ (cons (write-as-octets stream (first val)))
8.626+ (otherwise (fast-write-sequence (convert-to-octets val) stream))))
8.627+
8.628+(defun content-length (val)
8.629+ (typecase val
8.630+ (pathname (with-open-file (in val)
8.631+ (file-length in)))
8.632+ (cons (content-length (first val)))
8.633+ (otherwise (length (convert-to-octets val)))))
8.634+
8.635+(defun multipart-content-length (content boundary)
8.636+ (declare (type simple-string boundary))
8.637+ (let ((boundary-length (length boundary)))
8.638+ (+ (loop for (key . val) in content
8.639+ sum (+ 2 ;; --
8.640+ boundary-length
8.641+ 2 ;; CR LF
8.642+ (length (the simple-string (content-disposition key val)))
8.643+ (let ((content-type (multipart-value-content-type val)))
8.644+ (if content-type
8.645+ (+ #.(length "Content-Type: ") (length content-type) 2)
8.646+ 0))
8.647+ 2
8.648+ (content-length val)
8.649+ 2)
8.650+ into total-length
8.651+ finally (return total-length))
8.652+ 2 boundary-length 2 2)))
8.653+
8.654+(defun write-multipart-content (content boundary stream)
8.655+ (let ((boundary (string-to-octets boundary)))
8.656+ (labels ((boundary-line (&optional endp)
8.657+ (fast-write-sequence (string-to-octets "--") stream)
8.658+ (fast-write-sequence boundary stream)
8.659+ (when endp
8.660+ (fast-write-sequence (string-to-octets "--") stream))
8.661+ (crlf))
8.662+ (crlf () (fast-write-sequence +crlf+ stream)))
8.663+ (loop for (key . val) in content
8.664+ do (boundary-line)
8.665+ (fast-write-sequence (string-to-octets (content-disposition key val)) stream)
8.666+ (let ((content-type (multipart-value-content-type val)))
8.667+ (when content-type
8.668+ (fast-write-sequence
8.669+ (string-to-octets
8.670+ (format nil "Content-Type: ~A~C~C" content-type #\Return #\Newline))
8.671+ stream)))
8.672+ (crlf)
8.673+ (write-as-octets stream val)
8.674+ (crlf)
8.675+ finally
8.676+ (boundary-line t)))))
8.677+
8.678+(defun decompress-body (content-encoding body)
8.679+ (unless content-encoding
8.680+ (return-from decompress-body body))
8.681+
8.682+ (cond
8.683+ ((string= content-encoding "gzip")
8.684+ (if (streamp body)
8.685+ (chipz:make-decompressing-stream :gzip body)
8.686+ (chipz:decompress nil (chipz:make-dstate :gzip) body)))
8.687+ ((string= content-encoding "deflate")
8.688+ (if (streamp body)
8.689+ (chipz:make-decompressing-stream :zlib body)
8.690+ (chipz:decompress nil (chipz:make-dstate :zlib) body)))
8.691+ (t body)))
8.692+
8.693+;;; connection-cache
8.694+(defvar *use-connection-pool* t)
8.695+(defvar *max-active-connections* 8
8.696+ "Allowed number of active connections to all hosts. If you change this,
8.697+ then call (make-new-connection-pool).")
8.698+
8.699+(defstruct lru-pool-elt
8.700+ (prev nil :type (or null lru-pool-elt))
8.701+ (next nil :type (or null lru-pool-elt))
8.702+ (elt nil :type t)
8.703+ (key nil :type t)
8.704+ (eviction-callback nil :type (or null function)))
8.705+
8.706+;; An LRU-POOL can have multiple entries for the same key
8.707+(defstruct lru-pool
8.708+ (lock #+sb-thread (sb-thread:make-mutex :name "connection pool lock")
8.709+ #-sb-thread nil)
8.710+ (hash-table nil :type (or null hash-table)) ;; hash table entries are lists of elements
8.711+ (head nil :type (or null lru-pool-elt)) ;; most recently used is here and it's a doubly-linked-list
8.712+ (tail nil :type (or null lru-pool-elt)) ;; least recently used is here
8.713+ (num-elts 0 :type fixnum)
8.714+ (max-elts 8 :type fixnum))
8.715+
8.716+(defun make-connection-pool (&optional (max-active-connections *max-active-connections*))
8.717+ (make-lru-pool :hash-table (make-hash-table :test 'equal) :max-elts max-active-connections))
8.718+
8.719+(defvar *connection-pool* nil)
8.720+
8.721+(defun make-new-connection-pool (&optional (max-active-connections *max-active-connections*))
8.722+ (clear-connection-pool)
8.723+ (setf *connection-pool* (make-connection-pool max-active-connections)))
8.724+
8.725+(defun get-from-lru-pool (lru-pool key)
8.726+ "Takes an element from the LRU-POOL matching KEY. Must be called with LRU-POOL-LOCK held.
8.727+ The element is removed from the pool."
8.728+ (let* ((hash-table (lru-pool-hash-table lru-pool))
8.729+ (possible-elts (gethash key (lru-pool-hash-table lru-pool))))
8.730+ (when possible-elts
8.731+ (let ((remaining-elts (cdr possible-elts)))
8.732+ (if remaining-elts
8.733+ (setf (gethash key hash-table) remaining-elts)
8.734+ (remhash key hash-table)))
8.735+ (let ((elt (car possible-elts)))
8.736+ (let ((prev (lru-pool-elt-prev elt))
8.737+ (next (lru-pool-elt-next elt)))
8.738+ (if prev
8.739+ (setf (lru-pool-elt-next prev) next)
8.740+ (setf (lru-pool-head lru-pool) next))
8.741+ (if next
8.742+ (setf (lru-pool-elt-prev next) prev)
8.743+ (setf (lru-pool-tail lru-pool) prev)))
8.744+ (decf (lru-pool-num-elts lru-pool))
8.745+ (lru-pool-elt-elt elt)))))
8.746+
8.747+(defun evict-tail (lru-pool)
8.748+ "Removes the least recently used element of the LRU-POOL and returns
8.749+ (values evicted-element eviction-callback t) if there was
8.750+ an element to remove, otherwise nil. Must be called with LRU-POOL-LOCK held.
8.751+
8.752+ Outside the LRU-POOL-LOCK you must call the returned EVICTION-CALLBACK with the EVICTED-ELEMENT."
8.753+ ;; slightly different from get-from-lru-pool because we want to get rid of the
8.754+ ;; actual oldest element (one could in principle call get-from-lru-pool on
8.755+ ;; (lru-pool-elt-key (lru-pool-tail lru-pool)) if you didn't care
8.756+ (let* ((tail (lru-pool-tail lru-pool)))
8.757+ (when tail
8.758+ (let ((prev (lru-pool-elt-prev tail)))
8.759+ (if prev
8.760+ (setf (lru-pool-elt-next prev) nil)
8.761+ (setf (lru-pool-head lru-pool) nil))
8.762+ (setf (lru-pool-tail lru-pool) prev)
8.763+ (let* ((hash-table (lru-pool-hash-table lru-pool))
8.764+ (key (lru-pool-elt-key tail))
8.765+ (remaining (cl:delete tail (gethash key hash-table))))
8.766+ (if remaining
8.767+ (setf (gethash key hash-table) remaining)
8.768+ (remhash key hash-table))))
8.769+ (decf (lru-pool-num-elts lru-pool))
8.770+ (values (lru-pool-elt-elt tail) (lru-pool-elt-eviction-callback tail) t))))
8.771+
8.772+(defun add-to-lru-pool (lru-pool key elt eviction-callback)
8.773+ "Adds ELT to an LRU-POOL with potentially non-unique KEY, potentially evicting another element to
8.774+ make room. EVICTION-CALLBACK will be called with one parameter ELT, when ELT is evicted from the
8.775+ LRU-POOL. ADD-TO-LRU-POOL must be called with LRU-POOL-LOCK held.
8.776+
8.777+ If an element was evicted to make space, returns (values evicted-elt eviction-callback t)
8.778+ otherwise nil. The EVICTION-CALLBACK should take one parameter, the evicted element."
8.779+ (declare (type lru-pool lru-pool))
8.780+ (let* ((old-head (lru-pool-head lru-pool))
8.781+ (lru-pool-elt (make-lru-pool-elt :prev nil :next old-head :elt elt :key key :eviction-callback eviction-callback))
8.782+ (hash-table (lru-pool-hash-table lru-pool)))
8.783+ (setf (lru-pool-head lru-pool) lru-pool-elt)
8.784+ (push lru-pool-elt (gethash key hash-table))
8.785+ (when old-head
8.786+ (setf (lru-pool-elt-prev old-head) lru-pool-elt))
8.787+ (unless (lru-pool-tail lru-pool)
8.788+ (setf (lru-pool-tail lru-pool) lru-pool-elt))
8.789+ (when (> (incf (lru-pool-num-elts lru-pool)) (lru-pool-max-elts lru-pool))
8.790+ (evict-tail lru-pool))))
8.791+
8.792+(defmethod print-object ((obj lru-pool-elt) str) ;; avoid printing loops
8.793+ (print-unreadable-object (obj str :type "LRU-POOL-ELT")
8.794+ (format str "~A NEXT ~A" (lru-pool-elt-key obj) (lru-pool-elt-next obj))))
8.795+
8.796+(defmethod print-object ((obj lru-pool) str) ;; avoid printing loops
8.797+ (print-unreadable-object (obj str :type "LRU-POOL")
8.798+ (let (objs)
8.799+ (loop with lru-pool-elt = (lru-pool-head obj)
8.800+ while lru-pool-elt
8.801+ do (push (list (lru-pool-elt-key lru-pool-elt) (lru-pool-elt-elt lru-pool-elt)) objs)
8.802+ do (setf lru-pool-elt (lru-pool-elt-next lru-pool-elt)))
8.803+ (if objs
8.804+ (format str "~A/~A elts~%~{ ~{~A~^: ~}~^~%~}" (lru-pool-num-elts obj) (lru-pool-max-elts obj) objs)
8.805+ (format str "empty")))))
8.806+
8.807+(defmacro with-lock (lock &body body)
8.808+ #+thread-support `(sb-thread:with-mutex (,lock)
8.809+ ,@body)
8.810+ #-thread-support `(progn ,@body))
8.811+
8.812+(defun push-connection (host-port stream &optional eviction-callback)
8.813+ "Add STREAM back to connection pool with key HOST-PORT. EVICTION-CALLBACK
8.814+ must be a function of a single parameter, and will be called with STREAM
8.815+ if the HOST-PORT/SOCKET pair is evicted from the connection pool."
8.816+ (when *use-connection-pool*
8.817+ (let ((pool *connection-pool*))
8.818+ (multiple-value-bind (evicted-elt eviction-callback)
8.819+ (with-lock (lru-pool-lock pool)
8.820+ (add-to-lru-pool pool host-port stream eviction-callback))
8.821+ (and eviction-callback (funcall eviction-callback evicted-elt))
8.822+ (values)))))
8.823+
8.824+(defun steal-connection (host-port)
8.825+ "Return the STREAM associated with key HOST-PORT"
8.826+ (when *use-connection-pool*
8.827+ (let ((pool *connection-pool*))
8.828+ (with-lock (lru-pool-lock pool)
8.829+ (get-from-lru-pool pool host-port)))))
8.830+
8.831+(defun clear-connection-pool ()
8.832+ "Remove all elements from the connection pool, calling their eviction-callbacks."
8.833+ (when *use-connection-pool*
8.834+ (let ((pool *connection-pool*)
8.835+ evicted-element eviction-callback element-was-evicted)
8.836+ (when pool
8.837+ (loop for count from 0
8.838+ do (setf (values evicted-element eviction-callback element-was-evicted)
8.839+ (with-lock (lru-pool-lock pool)
8.840+ (evict-tail pool)))
8.841+ do (when eviction-callback (funcall eviction-callback evicted-element))
8.842+ while element-was-evicted)))))
8.843+
8.844+(make-new-connection-pool)
8.845+
8.846+;;; backend
8.847+(with-compilation-unit ()
8.848+(defparameter *ca-bundle*
8.849+ (uiop:native-namestring #P"/etc/ssl/cacert.pem")
8.850+ "The default public root certificates used in requests.")
8.851+
8.852+
8.853+(defun read-until-crlf*2 (stream)
8.854+ (fast-io:with-fast-output (buf)
8.855+ (tagbody
8.856+ read-cr
8.857+ (loop for byte of-type (or (unsigned-byte 8) null) = (read-byte stream nil nil)
8.858+ if byte
8.859+ do (fast-io:fast-write-byte byte buf)
8.860+ else
8.861+ do (go eof)
8.862+ until (= byte (char-code #\Return)))
8.863+
8.864+ read-lf
8.865+ (let ((next-byte (read-byte stream nil nil)))
8.866+ (unless next-byte
8.867+ (go eof))
8.868+ (locally (declare (type (unsigned-byte 8) next-byte))
8.869+ (cond
8.870+ ((= next-byte (char-code #\Newline))
8.871+ (fast-io:fast-write-byte next-byte buf)
8.872+ (go read-cr2))
8.873+ ((= next-byte (char-code #\Return))
8.874+ (fast-io:fast-write-byte next-byte buf)
8.875+ (go read-lf))
8.876+ (T
8.877+ (fast-io:fast-write-byte next-byte buf)
8.878+ (go read-cr)))))
8.879+
8.880+ read-cr2
8.881+ (let ((next-byte (read-byte stream nil nil)))
8.882+ (unless next-byte
8.883+ (go eof))
8.884+ (locally (declare (type (unsigned-byte 8) next-byte))
8.885+ (cond
8.886+ ((= next-byte (char-code #\Return))
8.887+ (fast-io:fast-write-byte next-byte buf)
8.888+ (go read-lf2))
8.889+ (T
8.890+ (fast-io:fast-write-byte next-byte buf)
8.891+ (go read-cr)))))
8.892+
8.893+ read-lf2
8.894+ (let ((next-byte (read-byte stream nil nil)))
8.895+ (unless next-byte
8.896+ (go eof))
8.897+ (locally (declare (type (unsigned-byte 8) next-byte))
8.898+ (cond
8.899+ ((= next-byte (char-code #\Newline))
8.900+ (fast-io:fast-write-byte next-byte buf))
8.901+ ((= next-byte (char-code #\Return))
8.902+ (fast-io:fast-write-byte next-byte buf)
8.903+ (go read-lf))
8.904+ (T
8.905+ (fast-io:fast-write-byte next-byte buf)
8.906+ (go read-cr)))))
8.907+
8.908+ eof)))
8.909+
8.910+(defvar +empty-body+
8.911+ (make-array 0 :element-type '(unsigned-byte 8)))
8.912+
8.913+(defun read-response (stream has-body collect-headers read-body)
8.914+ (let* ((http (make-http-response))
8.915+ body
8.916+ body-data
8.917+ (headers-data (and collect-headers
8.918+ (fast-io:make-output-buffer)))
8.919+ (header-finished-p nil)
8.920+ (finishedp nil)
8.921+ (content-length nil)
8.922+ (transfer-encoding-p)
8.923+ (parser (make-parser http
8.924+ :header-callback
8.925+ (lambda (headers)
8.926+ (setq header-finished-p t
8.927+ content-length (gethash "content-length" headers)
8.928+ transfer-encoding-p (gethash "transfer-encoding" headers))
8.929+ (unless (and has-body
8.930+ (or content-length
8.931+ transfer-encoding-p))
8.932+ (setq finishedp t)))
8.933+ :body-callback
8.934+ (lambda (data start end)
8.935+ (when body-data
8.936+ (fast-io:fast-write-sequence data body-data start end)))
8.937+ :finish-callback
8.938+ (lambda ()
8.939+ (setq finishedp t)))))
8.940+ (let ((buf (read-until-crlf*2 stream)))
8.941+ (declare (type octet-vector buf))
8.942+ (when collect-headers
8.943+ (fast-io:fast-write-sequence buf headers-data))
8.944+ (funcall parser buf))
8.945+ (unless header-finished-p
8.946+ (error "maybe invalid header"))
8.947+ (cond
8.948+ ((not read-body)
8.949+ (setq body stream))
8.950+ ((not has-body)
8.951+ (setq body +empty-body+))
8.952+ ((and content-length (not transfer-encoding-p))
8.953+ (let ((buf (make-array (etypecase content-length
8.954+ (integer content-length)
8.955+ (string (parse-integer content-length)))
8.956+ :element-type '(unsigned-byte 8))))
8.957+ (read-sequence buf stream)
8.958+ (setq body buf)))
8.959+ ((let ((status (http-status http)))
8.960+ (or (= status 100) ;; Continue
8.961+ (= status 101) ;; Switching Protocols
8.962+ (= status 204) ;; No Content
8.963+ (= status 304))) ;; Not Modified
8.964+ (setq body +empty-body+))
8.965+ (T
8.966+ (setq body-data (fast-io:make-output-buffer))
8.967+ (loop for buf of-type octet-vector = (read-until-crlf*2 stream)
8.968+ do (funcall parser buf)
8.969+ until (or finishedp
8.970+ (zerop (length buf)))
8.971+ finally
8.972+ (setq body (fast-io:finish-output-buffer body-data)))))
8.973+ (values http
8.974+ body
8.975+ (and collect-headers
8.976+ (fast-io:finish-output-buffer headers-data))
8.977+ transfer-encoding-p)))
8.978+
8.979+(defun print-verbose-data (direction &rest data)
8.980+ (flet ((boundary-line ()
8.981+ (let ((char (ecase direction
8.982+ (:incoming #\<)
8.983+ (:outgoing #\>))))
8.984+ (fresh-line)
8.985+ (dotimes (i 50)
8.986+ (write-char char))
8.987+ (fresh-line))))
8.988+ (boundary-line)
8.989+ (dolist (d data)
8.990+ (map nil (lambda (byte)
8.991+ (princ (code-char byte)))
8.992+ d))
8.993+ (boundary-line)))
8.994+
8.995+(defun convert-body (body content-encoding content-type content-length chunkedp force-binary force-string keep-alive-p on-close)
8.996+ (when (streamp body)
8.997+ (cond
8.998+ ((and keep-alive-p chunkedp)
8.999+ (setf body (make-keep-alive-stream body :chunked-stream
8.1000+ (let ((chunked-stream (chunga:make-chunked-stream body)))
8.1001+ (setf (chunga:chunked-stream-input-chunking-p chunked-stream) t)
8.1002+ chunked-stream) :on-close-or-eof on-close)))
8.1003+ ((and keep-alive-p content-length)
8.1004+ (setf body (make-keep-alive-stream body :end content-length :on-close-or-eof on-close)))
8.1005+ (chunkedp
8.1006+ (let ((chunked-stream (chunga:make-chunked-stream body)))
8.1007+ (setf (chunga:chunked-stream-input-chunking-p chunked-stream) t)
8.1008+ (setf body chunked-stream)))))
8.1009+ (let ((body (decompress-body content-encoding body)))
8.1010+ (if force-binary
8.1011+ body
8.1012+ (decode-body content-type body
8.1013+ :default-charset (if force-string
8.1014+ babel:*default-character-encoding*
8.1015+ nil)))))
8.1016+
8.1017+(defun content-disposition (key val)
8.1018+ (if (pathnamep val)
8.1019+ (let* ((filename (file-namestring val))
8.1020+ (utf8-filename-p (find-if (lambda (char)
8.1021+ (< 127 (char-code char)))
8.1022+ filename)))
8.1023+ (format nil "Content-Disposition: form-data; name=\"~A\"; ~:[filename=\"~A\"~;filename*=UTF-8''~A~]~C~C"
8.1024+ key
8.1025+ utf8-filename-p
8.1026+ (if utf8-filename-p
8.1027+ (obj/uri:parse-uri filename)
8.1028+ filename)
8.1029+ #\Return #\Newline))
8.1030+ (format nil "Content-Disposition: form-data; name=\"~A\"~C~C"
8.1031+ key
8.1032+ #\Return #\Newline)))
8.1033+
8.1034+(defun build-cookie-headers (uri cookie-jar)
8.1035+ (with-header-output (buffer)
8.1036+ (let ((cookies (cookie-jar-host-cookies cookie-jar (uri-host uri) (or (uri-path uri) "/")
8.1037+ :securep (string= (uri-scheme uri) "https"))))
8.1038+ (when cookies
8.1039+ (fast-io:fast-write-sequence (string-to-octets "Cookie: ") buffer)
8.1040+ (fast-io:fast-write-sequence
8.1041+ (string-to-octets (write-cookie-header cookies))
8.1042+ buffer)
8.1043+ (fast-io:fast-write-sequence +crlf+ buffer)))))
8.1044+
8.1045+(defun make-connect-stream (uri version stream &optional proxy-auth)
8.1046+ (let ((header (fast-io:with-fast-output (buffer)
8.1047+ (write-connect-header uri version buffer proxy-auth))))
8.1048+ (write-sequence header stream)
8.1049+ (force-output stream)
8.1050+ (read-until-crlf*2 stream)
8.1051+ stream))
8.1052+
8.1053+(defun make-proxy-authorization (uri)
8.1054+ (let ((proxy-auth (quri:uri-userinfo uri)))
8.1055+ (when proxy-auth
8.1056+ (format nil "Basic ~A"
8.1057+ (cl-base64:string-to-base64-string proxy-auth)))))
8.1058+
8.1059+(defconstant +socks5-version+ 5)
8.1060+(defconstant +socks5-reserved+ 0)
8.1061+(defconstant +socks5-no-auth+ 0)
8.1062+(defconstant +socks5-connect+ 1)
8.1063+(defconstant +socks5-domainname+ 3)
8.1064+(defconstant +socks5-succeeded+ 0)
8.1065+(defconstant +socks5-ipv4+ 1)
8.1066+(defconstant +socks5-ipv6+ 4)
8.1067+
8.1068+(defun ensure-socks5-connected (input output uri http-method)
8.1069+ (labels ((fail (condition &key reason)
8.1070+ (error (make-condition condition
8.1071+ :body nil :status nil :headers nil
8.1072+ :uri uri
8.1073+ :method http-method
8.1074+ :reason reason)))
8.1075+ (exact (n reason)
8.1076+ (unless (eql n (read-byte input nil 'eof))
8.1077+ (fail 'socks5-proxy-request-failed :reason reason)))
8.1078+ (drop (n reason)
8.1079+ (dotimes (i n)
8.1080+ (when (eq (read-byte input nil 'eof) 'eof)
8.1081+ (fail 'socks5-proxy-request-failed :reason reason)))))
8.1082+ ;; Send Version + Auth Method
8.1083+ ;; Currently, only supports no-auth method.
8.1084+ (write-byte +socks5-version+ output)
8.1085+ (write-byte 1 output)
8.1086+ (write-byte +socks5-no-auth+ output)
8.1087+ (finish-output output)
8.1088+
8.1089+ ;; Receive Auth Method
8.1090+ (exact +socks5-version+ "Unexpected version")
8.1091+ (exact +socks5-no-auth+ "Unsupported auth method")
8.1092+
8.1093+ ;; Send domainname Request
8.1094+ (let* ((host (babel:string-to-octets (uri-host uri)))
8.1095+ (hostlen (length host))
8.1096+ (port (uri-port uri)))
8.1097+ (unless (<= 1 hostlen 255)
8.1098+ (fail 'socks5-proxy-request-failed :reason "domainname too long"))
8.1099+ (unless (<= 1 port 65535)
8.1100+ (fail 'socks5-proxy-request-failed :reason "Invalid port"))
8.1101+ (write-byte +socks5-version+ output)
8.1102+ (write-byte +socks5-connect+ output)
8.1103+ (write-byte +socks5-reserved+ output)
8.1104+ (write-byte +socks5-domainname+ output)
8.1105+ (write-byte hostlen output)
8.1106+ (write-sequence host output)
8.1107+ (write-byte (ldb (byte 8 8) port) output)
8.1108+ (write-byte (ldb (byte 8 0) port) output)
8.1109+ (finish-output output)
8.1110+
8.1111+ ;; Receive reply
8.1112+ (exact +socks5-version+ "Unexpected version")
8.1113+ (exact +socks5-succeeded+ "Unexpected result code")
8.1114+ (drop 1 "Should be reserved byte")
8.1115+ (let ((atyp (read-byte input nil 'eof)))
8.1116+ (cond
8.1117+ ((eql atyp +socks5-ipv4+)
8.1118+ (drop 6 "Should be IPv4 address and port"))
8.1119+ ((eql atyp +socks5-ipv6+)
8.1120+ (drop 18 "Should be IPv6 address and port"))
8.1121+ ((eql atyp +socks5-domainname+)
8.1122+ (let ((n (read-byte input nil 'eof)))
8.1123+ (when (eq n 'eof)
8.1124+ (fail 'socks5-proxy-request-failed :reason "Invalid domainname length"))
8.1125+ (drop n "Should be domainname and port")))
8.1126+ (t
8.1127+ (fail 'socks5-proxy-request-failed :reason "Unknown address")))))))
8.1128+
8.1129+(defun make-ssl-stream (stream ca-path ssl-key-file ssl-cert-file ssl-key-password hostname insecure)
8.1130+ #+(not ssl) (declare (ignore stream ca-path ssl-key-file ssl-cert-file ssl-key-password hostname insecure))
8.1131+ #+(not ssl) (error "SSL not supported. Remove :dexador-no-ssl from *features* to enable SSL.")
8.1132+ #+ssl
8.1133+ (progn
8.1134+ (cl+ssl:ensure-initialized)
8.1135+ (let ((ctx (cl+ssl:make-context :verify-mode
8.1136+ (if insecure
8.1137+ cl+ssl:+ssl-verify-none+
8.1138+ cl+ssl:+ssl-verify-peer+)
8.1139+ :verify-location
8.1140+ ;; TODO 2024-05-22:
8.1141+ (cond
8.1142+ (ca-path (uiop:native-namestring ca-path))
8.1143+ ((probe-file *ca-bundle*) *ca-bundle*)
8.1144+ ;; In executable environment, perhaps *ca-bundle* doesn't exist.
8.1145+ (t :default))))
8.1146+ (ssl-cert-pem-p (and ssl-cert-file
8.1147+ (std/seq:ends-with-subseq ".pem" ssl-cert-file))))
8.1148+ (cl+ssl:with-global-context (ctx :auto-free-p t)
8.1149+ (when ssl-cert-pem-p
8.1150+ (cl+ssl:use-certificate-chain-file ssl-cert-file))
8.1151+ (cl+ssl:make-ssl-client-stream stream
8.1152+ :hostname hostname
8.1153+ :verify (not insecure)
8.1154+ :key ssl-key-file
8.1155+ :certificate (and (not ssl-cert-pem-p)
8.1156+ ssl-cert-file)
8.1157+ :password ssl-key-password)))))
8.1158+
8.1159+(defstruct usocket-wrapped-stream
8.1160+ stream)
8.1161+
8.1162+;; Forward methods the user might want to use on this.
8.1163+;; User is not meant to interact with this object except
8.1164+;; potentially to close it when they decide they don't
8.1165+;; need the :keep-alive connection anymore.
8.1166+(defmethod close ((u usocket-wrapped-stream) &key abort)
8.1167+ (close (usocket-wrapped-stream-stream u) :abort abort))
8.1168+
8.1169+(defmethod open-stream-p ((u usocket-wrapped-stream))
8.1170+ (open-stream-p (usocket-wrapped-stream-stream u)))
8.1171+
8.1172+(defun request (uri &rest args
8.1173+ &key (method :get) (version 1.1)
8.1174+ content headers
8.1175+ basic-auth bearer-auth
8.1176+ cookie-jar
8.1177+ (connect-timeout *default-connect-timeout*) (read-timeout *default-read-timeout*)
8.1178+ (keep-alive t) (use-connection-pool t)
8.1179+ (max-redirects 5)
8.1180+ ssl-key-file ssl-cert-file ssl-key-password
8.1181+ stream (verbose *verbose*)
8.1182+ force-binary
8.1183+ force-string
8.1184+ want-stream
8.1185+ (proxy *default-proxy*)
8.1186+ (insecure *no-ssl*)
8.1187+ ca-path
8.1188+ &aux
8.1189+ (proxy-uri (and proxy (quri:uri proxy)))
8.1190+ (original-user-supplied-stream stream)
8.1191+ (user-supplied-stream (if (usocket-wrapped-stream-p stream) (usocket-wrapped-stream-stream stream) stream)))
8.1192+ (declare (ignorable ssl-key-file ssl-cert-file ssl-key-password
8.1193+ connect-timeout)
8.1194+ (type real version)
8.1195+ (type fixnum max-redirects))
8.1196+ (with-content-caches
8.1197+ (labels ((make-new-connection (uri)
8.1198+ (restart-case
8.1199+ (let* ((con-uri (uri (or proxy uri)))
8.1200+ (connection (usocket:socket-connect (uri-host con-uri)
8.1201+ (or (uri-port con-uri) 80)
8.1202+ #-(or ecl clasp clisp allegro) :timeout #-(or ecl clasp clisp allegro) connect-timeout
8.1203+ :element-type '(unsigned-byte 8)))
8.1204+ (stream
8.1205+ (usocket:socket-stream connection))
8.1206+ (scheme (uri-scheme uri)))
8.1207+ (declare (type keyword scheme))
8.1208+ (when read-timeout
8.1209+ #+lispworks(setf (stream:stream-read-timeout stream) read-timeout)
8.1210+ #-lispworks(setf (usocket:socket-option connection :receive-timeout) read-timeout))
8.1211+ (when (socks5-proxy-p proxy-uri)
8.1212+ (ensure-socks5-connected stream stream uri method))
8.1213+ (if (string= (symbol-name scheme) "https")
8.1214+ (make-ssl-stream (if (http-proxy-p proxy-uri)
8.1215+ (make-connect-stream uri version stream (make-proxy-authorization con-uri))
8.1216+ stream) ca-path ssl-key-file ssl-cert-file ssl-key-password (uri-host uri) insecure)
8.1217+ stream))
8.1218+ (retry-request ()
8.1219+ :report "Retry the same request."
8.1220+ (return-from request
8.1221+ (apply #'request uri :use-connection-pool nil args)))
8.1222+ (retry-insecure ()
8.1223+ :report "Retry the same request without checking for SSL certificate validity."
8.1224+ (return-from request
8.1225+ (apply #'request uri :use-connection-pool nil :insecure t args)))))
8.1226+ (http-proxy-p (uri)
8.1227+ (and uri
8.1228+ (let ((scheme (uri-scheme uri)))
8.1229+ (and (stringp scheme)
8.1230+ (or (string= scheme "http")
8.1231+ (string= scheme "https"))))))
8.1232+ (socks5-proxy-p (uri)
8.1233+ (and uri
8.1234+ (let ((scheme (uri-scheme uri)))
8.1235+ (and (stringp scheme)
8.1236+ (string= scheme "socks5")))))
8.1237+ (connection-keep-alive-p (connection-header)
8.1238+ (and keep-alive
8.1239+ (or (and (= (the real version) 1.0)
8.1240+ (equalp connection-header "keep-alive"))
8.1241+ (not (equalp connection-header "close")))))
8.1242+ (return-stream-to-pool (stream uri)
8.1243+ (push-connection (format nil "~A://~A"
8.1244+ (uri-scheme uri)
8.1245+ (uri-authority uri)) stream #'close))
8.1246+ (return-stream-to-pool-or-close (stream connection-header uri)
8.1247+ (if (and (not user-supplied-stream) use-connection-pool (connection-keep-alive-p connection-header))
8.1248+ (return-stream-to-pool stream uri)
8.1249+ (when (open-stream-p stream)
8.1250+ (close stream))))
8.1251+ (finalize-connection (stream connection-header uri)
8.1252+ "If KEEP-ALIVE is in the connection-header and the user is not requesting a stream,
8.1253+ we will push the connection to our connection pool if allowed, otherwise we return
8.1254+ the stream back to the user who must close it."
8.1255+ (unless want-stream
8.1256+ (cond
8.1257+ ((and use-connection-pool (connection-keep-alive-p connection-header) (not user-supplied-stream))
8.1258+ (return-stream-to-pool stream uri))
8.1259+ ((not (connection-keep-alive-p connection-header))
8.1260+ (when (open-stream-p stream)
8.1261+ (close stream)))))))
8.1262+ (let* ((uri (uri uri))
8.1263+ (proxy (when (http-proxy-p proxy-uri) proxy))
8.1264+ (content-type (cdr (find :content-type headers :key #'car :test #'string-equal)))
8.1265+ (multipart-p (or (and content-type
8.1266+ (>= (length content-type) 10)
8.1267+ (string= content-type "multipart/" :end1 10))
8.1268+ (and (not content-type)
8.1269+ (consp content)
8.1270+ (find-if #'pathnamep content :key #'cdr))))
8.1271+ (form-urlencoded-p (or (string= content-type "application/x-www-form-urlencoded")
8.1272+ (and (not content-type)
8.1273+ (consp content)
8.1274+ (not multipart-p))))
8.1275+ (boundary (and multipart-p
8.1276+ (make-random-string 12)))
8.1277+ (content (if (and form-urlencoded-p (not (stringp content))) ;; user can provide already encoded content, trust them.
8.1278+ (quri:url-encode-params content)
8.1279+ content))
8.1280+ (stream (or user-supplied-stream
8.1281+ (and use-connection-pool
8.1282+ (steal-connection (format nil "~A://~A"
8.1283+ (uri-scheme uri)
8.1284+ (uri-authority uri))))))
8.1285+ (reusing-stream-p (not (null stream))) ;; user provided or from connection-pool
8.1286+ (stream (or stream
8.1287+ (make-new-connection uri)))
8.1288+ (content-length
8.1289+ (assoc :content-length headers :test #'string-equal))
8.1290+ (transfer-encoding
8.1291+ (assoc :transfer-encoding headers :test #'string-equal))
8.1292+ (chunkedp (or (and transfer-encoding
8.1293+ (equalp (cdr transfer-encoding) "chunked"))
8.1294+ (and content-length
8.1295+ (null (cdr content-length)))))
8.1296+ (first-line-data
8.1297+ (fast-io:with-fast-output (buffer)
8.1298+ (write-first-line method uri version buffer)))
8.1299+ (headers-data
8.1300+ (flet ((write-header* (name value)
8.1301+ (let ((header (assoc name headers :test #'string-equal)))
8.1302+ (if header
8.1303+ (when (cdr header)
8.1304+ (write-header name (cdr header)))
8.1305+ (write-header name value)))
8.1306+ (values)))
8.1307+ (with-header-output (buffer)
8.1308+ (write-header* :user-agent #.*default-user-agent*)
8.1309+ (write-header* :host (uri-authority uri))
8.1310+ (write-header* :accept "*/*")
8.1311+ (cond
8.1312+ ((and keep-alive
8.1313+ (= (the real version) 1.0))
8.1314+ (write-header* :connection "keep-alive"))
8.1315+ ((and (not keep-alive)
8.1316+ (= (the real version) 1.1))
8.1317+ (write-header* :connection "close")))
8.1318+ (cond ((and bearer-auth basic-auth)
8.1319+ (error "You should only use one Authorization header."))
8.1320+ (basic-auth
8.1321+ (write-header* :authorization
8.1322+ (format nil "Basic ~A"
8.1323+ (dat/base64::string-to-base64-string
8.1324+ (format nil "~A:~A"
8.1325+ (car basic-auth)
8.1326+ (cdr basic-auth))))))
8.1327+ (bearer-auth
8.1328+ (write-header* :authorization
8.1329+ (format nil "Bearer ~A" bearer-auth))))
8.1330+ (when proxy
8.1331+ (let ((scheme (uri-scheme uri)))
8.1332+ (when (string= scheme "http")
8.1333+ (let* ((uri (uri proxy))
8.1334+ (proxy-authorization (make-proxy-authorization uri)))
8.1335+ (when proxy-authorization
8.1336+ (write-header* :proxy-authorization proxy-authorization))))))
8.1337+ (cond
8.1338+ (multipart-p
8.1339+ (write-header :content-type (format nil "~A; boundary=~A"
8.1340+ (or content-type "multipart/form-data")
8.1341+ boundary))
8.1342+ (unless chunkedp
8.1343+ (write-header :content-length
8.1344+ (multipart-content-length content boundary))))
8.1345+ (form-urlencoded-p
8.1346+ (write-header* :content-type "application/x-www-form-urlencoded")
8.1347+ (unless chunkedp
8.1348+ (write-header* :content-length (length (the string content)))))
8.1349+ (t
8.1350+ (etypecase content
8.1351+ (null
8.1352+ (unless chunkedp
8.1353+ (write-header* :content-length 0)))
8.1354+ (string
8.1355+ (write-header* :content-type (or content-type "text/plain"))
8.1356+ (unless chunkedp
8.1357+ (write-header* :content-length (content-length content))))
8.1358+ ((array (unsigned-byte 8) *)
8.1359+ (write-header* :content-type (or content-type "text/plain"))
8.1360+ (unless chunkedp
8.1361+ (write-header* :content-length (length content))))
8.1362+ (pathname
8.1363+ (write-header* :content-type (or content-type (content-type content)))
8.1364+ (unless chunkedp
8.1365+ (write-header :content-length
8.1366+ (or (cdr (assoc :content-length headers :test #'string-equal))
8.1367+ (content-length content))))))))
8.1368+ ;; Transfer-Encoding: chunked
8.1369+ (when (and chunkedp
8.1370+ (not transfer-encoding))
8.1371+ (write-header* :transfer-encoding "chunked"))
8.1372+
8.1373+ ;; Custom headers
8.1374+ (loop for (name . value) in headers
8.1375+ unless (member name '(:user-agent :host :accept
8.1376+ :connection
8.1377+ :content-type :content-length) :test #'string-equal)
8.1378+ do (write-header name value)))))
8.1379+ (cookie-headers (and cookie-jar
8.1380+ (build-cookie-headers uri cookie-jar))))
8.1381+ (macrolet ((maybe-try-again-without-reusing-stream (&optional (force nil))
8.1382+ `(progn ;; retrying by go retry avoids generating the header, parsing, etc.
8.1383+ (when (open-stream-p stream)
8.1384+ (close stream :abort t)
8.1385+ (setf stream nil))
8.1386+
8.1387+ (when ,(or force 'reusing-stream-p)
8.1388+ (setf reusing-stream-p nil
8.1389+ user-supplied-stream nil
8.1390+ stream (make-new-connection uri))
8.1391+ (go retry))))
8.1392+ (try-again-without-reusing-stream ()
8.1393+ `(maybe-try-again-without-reusing-stream t))
8.1394+ (with-retrying (&body body)
8.1395+ `(restart-case
8.1396+ (handler-bind (((and error
8.1397+ ;; We should not retry errors received from the server.
8.1398+ ;; Only technical errors such as disconnection or some
8.1399+ ;; problems with the protocol should be retried automatically.
8.1400+ ;; This solves https://github.com/fukamachi/dexador/issues/137 issue.
8.1401+ (not http-request-failed))
8.1402+ (lambda (e)
8.1403+ (declare (ignorable e))
8.1404+ (maybe-try-again-without-reusing-stream))))
8.1405+ ,@body)
8.1406+ (retry-request () :report "Retry the same request."
8.1407+ (return-from request (apply #'request uri args)))
8.1408+ (ignore-and-continue () :report "Ignore the error and continue."))))
8.1409+ (tagbody
8.1410+ retry
8.1411+
8.1412+ (unless (open-stream-p stream)
8.1413+ (try-again-without-reusing-stream))
8.1414+
8.1415+ (with-retrying
8.1416+ (write-sequence first-line-data stream)
8.1417+ (write-sequence headers-data stream)
8.1418+ (when cookie-headers
8.1419+ (write-sequence cookie-headers stream))
8.1420+ (write-sequence +crlf+ stream)
8.1421+ (force-output stream))
8.1422+
8.1423+ ;; Sending the content
8.1424+ (when content
8.1425+ (let ((stream (if chunkedp
8.1426+ (chunga:make-chunked-stream stream)
8.1427+ stream)))
8.1428+ (when chunkedp
8.1429+ (setf (chunga:chunked-stream-output-chunking-p stream) t))
8.1430+ (with-retrying
8.1431+ (if (consp content)
8.1432+ (write-multipart-content content boundary stream)
8.1433+ (write-as-octets stream content))
8.1434+ (when chunkedp
8.1435+ (setf (chunga:chunked-stream-output-chunking-p stream) nil))
8.1436+ (finish-output stream))))
8.1437+
8.1438+ start-reading
8.1439+ (multiple-value-bind (http body response-headers-data transfer-encoding-p)
8.1440+ (with-retrying
8.1441+ (read-response stream (not (eq method :head)) verbose (not want-stream)))
8.1442+ (let* ((status (http-status http))
8.1443+ (response-headers (http-headers http))
8.1444+ (content-length (gethash "content-length" response-headers))
8.1445+ (content-length (etypecase content-length
8.1446+ (null content-length)
8.1447+ (string (parse-integer content-length))
8.1448+ (integer content-length))))
8.1449+ (when (= status 0)
8.1450+ (with-retrying
8.1451+ (http-request-failed status
8.1452+ :body body
8.1453+ :headers headers
8.1454+ :uri uri
8.1455+ :method method)))
8.1456+ (when verbose
8.1457+ (print-verbose-data :outgoing first-line-data headers-data cookie-headers +crlf+)
8.1458+ (print-verbose-data :incoming response-headers-data))
8.1459+ (when cookie-jar
8.1460+ (when-let ((set-cookies (append (gethash "set-cookie" response-headers)
8.1461+ (ensure-list (gethash "set-cookie2" response-headers)))))
8.1462+ (net/cookie::merge-cookies cookie-jar
8.1463+ (remove nil (mapcar (lambda (cookie)
8.1464+ (declare (type string cookie))
8.1465+ (unless (= (length cookie) 0)
8.1466+ (net/cookie:parse-set-cookie-header cookie
8.1467+ (uri-host uri)
8.1468+ (uri-path uri))))
8.1469+ set-cookies)))))
8.1470+ (when (and (member status '(301 302 303 307 308) :test #'=)
8.1471+ (gethash "location" response-headers)
8.1472+ (/= max-redirects 0))
8.1473+ ;; Need to read the response body
8.1474+ (when (and want-stream
8.1475+ (not (eq method :head)))
8.1476+ (cond
8.1477+ ((integerp content-length)
8.1478+ (dotimes (i content-length)
8.1479+ (loop until (read-byte body nil nil))))
8.1480+ (transfer-encoding-p
8.1481+ (read-until-crlf*2 body))))
8.1482+
8.1483+ (let* ((location-uri (uri (gethash "location" response-headers)))
8.1484+ (same-server-p (or (null (uri-host location-uri))
8.1485+ (and (string= (uri-scheme location-uri)
8.1486+ (uri-scheme uri))
8.1487+ (string= (uri-host location-uri)
8.1488+ (uri-host uri))
8.1489+ (eql (uri-port location-uri)
8.1490+ (uri-port uri))))))
8.1491+ (if (and same-server-p
8.1492+ (or (= status 307) (= status 308)
8.1493+ (member method '(:get :head) :test #'eq)))
8.1494+ (progn ;; redirection to the same host
8.1495+ (setq uri (merge-uris location-uri uri))
8.1496+ (setq first-line-data
8.1497+ (fast-io:with-fast-output (buffer)
8.1498+ (write-first-line method uri version buffer)))
8.1499+ (when cookie-jar
8.1500+ ;; Rebuild cookie-headers.
8.1501+ (setq cookie-headers (build-cookie-headers uri cookie-jar)))
8.1502+ (decf max-redirects)
8.1503+ (if (equalp (gethash "connection" response-headers) "close")
8.1504+ (try-again-without-reusing-stream)
8.1505+ (progn
8.1506+ (setq reusing-stream-p t)
8.1507+ (go retry))))
8.1508+ (progn ;; this is a redirection to a different host
8.1509+ (setf location-uri (merge-uris location-uri uri))
8.1510+ ;; Close connection if it isn't from our connection pool or from the user and we aren't going to
8.1511+ ;; pass it to our new call.
8.1512+ (when (not same-server-p) (return-stream-to-pool-or-close stream (gethash "connection" response-headers) uri))
8.1513+ (setf (getf args :headers)
8.1514+ (nconc `((:host . ,(uri-host location-uri))) headers))
8.1515+ (setf (getf args :max-redirects)
8.1516+ (1- max-redirects))
8.1517+ ;; Redirect as GET if it's 301, 302, 303
8.1518+ (unless (or (= status 307) (= status 308)
8.1519+ (member method '(:get :head) :test #'eq))
8.1520+ (setf (getf args :method) :get))
8.1521+ (return-from request
8.1522+ (apply #'request location-uri (if same-server-p
8.1523+ args
8.1524+ (progn (remf args :stream) args))))))))
8.1525+ (unwind-protect
8.1526+ (let* ((keep-connection-alive (connection-keep-alive-p
8.1527+ (gethash "connection" response-headers)))
8.1528+ (body (convert-body body
8.1529+ (gethash "content-encoding" response-headers)
8.1530+ (gethash "content-type" response-headers)
8.1531+ content-length
8.1532+ transfer-encoding-p
8.1533+ force-binary
8.1534+ force-string
8.1535+ keep-connection-alive
8.1536+ (if (and use-connection-pool keep-connection-alive (not user-supplied-stream) (streamp body))
8.1537+ (lambda (underlying-stream abort)
8.1538+ (declare (ignore abort))
8.1539+ (when (and underlying-stream (open-stream-p underlying-stream))
8.1540+ ;; read any left overs the user may have not read (in case of errors on user side?)
8.1541+ (loop while (ignore-errors (listen underlying-stream)) ;; ssl streams may close
8.1542+ do (read-byte underlying-stream nil nil))
8.1543+ (when (open-stream-p underlying-stream)
8.1544+ (push-connection (format nil "~A://~A"
8.1545+ (uri-scheme uri)
8.1546+ (uri-authority uri)) underlying-stream #'close))))
8.1547+ #'keep-alive-stream-close-underlying-stream))))
8.1548+ ;; Raise an error when the HTTP response status code is 4xx or 50x.
8.1549+ (when (<= 400 status)
8.1550+ (with-retrying
8.1551+ (http-request-failed status
8.1552+ :body body
8.1553+ :headers response-headers
8.1554+ :uri uri
8.1555+ :method method)))
8.1556+ ;; Have to be a little careful with the fifth value stream we return --
8.1557+ ;; the user may be not aware that keep-alive t without use-connection-pool can leak
8.1558+ ;; sockets, so we wrap the returned last value so when it is garbage
8.1559+ ;; collected it gets closed. If the user is getting a stream back as BODY,
8.1560+ ;; then we instead add a finalizer to that stream to close it when garbage collected
8.1561+ (return-from request
8.1562+ (values body
8.1563+ status
8.1564+ response-headers
8.1565+ uri
8.1566+ (when (and keep-alive
8.1567+ (not (equalp (gethash "connection" response-headers) "close"))
8.1568+ (or (not use-connection-pool) user-supplied-stream))
8.1569+ (or (and original-user-supplied-stream ;; user provided a stream
8.1570+ (if (usocket-wrapped-stream-p original-user-supplied-stream) ;; but, it came from us
8.1571+ (eql (usocket-wrapped-stream-stream original-user-supplied-stream) stream) ;; and we used it
8.1572+ (eql original-user-supplied-stream stream)) ;; user provided a bare stream
8.1573+ original-user-supplied-stream) ;; return what the user sent without wrapping it
8.1574+ (if want-stream ;; add a finalizer to the body to close the stream
8.1575+ (progn
8.1576+ (trivial-garbage:finalize body (lambda () (close stream)))
8.1577+ stream)
8.1578+ (let ((wrapped-stream (make-usocket-wrapped-stream :stream stream)))
8.1579+ (trivial-garbage:finalize wrapped-stream (lambda () (close stream)))
8.1580+ wrapped-stream)))))))
8.1581+ (finalize-connection stream (gethash "connection" response-headers) uri)))))))))))
8.1582+
8.1583+;;; API
8.1584+(defun get (uri &rest args
8.1585+ &key version headers basic-auth bearer-auth cookie-jar keep-alive use-connection-pool
8.1586+ connect-timeout read-timeout max-redirects
8.1587+ force-binary force-string want-stream content
8.1588+ ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path)
8.1589+ "Make a GET request to URI and return
8.1590+ (values body-or-stream status response-headers uri &optional opaque-socket-stream)
8.1591+
8.1592+ You may pass a real stream in as STREAM if you want us to communicate with the server via it --
8.1593+ though if any errors occur, we will open a new connection to the server. If you have a previous
8.1594+ OPAQUE-SOCKET-STREAM you can pass that in as STREAM as well and we will re-use that connection.
8.1595+
8.1596+ OPAQUE-SOCKET-STREAM is not returned if USE-CONNECTION-POOL is T, instead we keep track of it and
8.1597+ re-use it when needed.
8.1598+
8.1599+ If WANT-STREAM is T, then a STREAM is returned as the first value. You may read this as needed to
8.1600+ get the body of the response. If KEEP-ALIVE and USE-CONNECTION-POOL are T, then the stream will be
8.1601+ returned to the connection pool when you have read all the data or closed the stream. If KEEP-ALIVE
8.1602+ is NIL then you are responsible for closing the stream when done.
8.1603+
8.1604+ If KEEP-ALIVE is T and USE-CONNECTION-POOL is NIL, then the fifth value returned is a stream which
8.1605+ you can then pass in again using the STREAM option to re-use the active connection. If you ignore
8.1606+ the stream, it will get closed during garbage collection.
8.1607+
8.1608+ If KEEP-ALIVE is T and USE-CONNECTION-POOL is T, then there is no fifth
8.1609+ value (OPAQUE-SOCKET-STREAM) returned, but the active connection to the host/port may be reused in
8.1610+ subsequent calls. This removes the need for the caller to keep track of the active socket-stream
8.1611+ for subsequent calls.
8.1612+
8.1613+ While CONTENT is allowed in a GET request the results are ill-defined and not advised."
8.1614+ (declare (ignore version headers basic-auth bearer-auth cookie-jar keep-alive use-connection-pool
8.1615+ connect-timeout read-timeout max-redirects force-binary force-string want-stream
8.1616+ ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path content))
8.1617+ (apply #'request uri :method :get args))
8.1618+
8.1619+(defun post (uri &rest args
8.1620+ &key version content headers basic-auth bearer-auth cookie-jar keep-alive
8.1621+ use-connection-pool connect-timeout read-timeout
8.1622+ force-binary force-string want-stream
8.1623+ ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path)
8.1624+ (declare (ignore version content headers basic-auth bearer-auth cookie-jar keep-alive
8.1625+ use-connection-pool connect-timeout read-timeout force-binary force-string
8.1626+ want-stream ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy
8.1627+ insecure ca-path))
8.1628+ (apply #'request uri :method :post args))
8.1629+
8.1630+(defun head (uri &rest args
8.1631+ &key version headers basic-auth bearer-auth cookie-jar connect-timeout read-timeout max-redirects
8.1632+ ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path)
8.1633+ (declare (ignore version headers basic-auth bearer-auth cookie-jar connect-timeout read-timeout
8.1634+ max-redirects ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path))
8.1635+ (apply #'request uri :method :head :use-connection-pool nil args))
8.1636+
8.1637+(defun put (uri &rest args
8.1638+ &key version content headers basic-auth bearer-auth cookie-jar keep-alive
8.1639+ use-connection-pool connect-timeout read-timeout
8.1640+ force-binary force-string want-stream
8.1641+ ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path)
8.1642+ (declare (ignore version content headers basic-auth bearer-auth cookie-jar keep-alive
8.1643+ use-connection-pool connect-timeout read-timeout force-binary force-string
8.1644+ want-stream ssl-key-file ssl-cert-file ssl-key-password stream verbose
8.1645+ proxy insecure ca-path))
8.1646+ (apply #'request uri :method :put args))
8.1647+
8.1648+(defun patch (uri &rest args
8.1649+ &key version content headers basic-auth bearer-auth cookie-jar keep-alive
8.1650+ use-connection-pool connect-timeout read-timeout
8.1651+ force-binary force-string want-stream
8.1652+ ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path)
8.1653+ (declare (ignore version content headers basic-auth bearer-auth cookie-jar keep-alive
8.1654+ use-connection-pool connect-timeout read-timeout force-binary force-string
8.1655+ want-stream ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy
8.1656+ insecure ca-path))
8.1657+ (apply #'request uri :method :patch args))
8.1658+
8.1659+(defun delete (uri &rest args
8.1660+ &key version headers basic-auth bearer-auth cookie-jar keep-alive
8.1661+ use-connection-pool connect-timeout read-timeout
8.1662+ force-binary force-string want-stream content
8.1663+ ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path)
8.1664+ (declare (ignore version headers basic-auth bearer-auth cookie-jar keep-alive use-connection-pool
8.1665+ connect-timeout read-timeout force-binary force-string want-stream ssl-key-file
8.1666+ ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path content))
8.1667+ (apply #'request uri :method :delete args))
8.1668+
8.1669+(defun fetch (uri destination &rest args
8.1670+ &key (if-exists :error)
8.1671+ version headers basic-auth bearer-auth cookie-jar keep-alive use-connection-pool
8.1672+ connect-timeout read-timeout max-redirects
8.1673+ ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path)
8.1674+ (declare (ignore version headers basic-auth bearer-auth cookie-jar keep-alive use-connection-pool
8.1675+ connect-timeout read-timeout max-redirects ssl-key-file ssl-cert-file
8.1676+ ssl-key-password stream verbose proxy insecure ca-path))
8.1677+ (unless (and (eql if-exists nil)
8.1678+ (probe-file destination))
8.1679+ (with-open-file (out destination
8.1680+ :direction :output :element-type '(unsigned-byte 8)
8.1681+ :if-exists if-exists
8.1682+ :if-does-not-exist :create)
8.1683+ (remf args :if-exists)
8.1684+ (let ((body (apply #'dex:get uri :want-stream t :force-binary t
8.1685+ args)))
8.1686+ (alexandria:copy-stream body out)
8.1687+ ;; Nominally the body gets closed, but if keep-alive is nil we need to explicitly do it.
8.1688+ (when (open-stream-p body)
8.1689+ (close body))))))
8.1690+
8.1691+(defun ignore-and-continue (e)
8.1692+ (let ((restart (find-restart 'ignore-and-continue e)))
8.1693+ (when restart
8.1694+ (invoke-restart restart))))
8.1695+
8.1696+(defun retry-request (times &key (interval 3))
8.1697+ (declare (type (or function integer) interval))
8.1698+ (etypecase times
8.1699+ (condition
8.1700+ (let ((restart (find-restart 'retry-request times)))
8.1701+ (when restart
8.1702+ (invoke-restart restart))))
8.1703+ (integer
8.1704+ (retry-request-ntimes times :interval interval))))
8.1705+
8.1706+(defun retry-request-ntimes (n &key (interval 3))
8.1707+ (declare (type integer n)
8.1708+ (type (or function integer) interval))
8.1709+ (let ((retries 0))
8.1710+ (declare (type integer retries))
8.1711+ (lambda (e)
8.1712+ (declare (type condition e))
8.1713+ (let ((restart (find-restart 'retry-request e)))
8.1714+ (when restart
8.1715+ (when (< retries n)
8.1716+ (incf retries)
8.1717+ (etypecase interval
8.1718+ (function (funcall interval retries))
8.1719+ (integer (sleep interval)))
8.1720+ (invoke-restart restart)))))))
9.1--- a/lisp/lib/obj/pkg.lisp Wed May 22 18:19:23 2024 -0400
9.2+++ b/lisp/lib/obj/pkg.lisp Wed May 22 22:16:26 2024 -0400
9.3@@ -118,7 +118,15 @@
9.4 :unintern-uri
9.5 :do-all-uris
9.6 :uri-to-pathname
9.7- :pathname-to-uri))
9.8+ :pathname-to-uri
9.9+ ;; domains
9.10+ :parse-domain
9.11+ :ipv4-addr-p
9.12+ :ipv6-addr-p
9.13+ :ip-addr-p
9.14+ :ip-addr=
9.15+ :uri-tld
9.16+ :uri-domain))
9.17
9.18 (defpackage :obj/url
9.19 (:nicknames :url)
10.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
10.2+++ b/lisp/lib/obj/uri/domain.lisp Wed May 22 22:16:26 2024 -0400
10.3@@ -0,0 +1,239 @@
10.4+;;; obj/uri/domain.lisp --- URI Domains
10.5+
10.6+;;
10.7+
10.8+;;; Code:
10.9+(in-package :obj/uri)
10.10+
10.11+(defun next-subdomain (hostname &optional (start 0))
10.12+ (let ((pos (position #\. hostname :start start)))
10.13+ (when pos
10.14+ (incf pos)
10.15+ (values (subseq hostname pos)
10.16+ pos))))
10.17+
10.18+(defun make-subdomain-iter (hostname)
10.19+ (let ((current-pos 0)
10.20+ (first t))
10.21+ (lambda ()
10.22+ (block nil
10.23+ (when first
10.24+ (setq first nil)
10.25+ (return hostname))
10.26+ (multiple-value-bind (subdomain pos)
10.27+ (next-subdomain hostname current-pos)
10.28+ (when subdomain
10.29+ (setf current-pos pos)
10.30+ subdomain))))))
10.31+
10.32+(defvar *etlds* nil)
10.33+
10.34+(defun parse-domain (hostname)
10.35+ (dolist (tld (third *etlds*))
10.36+ (when (ends-with-subseq tld hostname)
10.37+ (if (= (length tld) (length hostname))
10.38+ (return-from parse-domain hostname)
10.39+ (when (char= (aref hostname (- (length hostname) (length tld) 1))
10.40+ #\.)
10.41+ (return-from parse-domain
10.42+ (subseq hostname
10.43+ (- (length hostname) (length tld))))))))
10.44+ (loop with iter = (make-subdomain-iter hostname)
10.45+ with pre-prev-subdomain = nil
10.46+ with prev-subdomain = nil
10.47+ for subdomain = (funcall iter)
10.48+ while subdomain
10.49+ if (gethash subdomain (second *etlds*)) do
10.50+ (return pre-prev-subdomain)
10.51+ else if (gethash subdomain (first *etlds*)) do
10.52+ (return (if (string= subdomain hostname)
10.53+ nil
10.54+ prev-subdomain))
10.55+ do (setf pre-prev-subdomain prev-subdomain
10.56+ prev-subdomain subdomain)
10.57+ finally
10.58+ (let* ((pos (position #\. hostname :from-end t))
10.59+ (pos (and pos
10.60+ (position #\. hostname :from-end t :end pos))))
10.61+ (return
10.62+ (if pos
10.63+ (subseq hostname (1+ pos))
10.64+ hostname)))))
10.65+
10.66+(defun uri-tld (uri)
10.67+ (let ((host (uri-host uri)))
10.68+ (when (and host
10.69+ (not (ip-addr-p host)))
10.70+ (let ((pos (position #\. host :from-end t)))
10.71+ (if pos
10.72+ (subseq host (1+ pos))
10.73+ host)))))
10.74+
10.75+(defun uri-domain (uri)
10.76+ (let ((host (uri-host uri)))
10.77+ (when (and host
10.78+ (not (ip-addr-p host)))
10.79+ (parse-domain host))))
10.80+
10.81+(defun ipv4-addr-p (host)
10.82+ (declare (optimize (speed 3) (safety 2))
10.83+ #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
10.84+ (check-type host string)
10.85+ (flet ((read-byte-string (string start)
10.86+ (declare (type fixnum start))
10.87+ (when (<= (length string) start)
10.88+ (return-from read-byte-string nil))
10.89+ (let* ((end (+ start 2))
10.90+ (endp (<= (1- (length string)) end))
10.91+ (end (if endp
10.92+ (1- (length string))
10.93+ end))
10.94+ (res 0))
10.95+ (declare (type fixnum end res))
10.96+ (do ((i start (1+ i)))
10.97+ ((< end i))
10.98+ (declare (type fixnum i))
10.99+ (unless (char<= #\0 (aref string i) #\9)
10.100+ (return-from read-byte-string
10.101+ (if (= i start)
10.102+ nil
10.103+ (values res i nil))))
10.104+ (setq res
10.105+ (+ (* res 10)
10.106+ (- (char-code (aref string i)) 48))))
10.107+ (cond
10.108+ (endp
10.109+ (values res end t))
10.110+ ((char= (aref string (1+ end)) #\.)
10.111+ (values res (1+ end) nil))))))
10.112+ (let ((start 0))
10.113+ (dotimes (i 4 t)
10.114+ (multiple-value-bind (byte pos endp)
10.115+ (read-byte-string host start)
10.116+ (unless (typep byte '(unsigned-byte 8))
10.117+ (return nil))
10.118+ (unless (xor endp (not (= i 3)))
10.119+ (return nil))
10.120+ (setq start (1+ pos)))))))
10.121+
10.122+(defun trim-brackets (host)
10.123+ (if (char= (aref host 0) #\[)
10.124+ (if (char= (aref host (1- (length host))) #\])
10.125+ (subseq host 1 (1- (length host)))
10.126+ nil)
10.127+ host))
10.128+
10.129+(defun ipv6-addr-p (host)
10.130+ (declare (optimize (speed 3) (safety 2))
10.131+ #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
10.132+ (check-type host string)
10.133+ (when (= (length host) 0)
10.134+ (return-from ipv6-addr-p nil))
10.135+
10.136+ (labels ((read-section (string start &optional read-colons)
10.137+ (declare (type string string)
10.138+ (type fixnum start))
10.139+ (when (<= (length string) start)
10.140+ (return-from read-section
10.141+ (values start read-colons t)))
10.142+ (when (char= (aref string start) #\:)
10.143+ (cond
10.144+ ((<= (length string) (1+ start))
10.145+ (return-from read-section nil))
10.146+ ((char= (aref string (1+ start)) #\:)
10.147+ (if read-colons
10.148+ (return-from read-section nil)
10.149+ (return-from read-section (read-section string (+ 2 start) t))))
10.150+ (t (incf start))))
10.151+ (let* ((end (+ start 4))
10.152+ (endp (<= (length string) end))
10.153+ (end (if endp
10.154+ (length string)
10.155+ end)))
10.156+ (declare (type fixnum end))
10.157+
10.158+ (do ((i start (1+ i)))
10.159+ ((= end i))
10.160+ (let ((ch (aref string i)))
10.161+ (cond
10.162+ ((char= ch #\:)
10.163+ (return-from read-section
10.164+ (values i read-colons nil)))
10.165+ ((or (char<= #\0 ch #\9)
10.166+ (char<= #\a ch #\f)
10.167+ (char<= #\A ch #\F)))
10.168+ (t (return-from read-section nil)))))
10.169+
10.170+ (if endp
10.171+ (values end read-colons endp)
10.172+ (if (char= (aref string end) #\:)
10.173+ (values end read-colons endp)
10.174+ nil)))))
10.175+
10.176+ (setq host (trim-brackets host))
10.177+ (unless host
10.178+ (return-from ipv6-addr-p nil))
10.179+
10.180+ (let ((start 0)
10.181+ (read-colons-p nil))
10.182+ (dotimes (i 8 t)
10.183+ (multiple-value-bind (e read-colons endp)
10.184+ (read-section host start read-colons-p)
10.185+ (unless e
10.186+ (return-from ipv6-addr-p nil))
10.187+ (when endp
10.188+ (when (and (not (= i 7))
10.189+ (not read-colons))
10.190+ (return-from ipv6-addr-p nil))
10.191+ (return-from ipv6-addr-p t))
10.192+ (when (and (= i 7) (not endp))
10.193+ (return-from ipv6-addr-p nil))
10.194+ (setq start e
10.195+ read-colons-p read-colons))))))
10.196+
10.197+(defun ip-addr-p (host)
10.198+ (or (ipv4-addr-p host)
10.199+ (ipv6-addr-p host)))
10.200+
10.201+(defun ip-addr= (ip1 ip2)
10.202+ (flet ((parse-ipv6 (ip)
10.203+ (setq ip (trim-brackets ip))
10.204+ (cond
10.205+ ((char= (aref ip 0) #\:)
10.206+ (setq ip (concatenate 'string "0" ip)))
10.207+ ((char= (aref ip (1- (length ip))) #\:)
10.208+ (setq ip (concatenate 'string ip "0"))))
10.209+ (let* ((ip-parsed (split-sequence #\: ip))
10.210+ (len (length ip-parsed)))
10.211+ (loop for section in ip-parsed
10.212+ if (string= section "")
10.213+ append (make-list (- 9 len) :initial-element 0)
10.214+ else
10.215+ collect (parse-integer section :radix 16)))))
10.216+ (cond
10.217+ ((ipv4-addr-p ip1)
10.218+ (string= ip1 ip2))
10.219+ ((ipv6-addr-p ip1)
10.220+ (and (ipv6-addr-p ip2)
10.221+ (equal (parse-ipv6 ip1)
10.222+ (parse-ipv6 ip2)))))))
10.223+
10.224+(defun cookie-domain-p (domain cookie-domain)
10.225+ (unless cookie-domain
10.226+ (return-from cookie-domain-p t))
10.227+ (if (ip-addr-p domain)
10.228+ (ip-addr= domain cookie-domain)
10.229+ (progn
10.230+ ;; ignore the preceding "."
10.231+ (when (char= (aref cookie-domain 0) #\.)
10.232+ (setq cookie-domain (subseq cookie-domain 1)))
10.233+ (when-let ((registered-domain (parse-domain domain)))
10.234+ (cond
10.235+ ((= (length registered-domain) (length cookie-domain))
10.236+ (string= registered-domain cookie-domain))
10.237+ ((= (length domain) (length cookie-domain))
10.238+ (string= domain cookie-domain))
10.239+ (t (and (ends-with-subseq domain cookie-domain)
10.240+ (char= #\.
10.241+ (aref cookie-domain (- (length cookie-domain)
10.242+ (length registered-domain)))))))))))
11.1--- a/lisp/lib/pod/util.lisp Wed May 22 18:19:23 2024 -0400
11.2+++ b/lisp/lib/pod/util.lisp Wed May 22 22:16:26 2024 -0400
11.3@@ -21,7 +21,7 @@
11.4 :output t
11.5 :buffering :none)))
11.6 ;; TODO 2024-04-01: remove dependencies
11.7- (let ((wrapped-stream (flexi-streams:make-flexi-stream (dex.usocket::make-chunked-stream stream)
11.8+ (let ((wrapped-stream (flexi-streams:make-flexi-stream (chunga::make-chunked-stream stream)
11.9 :external-format :utf8)))
11.10 (dex:request (format-libpod-api-local path) :method method :stream wrapped-stream))))
11.11
12.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
12.2+++ b/lisp/std/macs/control.lisp Wed May 22 22:16:26 2024 -0400
12.3@@ -0,0 +1,26 @@
12.4+;;; std/macs/control.lisp --- Control Flow Macros
12.5+
12.6+;;
12.7+
12.8+;;; Code:
12.9+(in-package :std/macs)
12.10+
12.11+(defmacro xor (&rest datums)
12.12+ "Evaluates its arguments one at a time, from left to right. If more than one
12.13+argument evaluates to a true value no further DATUMS are evaluated, and NIL is
12.14+returned as both primary and secondary value. If exactly one argument
12.15+evaluates to true, its value is returned as the primary value after all the
12.16+arguments have been evaluated, and T is returned as the secondary value. If no
12.17+arguments evaluate to true NIL is returned as primary, and T as secondary
12.18+value."
12.19+ (with-gensyms (xor tmp true)
12.20+ `(let (,tmp ,true)
12.21+ (declare (ignorable ,tmp))
12.22+ (block ,xor
12.23+ ,@(mapcar (lambda (datum)
12.24+ `(if (setf ,tmp ,datum)
12.25+ (if ,true
12.26+ (return-from ,xor (values nil nil))
12.27+ (setf ,true ,tmp))))
12.28+ datums)
12.29+ (return-from ,xor (values ,true t))))))
13.1--- a/lisp/std/pkg.lisp Wed May 22 18:19:23 2024 -0400
13.2+++ b/lisp/std/pkg.lisp Wed May 22 22:16:26 2024 -0400
13.3@@ -262,7 +262,8 @@
13.4 :plambda
13.5 :pandoric-eval
13.6 :with-collectors
13.7- :collecting))
13.8+ :collecting
13.9+ :xor))
13.10
13.11 (defpkg :std/readtable
13.12 (:use :cl)
13.13@@ -379,7 +380,8 @@
13.14 (:use :cl)
13.15 (:import-from :sb-int :collect)
13.16 (:import-from :std/array :signed-array-length)
13.17- (:export :take))
13.18+ (:export :take :starts-with-subseq :ends-with-subseq
13.19+ :split-sequence :split-sequence-if :split-sequence-if-not))
13.20
13.21 (defpkg :std/sys
13.22 (:use :cl)
14.1--- a/lisp/std/seq.lisp Wed May 22 18:19:23 2024 -0400
14.2+++ b/lisp/std/seq.lisp Wed May 22 22:16:26 2024 -0400
14.3@@ -22,3 +22,214 @@
14.4 (if (minusp n)
14.5 (subseq seq (max 0 (+ (length seq) n)))
14.6 (subseq seq 0 (min n (length seq))))))
14.7+
14.8+(defun starts-with-subseq (prefix sequence &rest args
14.9+ &key
14.10+ return-suffix
14.11+ &allow-other-keys)
14.12+ "Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX.
14.13+
14.14+If RETURN-SUFFIX is T the function returns, as a second value, a
14.15+sub-sequence or displaced array pointing to the sequence after PREFIX."
14.16+ (declare (dynamic-extent args))
14.17+ (let ((sequence-length (length sequence))
14.18+ (prefix-length (length prefix)))
14.19+ (when (< sequence-length prefix-length)
14.20+ (return-from starts-with-subseq (values nil nil)))
14.21+ (flet ((make-suffix (start)
14.22+ (when return-suffix
14.23+ (cond
14.24+ ((not (arrayp sequence))
14.25+ (if start
14.26+ (subseq sequence start)
14.27+ (subseq sequence 0 0)))
14.28+ ((not start)
14.29+ (make-array 0
14.30+ :element-type (array-element-type sequence)
14.31+ :adjustable nil))
14.32+ (t
14.33+ (make-array (- sequence-length start)
14.34+ :element-type (array-element-type sequence)
14.35+ :displaced-to sequence
14.36+ :displaced-index-offset start
14.37+ :adjustable nil))))))
14.38+ (remf args :return-suffix)
14.39+ (let ((mismatch (apply #'mismatch prefix sequence
14.40+ args)))
14.41+ (cond
14.42+ ((not mismatch)
14.43+ (values t (make-suffix nil)))
14.44+ ((= mismatch prefix-length)
14.45+ (values t (make-suffix mismatch)))
14.46+ (t
14.47+ (values nil nil)))))))
14.48+
14.49+(defun ends-with-subseq (suffix sequence &key (test #'eql))
14.50+ "Test whether SEQUENCE ends with SUFFIX. In other words: return true if
14.51+the last (length SUFFIX) elements of SEQUENCE are equal to SUFFIX."
14.52+ (let ((sequence-length (length sequence))
14.53+ (suffix-length (length suffix)))
14.54+ (when (< sequence-length suffix-length)
14.55+ ;; if SEQUENCE is shorter than SUFFIX, then SEQUENCE can't end with SUFFIX.
14.56+ (return-from ends-with-subseq nil))
14.57+ (loop for sequence-index from (- sequence-length suffix-length) below sequence-length
14.58+ for suffix-index from 0 below suffix-length
14.59+ when (not (funcall test (elt sequence sequence-index) (elt suffix suffix-index)))
14.60+ do (return-from ends-with-subseq nil)
14.61+ finally (return t))))
14.62+
14.63+(defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied))
14.64+ "Return a list of subsequences in seq delimited by delimiter.
14.65+
14.66+If :remove-empty-subseqs is NIL, empty subsequences will be included
14.67+in the result; otherwise they will be discarded. All other keywords
14.68+work analogously to those for CL:SUBSTITUTE. In particular, the
14.69+behaviour of :from-end is possibly different from other versions of
14.70+this function; :from-end values of NIL and T are equivalent unless
14.71+:count is supplied. The second return value is an index suitable as an
14.72+argument to CL:SUBSEQ into the sequence indicating where processing
14.73+stopped."
14.74+ (let ((len (length seq))
14.75+ (other-keys (nconc (when test-supplied
14.76+ (list :test test))
14.77+ (when test-not-supplied
14.78+ (list :test-not test-not))
14.79+ (when key-supplied
14.80+ (list :key key)))))
14.81+ (unless end (setq end len))
14.82+ (if from-end
14.83+ (loop for right = end then left
14.84+ for left = (max (or (apply #'position delimiter seq
14.85+ :end right
14.86+ :from-end t
14.87+ other-keys)
14.88+ -1)
14.89+ (1- start))
14.90+ unless (and (= right (1+ left))
14.91+ remove-empty-subseqs) ; empty subseq we don't want
14.92+ if (and count (>= nr-elts count))
14.93+ ;; We can't take any more. Return now.
14.94+ return (values (nreverse subseqs) right)
14.95+ else
14.96+ collect (subseq seq (1+ left) right) into subseqs
14.97+ and sum 1 into nr-elts
14.98+ until (< left start)
14.99+ finally (return (values (nreverse subseqs) (1+ left))))
14.100+ (loop for left = start then (+ right 1)
14.101+ for right = (min (or (apply #'position delimiter seq
14.102+ :start left
14.103+ other-keys)
14.104+ len)
14.105+ end)
14.106+ unless (and (= right left)
14.107+ remove-empty-subseqs) ; empty subseq we don't want
14.108+ if (and count (>= nr-elts count))
14.109+ ;; We can't take any more. Return now.
14.110+ return (values subseqs left)
14.111+ else
14.112+ collect (subseq seq left right) into subseqs
14.113+ and sum 1 into nr-elts
14.114+ until (>= right end)
14.115+ finally (return (values subseqs right))))))
14.116+
14.117+(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
14.118+ "Return a list of subsequences in seq delimited by items satisfying
14.119+predicate.
14.120+
14.121+If :remove-empty-subseqs is NIL, empty subsequences will be included
14.122+in the result; otherwise they will be discarded. All other keywords
14.123+work analogously to those for CL:SUBSTITUTE-IF. In particular, the
14.124+behaviour of :from-end is possibly different from other versions of
14.125+this function; :from-end values of NIL and T are equivalent unless
14.126+:count is supplied. The second return value is an index suitable as an
14.127+argument to CL:SUBSEQ into the sequence indicating where processing
14.128+stopped."
14.129+ (let ((len (length seq))
14.130+ (other-keys (when key-supplied
14.131+ (list :key key))))
14.132+ (unless end (setq end len))
14.133+ (if from-end
14.134+ (loop for right = end then left
14.135+ for left = (max (or (apply #'position-if predicate seq
14.136+ :end right
14.137+ :from-end t
14.138+ other-keys)
14.139+ -1)
14.140+ (1- start))
14.141+ unless (and (= right (1+ left))
14.142+ remove-empty-subseqs) ; empty subseq we don't want
14.143+ if (and count (>= nr-elts count))
14.144+ ;; We can't take any more. Return now.
14.145+ return (values (nreverse subseqs) right)
14.146+ else
14.147+ collect (subseq seq (1+ left) right) into subseqs
14.148+ and sum 1 into nr-elts
14.149+ until (< left start)
14.150+ finally (return (values (nreverse subseqs) (1+ left))))
14.151+ (loop for left = start then (+ right 1)
14.152+ for right = (min (or (apply #'position-if predicate seq
14.153+ :start left
14.154+ other-keys)
14.155+ len)
14.156+ end)
14.157+ unless (and (= right left)
14.158+ remove-empty-subseqs) ; empty subseq we don't want
14.159+ if (and count (>= nr-elts count))
14.160+ ;; We can't take any more. Return now.
14.161+ return (values subseqs left)
14.162+ else
14.163+ collect (subseq seq left right) into subseqs
14.164+ and sum 1 into nr-elts
14.165+ until (>= right end)
14.166+ finally (return (values subseqs right))))))
14.167+
14.168+(defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
14.169+ "Return a list of subsequences in seq delimited by items satisfying
14.170+(CL:COMPLEMENT predicate).
14.171+
14.172+If :remove-empty-subseqs is NIL, empty subsequences will be included
14.173+in the result; otherwise they will be discarded. All other keywords
14.174+work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular,
14.175+the behaviour of :from-end is possibly different from other versions
14.176+of this function; :from-end values of NIL and T are equivalent unless
14.177+:count is supplied. The second return value is an index suitable as an
14.178+argument to CL:SUBSEQ into the sequence indicating where processing
14.179+stopped." ; Emacs syntax highlighting is broken, and this helps: "
14.180+ (let ((len (length seq))
14.181+ (other-keys (when key-supplied
14.182+ (list :key key))))
14.183+ (unless end (setq end len))
14.184+ (if from-end
14.185+ (loop for right = end then left
14.186+ for left = (max (or (apply #'position-if-not predicate seq
14.187+ :end right
14.188+ :from-end t
14.189+ other-keys)
14.190+ -1)
14.191+ (1- start))
14.192+ unless (and (= right (1+ left))
14.193+ remove-empty-subseqs) ; empty subseq we don't want
14.194+ if (and count (>= nr-elts count))
14.195+ ;; We can't take any more. Return now.
14.196+ return (values (nreverse subseqs) right)
14.197+ else
14.198+ collect (subseq seq (1+ left) right) into subseqs
14.199+ and sum 1 into nr-elts
14.200+ until (< left start)
14.201+ finally (return (values (nreverse subseqs) (1+ left))))
14.202+ (loop for left = start then (+ right 1)
14.203+ for right = (min (or (apply #'position-if-not predicate seq
14.204+ :start left
14.205+ other-keys)
14.206+ len)
14.207+ end)
14.208+ unless (and (= right left)
14.209+ remove-empty-subseqs) ; empty subseq we don't want
14.210+ if (and count (>= nr-elts count))
14.211+ ;; We can't take any more. Return now.
14.212+ return (values subseqs left)
14.213+ else
14.214+ collect (subseq seq left right) into subseqs
14.215+ and sum 1 into nr-elts
14.216+ until (>= right end)
14.217+ finally (return (values subseqs right))))))
15.1--- a/lisp/std/std.asd Wed May 22 18:19:23 2024 -0400
15.2+++ b/lisp/std/std.asd Wed May 22 22:16:26 2024 -0400
15.3@@ -37,7 +37,8 @@
15.4 ((:file "ana")
15.5 (:file "pan")
15.6 (:file "const")
15.7- (:file "collecting")))
15.8+ (:file "collecting")
15.9+ (:file "control")))
15.10 (:file "bit")
15.11 (:file "fmt")
15.12 (:file "path")
