Mercurial > core / lisp/lib/net/req.lisp
changeset 698: |
96958d3eb5b0 |
parent: |
f6a340b92274
|
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Fri, 04 Oct 2024 22:04:59 -0400 |
permissions: |
-rw-r--r-- |
description: |
fixes |
1 ;;; net/req.lisp --- HTTP Request API 3 ;; based on Fukamachi's DEXADOR 9 (define-condition http-request-failed (error) 11 :reader response-body) 12 (status :initarg :status 13 :reader response-status) 14 (headers :initarg :headers 15 :reader response-headers) 18 (method :initarg :method 19 :reader request-method)) 20 (:report (lambda (condition stream) 21 (with-slots (uri status) condition 22 (format stream "An HTTP request to ~S has failed (status=~D)." 26 (defmacro define-request-failed-condition (name code) 27 `(define-condition ,(intern (format nil "~A-~A" :http-request name)) (http-request-failed) 29 (:report (lambda (condition stream) 30 (with-slots (body uri) condition 31 (format stream ,(format nil "An HTTP request to ~~S returned ~D ~A.~~2%~~A" 33 (substitute #\Space #\- (string-downcase name))) 38 (defvar *request-failed-error* (make-hash-table :test 'eql)) 41 ,@(loop for (name . code) in '(;; 4xx (Client Errors) 44 (payment-required . 402) 47 (method-not-allowed . 405) 48 (not-acceptable . 406) 49 (proxy-authentication-required . 407) 50 (request-timeout . 408) 53 (length-required . 411) 54 (precondition-failed . 412) 55 (payload-too-large . 413) 57 (unsupported-media-type . 415) 58 (range-not-satisfiable . 416) 59 (expectation-failed . 417) 60 (misdirected-request . 421) 61 (upgrade-required . 426) 62 (too-many-requests . 429) 64 ;; 5xx (Server Errors) 65 (internal-server-error . 500) 66 (not-implemented . 501) 68 (service-unavailable . 503) 69 (gateway-timeout . 504) 70 (http-version-not-supported . 505)) 71 collect `(define-request-failed-condition ,name ,code) 72 collect `(setf (gethash ,code *request-failed-error*) 73 ',(intern (format nil "~A-~A" :http-request name))))) 75 (defun http-request-failed (status &key body headers uri method) 78 (gethash status *request-failed-error* 'http-request-failed) 85 (define-condition socks5-proxy-request-failed (http-request-failed) 86 ((reason :initarg :reason)) 87 (:report (lambda (condition stream) 88 (with-slots (uri reason) condition 89 (format stream "An HTTP request to ~S via SOCKS5 has failed (reason=~S)." 94 (defvar *default-connect-timeout* 10) 95 (defvar *default-read-timeout* 10) 96 (defvar *verbose* nil) 99 (defvar *default-proxy* (or #-windows (uiop:getenv "HTTPS_PROXY") 100 #-windows (uiop:getenv "HTTP_PROXY")) 101 "If specified will be used as the default value of PROXY in calls to dexador. Defaults to 102 the value of the environment variable HTTPS_PROXY or HTTP_PROXY if not on Windows.") 104 (define-constant +crlf+ (string-to-octets (format nil "~C~C" #\Return #\Newline)) :test 'equalp) 107 (defparameter *default-user-agent* 108 (format nil "cc/req (~A~@[ ~A~]); ~A;~@[ ~A~]" 109 (lisp-implementation-type) 110 (lisp-implementation-version) 112 (software-version)))) 114 (defparameter *header-buffer* nil) 116 (defun write-first-line (method uri version &optional (buffer *header-buffer*)) 117 (fast-write-sequence (string-to-octets (string method)) buffer) 118 (fast-write-byte #.(char-code #\Space) buffer) 119 (fast-write-sequence (string-to-octets 120 (format nil "~A~:[~;~:*?~A~]" 121 (or (uri-path uri) "/") 124 (fast-write-byte #.(char-code #\Space) buffer) 125 (fast-write-sequence (ecase version 126 (1.1 (string-to-octets "HTTP/1.1")) 127 (1.0 (string-to-octets "HTTP/1.0"))) 129 (fast-write-sequence +crlf+ buffer)) 131 (defun write-header-field (name buffer) 132 (fast-write-sequence (if (typep name 'octet-vector) 134 (string-to-octets (string-capitalize name))) 137 (defun write-header-value (value buffer) 138 (fast-write-sequence (if (typep value 'octet-vector) 140 (string-to-octets (princ-to-string value))) 143 (defun write-header (name value &optional (buffer *header-buffer*)) 144 (write-header-field name buffer) 145 (fast-write-sequence (string-to-octets ": ") buffer) 146 (write-header-value value buffer) 147 (fast-write-sequence +crlf+ buffer)) 149 (define-compiler-macro write-header (name value &optional (buffer '*header-buffer*)) 151 ,(if (and (constantp name) 152 (typep name '(or keyword string))) 153 `(fast-write-sequence (string-to-octets ,(string-capitalize name)) ,buffer) 154 `(write-header-field ,name ,buffer)) 155 (fast-write-sequence (string-to-octets ": ") ,buffer) 156 ,(if (constantp value) 157 `(fast-write-sequence (string-to-octets ,(string value)) ,buffer) 158 `(write-header-value ,value ,buffer)) 159 (fast-write-sequence +crlf+ ,buffer))) 161 (defmacro with-header-output ((buffer &optional output) &body body) 162 `(fast-io:with-fast-output (,buffer ,output) 163 (declare (ignorable ,buffer)) 164 (let ((*header-buffer* ,buffer)) 167 (defun write-connect-header (uri version buffer &optional proxy-auth) 168 (fast-write-sequence (string-to-octets "CONNECT") buffer) 169 (fast-write-byte #.(char-code #\Space) buffer) 170 (fast-write-sequence (string-to-octets (format nil "~A:~A" 174 (fast-write-byte #.(char-code #\Space) buffer) 175 (fast-write-sequence (ecase version 176 (1.1 (string-to-octets "HTTP/1.1")) 177 (1.0 (string-to-octets "HTTP/1.0"))) 179 (fast-write-sequence +crlf+ buffer) 180 (fast-write-sequence (string-to-octets "Host:") buffer) 181 (fast-write-byte #.(char-code #\Space) buffer) 182 (fast-write-sequence (string-to-octets (format nil "~A:~A" 187 (fast-write-sequence +crlf+ buffer) 188 (fast-write-sequence (string-to-octets "Proxy-Authorization:") buffer) 189 (fast-write-byte #.(char-code #\Space) buffer) 190 (fast-write-sequence (string-to-octets proxy-auth) buffer)) 191 (fast-write-sequence +crlf+ buffer) 192 (fast-write-sequence +crlf+ buffer)) 194 (defun make-random-string (&optional (length 12)) 195 (declare (type fixnum length)) 196 (let ((result (make-string length))) 197 (declare (type simple-string result)) 198 (dotimes (i length result) 199 (setf (aref result i) 201 ((0 1) (code-char (+ #.(char-code #\a) (random 26)))) 202 ((2 3) (code-char (+ #.(char-code #\A) (random 26)))) 203 ((4) (code-char (+ #.(char-code #\0) (random 10))))))))) 206 (defun parse-content-type (content-type) 209 (ppcre:scan-to-strings "^\\s*?(\\w+)/([^;\\s]+)(?:\\s*;\\s*charset=([A-Za-z0-9_-]+))?" 212 (values (aref types 0) 216 (defun charset-to-encoding (charset &optional 217 (default sb-ext:*default-external-format*)) 221 ((string-equal charset "utf-8") 223 ((string-equal charset "euc-jp") 225 ((or (string-equal charset "shift_jis") 226 (string-equal charset "shift-jis")) 228 ((string-equal charset "windows-31j") 230 (t (or (when (sb-impl::get-external-format (keywordicate charset)) charset) 233 (defun detect-charset (content-type body) 234 (multiple-value-bind (type subtype charset) 235 (parse-content-type content-type) 237 ((charset-to-encoding charset nil)) 238 ((string-equal type "text") 239 (or (charset-to-encoding charset nil) 240 (if (and (string-equal subtype "html") 241 (typep body '(array (unsigned-byte 8) (*)))) 242 (charset-to-encoding (detect-charset-from-html body) nil) 245 ((and (string-equal type "application") 246 (or (string-equal subtype "json") 247 (string-equal subtype "javascript"))) 248 ;; According to RFC4627 (http://www.ietf.org/rfc/rfc4627.txt), 249 ;; JSON text SHALL be encoded in Unicode. The default encoding is UTF-8. 250 ;; It's possible to determine if the encoding is UTF-16 or UTF-36 251 ;; by looking at the first four octets, however, I leave it to the future. 253 ;; According to RFC4329 (https://datatracker.ietf.org/doc/html/rfc4329), 254 ;; javascript also is specified by charset, or defaults to UTF-8 255 ;; It's also possible to specify in the first four octets, but 256 ;; like application/json I leave it to the future. 257 (charset-to-encoding charset :utf-8)) 258 ((and (string-equal type "application") 259 (ppcre:scan "(?:[^+]+\\+)?xml" subtype)) 260 (charset-to-encoding charset))))) 262 (defun detect-charset-from-html (body) 263 "Detect the body's charset by (roughly) searching meta tags which has \"charset\" attribute." 264 (labels ((find-meta (start) 265 (search #.(string-to-octets "<meta ") body :start2 start)) 267 (let ((start (find-meta start))) 269 (return-from main nil)) 270 (let ((end (position (char-code #\>) body :start start :test #'=))) 272 (return-from main nil)) 274 (let ((match (nth-value 1 (ppcre:scan-to-strings 275 "charset=[\"']?([^\\s\"'>]+)[\"']?" 276 (octets-to-string body :start start :end end))))) 282 ;;; keep-alive-stream 283 (defclass keep-alive-stream (fundamental-input-stream) 284 ((stream :type (or null stream) 286 :initform (error ":stream is required") 287 :accessor keep-alive-stream-stream 288 :documentation "A stream; when we read END elements from it, we call CLOSE-ACTION on it and 289 set this slot to nil.") 292 :accessor keep-alive-stream-end) 293 (close-action :initarg :on-close-or-eof :reader close-action 294 :documentation "A (lambda (stream abort)) which will be called with keep-alive-stream-stream 295 when the stream is either closed or we hit end of file or we hit end"))) 297 (defun keep-alive-stream-close-underlying-stream (underlying-stream abort) 298 (when (and underlying-stream (open-stream-p underlying-stream)) 299 (close underlying-stream :abort abort))) 301 (defclass keep-alive-chunked-stream (keep-alive-stream) 302 ((chunga-stream :initarg :chunga-stream :accessor chunga-stream))) 304 (defun make-keep-alive-stream (stream &key end chunked-stream (on-close-or-eof #'keep-alive-stream-close-underlying-stream)) 305 "ON-CLOSE-OR-EOF takes a single parameter, STREAM (the stream passed in here, not the 306 keep-alive-stream), and should handle clean-up of it" 307 (assert (xor end chunked-stream)) 309 (make-instance 'keep-alive-chunked-stream :stream stream :chunga-stream chunked-stream :on-close-or-eof on-close-or-eof) 310 (make-instance 'keep-alive-stream :stream stream :end end :on-close-or-eof on-close-or-eof))) 312 (defun maybe-close (stream &optional close-if) 313 "Will close the underlying stream if close-if is T (unless it is already closed). 314 If the stream is already closed or we closed it returns :EOF otherwise NIL." 315 (let ((underlying-stream (keep-alive-stream-stream stream))) 317 ((not underlying-stream) 320 (funcall (close-action stream) underlying-stream nil) 321 (setf (keep-alive-stream-stream stream) nil) 325 (defmethod stream-read-byte ((stream keep-alive-stream)) 326 "Return :EOF or byte read. When we hit EOF or finish reading our allowed content, 327 call the close-action on our underlying-stream and return EOF." 329 (underlying-stream (keep-alive-stream-stream stream))) 330 (or (maybe-close stream (<= (keep-alive-stream-end stream) 0)) 332 (setf byte (read-byte underlying-stream nil :eof)) 333 (decf (keep-alive-stream-end stream) 1) 334 (maybe-close stream (or (<= (keep-alive-stream-end stream) 0) (eql byte :eof))) 337 (defmethod stream-read-byte ((stream keep-alive-chunked-stream)) 338 "Return :EOF or byte read. When we hit :EOF or finish reading our chunk, 339 call the close-action on our underlying-stream and return :EOF" 340 (or (maybe-close stream) 341 (if (chunga:chunked-stream-input-chunking-p (chunga-stream stream)) 342 (let ((byte (read-byte (chunga-stream stream) nil :eof))) 346 (maybe-close stream t)) 348 (or (maybe-close stream t) :eof)))) 350 (defmethod stream-read-sequence ((stream keep-alive-stream) sequence &optional start end) 351 (declare (optimize speed)) 352 (let ((%end (or end 0)) 353 (%start (or start 0))) 354 (if (null (keep-alive-stream-stream stream)) ;; we already closed it 356 (let* ((to-read (min (- %end %start) (keep-alive-stream-end stream))) 357 (n (read-sequence sequence (keep-alive-stream-stream stream) 359 :end (+ %start to-read)))) 360 (decf (keep-alive-stream-end stream) (- n %start)) 361 (maybe-close stream (<= (keep-alive-stream-end stream) 0)) 364 (defmethod stream-read-sequence ((stream keep-alive-chunked-stream) sequence &optional start end) 365 (declare (optimize speed)) 366 (if (null (keep-alive-stream-stream stream)) ;; we already closed it 368 (if (chunga:chunked-stream-input-chunking-p (chunga-stream stream)) 370 (let ((num-read (read-sequence sequence (chunga-stream stream) :start start :end end))) 372 (maybe-close stream (not (chunga:chunked-stream-input-chunking-p (chunga-stream stream))))) 375 (defmethod stream-element-type ((stream keep-alive-chunked-stream)) 376 (stream-element-type (chunga-stream stream))) 378 (defmethod stream-element-type ((stream keep-alive-stream)) 381 (defmethod open-stream-p ((stream keep-alive-stream)) 382 (let ((underlying-stream (keep-alive-stream-stream stream))) 383 (and underlying-stream (open-stream-p underlying-stream)))) 385 (defmethod close ((stream keep-alive-stream) &key abort) 386 (funcall (close-action stream) (keep-alive-stream-stream stream) abort) 387 (setf (keep-alive-stream-stream stream) nil)) 390 (declaim (type fixnum +buffer-size+)) 391 (eval-always (defconstant +buffer-size+ 128)) 393 (defclass decoding-stream (fundamental-character-input-stream) 394 ((stream :type stream 396 :initform (error ":stream is required") 397 :accessor decoding-stream-stream) 398 (encoding :initarg :encoding 399 :initform (error ":encoding is required") 400 :accessor decoding-stream-encoding) 401 (buffer :type (simple-array (unsigned-byte 8) (#.+buffer-size+)) 402 :initform (make-array +buffer-size+ :element-type '(unsigned-byte 8)) 403 :accessor decoding-stream-buffer) 404 (buffer-position :type fixnum 405 :initform +buffer-size+ 406 :accessor decoding-stream-buffer-position) 407 (buffer-end-position :type fixnum 409 :accessor decoding-stream-buffer-end-position) 410 (last-char :type character 412 :accessor decoding-stream-last-char) 413 (last-char-size :type fixnum 415 :accessor decoding-stream-last-char-size) 416 (on-close :type (or null function) :initform nil :initarg :on-close))) 418 (defmethod initialize-instance :after ((stream decoding-stream) &rest initargs) 419 (declare (ignore initargs)) 420 (with-slots (encoding) stream 421 (when (keywordp encoding) 422 (setf encoding (babel-encodings:get-character-encoding encoding))))) 424 (defun make-decoding-stream (stream &key (encoding babel-encodings:*default-character-encoding*) 426 (let ((decoding-stream (make-instance 'decoding-stream 429 :on-close on-close))) 430 (fill-buffer decoding-stream) 433 (defun fill-buffer (stream) 434 (declare (optimize speed)) 435 (with-slots (stream buffer buffer-position buffer-end-position) stream 436 (declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+)) buffer) 437 (type fixnum buffer-position)) 438 (let ((to-read (- +buffer-size+ buffer-position))) 439 (declare (type fixnum to-read)) 440 (replace buffer buffer 442 :start2 buffer-position 444 (setf buffer-position 0) 445 (let ((n (read-sequence buffer stream :start to-read))) 446 (declare (type fixnum n)) 447 (unless (= n +buffer-size+) 448 (setf buffer-end-position n)))))) 450 (defun needs-to-fill-buffer-p (stream) 451 (declare (optimize speed)) 452 (when (/= -1 (the fixnum (decoding-stream-buffer-end-position stream))) 453 (return-from needs-to-fill-buffer-p nil)) 455 (with-slots (buffer-position encoding) stream 456 (< (- +buffer-size+ (the fixnum buffer-position)) 457 (the fixnum (babel-encodings:enc-max-units-per-char encoding))))) 460 (defmethod stream-read-char ((stream decoding-stream)) 461 (declare (optimize speed)) 462 (when (needs-to-fill-buffer-p stream) 463 (fill-buffer stream)) 465 (when (= (the fixnum (decoding-stream-buffer-end-position stream)) 466 (the fixnum (decoding-stream-buffer-position stream))) 467 (return-from stream-read-char :eof)) 469 (with-slots (buffer buffer-position encoding last-char last-char-size) 471 (declare (fixnum buffer-position)) 472 (let* ((mapping (babel-encodings:lookup-mapping babel::*string-vector-mappings* encoding)) 473 (counter (babel-encodings:code-point-counter mapping))) 474 (declare (type function counter)) 475 (multiple-value-bind (chars new-end) 476 (funcall counter buffer buffer-position +buffer-size+ 1) 477 (declare (ignore chars) (fixnum new-end)) 478 (let ((string (make-string 1 :element-type 'babel:unicode-char)) 479 (size (the fixnum (- new-end buffer-position)))) 480 (funcall (the function (babel-encodings:decoder mapping)) 481 buffer buffer-position new-end string 0) 482 (setf buffer-position new-end 483 last-char (aref string 0) 487 (defmethod stream-unread-char ((stream decoding-stream) char) 488 (let ((last-char (decoding-stream-last-char stream))) 489 (when (char= last-char #\Nul) 490 (error "No character to unread from this stream")) 491 (unless (char= char last-char) 492 (error "Last character read (~S) was different from ~S" 494 (with-slots (buffer-position last-char-size) stream 495 (decf buffer-position last-char-size)) 496 (with-slots (last-char last-char-size) stream 497 (setf last-char #\Nul 501 (defmethod open-stream-p ((stream decoding-stream)) 502 (open-stream-p (decoding-stream-stream stream))) 504 (defmethod stream-element-type ((stream decoding-stream)) 507 (defmethod close ((stream decoding-stream) &key abort) 508 ;; TODO: modify me to return the connection to the connection pool 509 (with-slots (stream) stream 510 (when (open-stream-p stream) 511 (close stream :abort abort)))) 514 (defun decode-body (content-type body &key default-charset on-close) 515 (let ((charset (or (and content-type 516 (detect-charset content-type body)) 518 (babel-encodings:*suppress-character-coding-errors* t)) 522 (make-decoding-stream body :encoding charset :on-close on-close) 523 (babel:octets-to-string body :encoding (keywordicate charset))) 524 (babel:character-decoding-error (e) 525 (warn (format nil "Failed to decode the body to ~S due to the following error (falling back to binary):~% ~A" 528 (return-from decode-body body))) 531 (defun content-disposition (key val) 533 (cons (content-disposition key (first val))) 535 (let* ((filename (file-namestring val)) 536 (utf8-filename-p (find-if (lambda (char) 537 (< 127 (char-code char))) 539 (format nil "Content-Disposition: form-data; name=\"~A\"; ~:[filename=\"~A\"~;filename*=UTF-8''~A~]~C~C" 543 (obj/uri:parse-uri filename) 545 #\Return #\Newline))) 547 (format nil "Content-Disposition: form-data; name=\"~A\"~C~C" 549 #\Return #\Newline)))) 551 (defmacro define-alist-cache (cache-name) 552 (let ((var (intern (format nil "*~A*" cache-name)))) 555 (defun ,(intern (format nil "LOOKUP-IN-~A" cache-name)) (elt) 557 (alexandria:assoc-value ,var elt))) 558 (defun (setf ,(intern (format nil "LOOKUP-IN-~A" cache-name))) (val elt) 560 (setf (alexandria:assoc-value ,var elt) val)) 563 ;; If bound, an alist mapping content to content-type, 564 ;; used to avoid determining content type multiple times 565 (define-alist-cache content-type-cache) 566 ;; If bound, an alist mapping content to encoded content, to avoid 567 ;; double converting content when we must calculate its length first 568 (define-alist-cache content-encoding-cache) 570 (defmacro with-content-caches (&body body) 571 `(let ((*content-type-cache* nil) 572 (*content-encoding-cache* nil)) 575 (defun content-type (value) 577 (pathname (or (lookup-in-content-type-cache value) 578 (setf (lookup-in-content-type-cache value) (mime value)))) 581 (defun multipart-value-content-type (value) 584 (destructuring-bind (val &key content-type) 586 (or content-type (content-type val)))) 587 (otherwise (content-type value)))) 589 (defun convert-to-octets (val) 590 (or (lookup-in-content-encoding-cache val) 591 (setf (lookup-in-content-encoding-cache val) 593 (string (babel:string-to-octets val)) 594 ((array (unsigned-byte 8) (*)) val) 595 (symbol (babel:string-to-octets (princ-to-string val))) 596 (cons (convert-to-octets (first val))) 597 (otherwise (babel:string-to-octets (princ-to-string val))))))) 599 (defun write-as-octets (stream val) 601 ((array (unsigned-byte 8) (*)) (write-sequence val stream)) 603 (with-open-file (in val :element-type '(unsigned-byte 8)) 604 (alexandria:copy-stream in stream))) 606 (write-sequence (convert-to-octets val) stream)) 607 (cons (write-as-octets stream (first val))) 608 (otherwise (fast-write-sequence (convert-to-octets val) stream)))) 610 (defun content-length (val) 612 (pathname (with-open-file (in val) 614 (cons (content-length (first val))) 615 (otherwise (length (convert-to-octets val))))) 617 (defun multipart-content-length (content boundary) 618 (declare (type simple-string boundary)) 619 (let ((boundary-length (length boundary))) 620 (+ (loop for (key . val) in content 624 (length (the simple-string (content-disposition key val))) 625 (let ((content-type (multipart-value-content-type val))) 627 (+ #.(length "Content-Type: ") (length content-type) 2) 633 finally (return total-length)) 634 2 boundary-length 2 2))) 636 (defun write-multipart-content (content boundary stream) 637 (let ((boundary (string-to-octets boundary))) 638 (labels ((boundary-line (&optional endp) 639 (fast-write-sequence (string-to-octets "--") stream) 640 (fast-write-sequence boundary stream) 642 (fast-write-sequence (string-to-octets "--") stream)) 644 (crlf () (fast-write-sequence +crlf+ stream))) 645 (loop for (key . val) in content 647 (fast-write-sequence (string-to-octets (content-disposition key val)) stream) 648 (let ((content-type (multipart-value-content-type val))) 652 (format nil "Content-Type: ~A~C~C" content-type #\Return #\Newline)) 655 (write-as-octets stream val) 658 (boundary-line t))))) 660 (defun decompress-body (content-encoding body) 661 (unless content-encoding 662 (return-from decompress-body body)) 665 ((string= content-encoding "gzip") 667 (chipz:make-decompressing-stream :gzip body) 668 (chipz:decompress nil (chipz:make-dstate :gzip) body))) 669 ((string= content-encoding "deflate") 671 (chipz:make-decompressing-stream :zlib body) 672 (chipz:decompress nil (chipz:make-dstate :zlib) body))) 676 (defvar *use-connection-pool* t) 677 (defvar *max-active-connections* 8 678 "Allowed number of active connections to all hosts. If you change this, 679 then call (make-new-connection-pool).") 681 (defstruct lru-pool-elt 682 (prev nil :type (or null lru-pool-elt)) 683 (next nil :type (or null lru-pool-elt)) 686 (eviction-callback nil :type (or null function))) 688 ;; An LRU-POOL can have multiple entries for the same key 690 (lock #+sb-thread (sb-thread:make-mutex :name "connection pool lock") 692 (hash-table nil :type (or null hash-table)) ;; hash table entries are lists of elements 693 (head nil :type (or null lru-pool-elt)) ;; most recently used is here and it's a doubly-linked-list 694 (tail nil :type (or null lru-pool-elt)) ;; least recently used is here 695 (num-elts 0 :type fixnum) 696 (max-elts 8 :type fixnum)) 698 (defun make-connection-pool (&optional (max-active-connections *max-active-connections*)) 699 (make-lru-pool :hash-table (make-hash-table :test 'equal) :max-elts max-active-connections)) 701 (defvar *connection-pool* nil) 703 (defun make-new-connection-pool (&optional (max-active-connections *max-active-connections*)) 704 (clear-connection-pool) 705 (setf *connection-pool* (make-connection-pool max-active-connections))) 707 (defun get-from-lru-pool (lru-pool key) 708 "Takes an element from the LRU-POOL matching KEY. Must be called with LRU-POOL-LOCK held. 709 The element is removed from the pool." 710 (let* ((hash-table (lru-pool-hash-table lru-pool)) 711 (possible-elts (gethash key (lru-pool-hash-table lru-pool)))) 713 (let ((remaining-elts (cdr possible-elts))) 715 (setf (gethash key hash-table) remaining-elts) 716 (remhash key hash-table))) 717 (let ((elt (car possible-elts))) 718 (let ((prev (lru-pool-elt-prev elt)) 719 (next (lru-pool-elt-next elt))) 721 (setf (lru-pool-elt-next prev) next) 722 (setf (lru-pool-head lru-pool) next)) 724 (setf (lru-pool-elt-prev next) prev) 725 (setf (lru-pool-tail lru-pool) prev))) 726 (decf (lru-pool-num-elts lru-pool)) 727 (lru-pool-elt-elt elt))))) 729 (defun evict-tail (lru-pool) 730 "Removes the least recently used element of the LRU-POOL and returns 731 (values evicted-element eviction-callback t) if there was 732 an element to remove, otherwise nil. Must be called with LRU-POOL-LOCK held. 734 Outside the LRU-POOL-LOCK you must call the returned EVICTION-CALLBACK with the EVICTED-ELEMENT." 735 ;; slightly different from get-from-lru-pool because we want to get rid of the 736 ;; actual oldest element (one could in principle call get-from-lru-pool on 737 ;; (lru-pool-elt-key (lru-pool-tail lru-pool)) if you didn't care 738 (let* ((tail (lru-pool-tail lru-pool))) 740 (let ((prev (lru-pool-elt-prev tail))) 742 (setf (lru-pool-elt-next prev) nil) 743 (setf (lru-pool-head lru-pool) nil)) 744 (setf (lru-pool-tail lru-pool) prev) 745 (let* ((hash-table (lru-pool-hash-table lru-pool)) 746 (key (lru-pool-elt-key tail)) 747 (remaining (cl:delete tail (gethash key hash-table)))) 749 (setf (gethash key hash-table) remaining) 750 (remhash key hash-table)))) 751 (decf (lru-pool-num-elts lru-pool)) 752 (values (lru-pool-elt-elt tail) (lru-pool-elt-eviction-callback tail) t)))) 754 (defun add-to-lru-pool (lru-pool key elt eviction-callback) 755 "Adds ELT to an LRU-POOL with potentially non-unique KEY, potentially evicting another element to 756 make room. EVICTION-CALLBACK will be called with one parameter ELT, when ELT is evicted from the 757 LRU-POOL. ADD-TO-LRU-POOL must be called with LRU-POOL-LOCK held. 759 If an element was evicted to make space, returns (values evicted-elt eviction-callback t) 760 otherwise nil. The EVICTION-CALLBACK should take one parameter, the evicted element." 761 (declare (type lru-pool lru-pool)) 762 (let* ((old-head (lru-pool-head lru-pool)) 763 (lru-pool-elt (make-lru-pool-elt :prev nil :next old-head :elt elt :key key :eviction-callback eviction-callback)) 764 (hash-table (lru-pool-hash-table lru-pool))) 765 (setf (lru-pool-head lru-pool) lru-pool-elt) 766 (push lru-pool-elt (gethash key hash-table)) 768 (setf (lru-pool-elt-prev old-head) lru-pool-elt)) 769 (unless (lru-pool-tail lru-pool) 770 (setf (lru-pool-tail lru-pool) lru-pool-elt)) 771 (when (> (incf (lru-pool-num-elts lru-pool)) (lru-pool-max-elts lru-pool)) 772 (evict-tail lru-pool)))) 774 (defmethod print-object ((obj lru-pool-elt) str) ;; avoid printing loops 775 (print-unreadable-object (obj str :type "LRU-POOL-ELT") 776 (format str "~A NEXT ~A" (lru-pool-elt-key obj) (lru-pool-elt-next obj)))) 778 (defmethod print-object ((obj lru-pool) str) ;; avoid printing loops 779 (print-unreadable-object (obj str :type "LRU-POOL") 781 (loop with lru-pool-elt = (lru-pool-head obj) 783 do (push (list (lru-pool-elt-key lru-pool-elt) (lru-pool-elt-elt lru-pool-elt)) objs) 784 do (setf lru-pool-elt (lru-pool-elt-next lru-pool-elt))) 786 (format str "~A/~A elts~%~{ ~{~A~^: ~}~^~%~}" (lru-pool-num-elts obj) (lru-pool-max-elts obj) objs) 787 (format str "empty"))))) 789 (defmacro with-lock (lock &body body) 790 #+thread-support `(sb-thread:with-mutex (,lock) 792 #-thread-support `(progn ,@body)) 794 (defun push-connection (host-port stream &optional eviction-callback) 795 "Add STREAM back to connection pool with key HOST-PORT. EVICTION-CALLBACK 796 must be a function of a single parameter, and will be called with STREAM 797 if the HOST-PORT/SOCKET pair is evicted from the connection pool." 798 (when *use-connection-pool* 799 (let ((pool *connection-pool*)) 800 (multiple-value-bind (evicted-elt eviction-callback) 801 (with-lock (lru-pool-lock pool) 802 (add-to-lru-pool pool host-port stream eviction-callback)) 803 (and eviction-callback (funcall eviction-callback evicted-elt)) 806 (defun steal-connection (host-port) 807 "Return the STREAM associated with key HOST-PORT" 808 (when *use-connection-pool* 809 (let ((pool *connection-pool*)) 810 (with-lock (lru-pool-lock pool) 811 (get-from-lru-pool pool host-port))))) 813 (defun clear-connection-pool () 814 "Remove all elements from the connection pool, calling their eviction-callbacks." 815 (when *use-connection-pool* 816 (let ((pool *connection-pool*) 817 evicted-element eviction-callback element-was-evicted) 819 (loop for count from 0 820 do (setf (values evicted-element eviction-callback element-was-evicted) 821 (with-lock (lru-pool-lock pool) 823 do (when eviction-callback (funcall eviction-callback evicted-element)) 824 while element-was-evicted))))) 826 (make-new-connection-pool) 830 (defparameter *ca-bundle* 831 #.(uiop:native-namestring #P"/etc/ca-certificates/extracted/ca-bundle.trust.crt") 832 "The default public root certificates used in requests.")) 835 (defun read-until-crlf*2 (stream) 836 (fast-io:with-fast-output (buf) 839 (loop for byte of-type (or (unsigned-byte 8) null) = (read-byte stream nil nil) 841 do (fast-io:fast-write-byte byte buf) 844 until (= byte (char-code #\Return))) 847 (let ((next-byte (read-byte stream nil nil))) 850 (locally (declare (type (unsigned-byte 8) next-byte)) 852 ((= next-byte (char-code #\Newline)) 853 (fast-io:fast-write-byte next-byte buf) 855 ((= next-byte (char-code #\Return)) 856 (fast-io:fast-write-byte next-byte buf) 859 (fast-io:fast-write-byte next-byte buf) 863 (let ((next-byte (read-byte stream nil nil))) 866 (locally (declare (type (unsigned-byte 8) next-byte)) 868 ((= next-byte (char-code #\Return)) 869 (fast-io:fast-write-byte next-byte buf) 872 (fast-io:fast-write-byte next-byte buf) 876 (let ((next-byte (read-byte stream nil nil))) 879 (locally (declare (type (unsigned-byte 8) next-byte)) 881 ((= next-byte (char-code #\Newline)) 882 (fast-io:fast-write-byte next-byte buf)) 883 ((= next-byte (char-code #\Return)) 884 (fast-io:fast-write-byte next-byte buf) 887 (fast-io:fast-write-byte next-byte buf) 893 (make-array 0 :element-type '(unsigned-byte 8))) 895 (defun read-response (stream has-body collect-headers read-body) 896 (let* ((http (make-http-response)) 899 (headers-data (and collect-headers 900 (fast-io:make-output-buffer))) 901 (header-finished-p nil) 904 (transfer-encoding-p) 905 (parser (make-http-parser http 908 (setq header-finished-p t 909 content-length (gethash "content-length" headers) 910 transfer-encoding-p (gethash "transfer-encoding" headers)) 911 (unless (and has-body 913 transfer-encoding-p)) 916 (lambda (data start end) 918 (fast-io:fast-write-sequence data body-data start end))) 921 (setq finishedp t))))) 922 (let ((buf (read-until-crlf*2 stream))) 923 (declare (type octet-vector buf)) 924 (when collect-headers 925 (fast-io:fast-write-sequence buf headers-data)) 926 (funcall parser buf)) 927 (unless header-finished-p 928 (error "maybe invalid header")) 933 (setq body *empty-body*)) 934 ((and content-length (not transfer-encoding-p)) 935 (let ((buf (make-array (etypecase content-length 936 (integer content-length) 937 (string (parse-integer content-length))) 938 :element-type '(unsigned-byte 8)))) 939 (read-sequence buf stream) 941 ((let ((status (http-status http))) 942 (or (= status 100) ;; Continue 943 (= status 101) ;; Switching Protocols 944 (= status 204) ;; No Content 945 (= status 304))) ;; Not Modified 946 (setq body *empty-body*)) 948 (setq body-data (fast-io:make-output-buffer)) 949 (loop for buf of-type octet-vector = (read-until-crlf*2 stream) 950 do (funcall parser buf) 952 (zerop (length buf))) 954 (setq body (fast-io:finish-output-buffer body-data))))) 958 (fast-io:finish-output-buffer headers-data)) 959 transfer-encoding-p))) 961 (defun print-verbose-data (direction &rest data) 962 (flet ((boundary-line () 963 (let ((char (ecase direction 972 (map nil (lambda (byte) 973 (princ (code-char byte))) 977 (defun convert-body (body content-encoding content-type content-length chunkedp force-binary force-string keep-alive-p on-close) 980 ((and keep-alive-p chunkedp) 981 (setf body (make-keep-alive-stream body :chunked-stream 982 (let ((chunked-stream (chunga:make-chunked-stream body))) 983 (setf (chunga:chunked-stream-input-chunking-p chunked-stream) t) 984 chunked-stream) :on-close-or-eof on-close))) 985 ((and keep-alive-p content-length) 986 (setf body (make-keep-alive-stream body :end content-length :on-close-or-eof on-close))) 988 (let ((chunked-stream (chunga:make-chunked-stream body))) 989 (setf (chunga:chunked-stream-input-chunking-p chunked-stream) t) 990 (setf body chunked-stream))))) 991 (let ((body (decompress-body content-encoding body))) 994 (decode-body content-type body 995 :default-charset (if force-string 996 babel:*default-character-encoding* 999 (defun build-cookie-headers (uri cookie-jar) 1000 (with-header-output (buffer) 1001 (let ((cookies (cookie-jar-host-cookies cookie-jar (uri-host uri) (or (uri-path uri) "/") 1002 :securep (string= (uri-scheme uri) "https")))) 1004 (fast-io:fast-write-sequence (string-to-octets "Cookie: ") buffer) 1005 (fast-io:fast-write-sequence 1006 (string-to-octets (write-cookie-header cookies)) 1008 (fast-io:fast-write-sequence +crlf+ buffer))))) 1010 (defun make-connect-stream (uri version stream &optional proxy-auth) 1011 (let ((header (fast-io:with-fast-output (buffer) 1012 (write-connect-header uri version buffer proxy-auth)))) 1013 (write-sequence header stream) 1014 (force-output stream) 1015 (read-until-crlf*2 stream) 1018 (defun make-proxy-authorization (uri) 1019 (let ((proxy-auth (obj/uri:uri-userinfo uri))) 1021 (format nil "Basic ~A" 1022 (dat/base64:string-to-base64-string proxy-auth))))) 1024 (defconstant +socks5-version+ 5) 1025 (defconstant +socks5-reserved+ 0) 1026 (defconstant +socks5-no-auth+ 0) 1027 (defconstant +socks5-connect+ 1) 1028 (defconstant +socks5-domainname+ 3) 1029 (defconstant +socks5-succeeded+ 0) 1030 (defconstant +socks5-ipv4+ 1) 1031 (defconstant +socks5-ipv6+ 4) 1033 (defun ensure-socks5-connected (input output uri http-method) 1034 (labels ((fail (condition &key reason) 1035 (error (make-condition condition 1036 :body nil :status nil :headers nil 1041 (unless (eql n (read-byte input nil 'eof)) 1042 (fail 'socks5-proxy-request-failed :reason reason))) 1045 (when (eq (read-byte input nil 'eof) 'eof) 1046 (fail 'socks5-proxy-request-failed :reason reason))))) 1047 ;; Send Version + Auth Method 1048 ;; Currently, only supports no-auth method. 1049 (write-byte +socks5-version+ output) 1050 (write-byte 1 output) 1051 (write-byte +socks5-no-auth+ output) 1052 (finish-output output) 1054 ;; Receive Auth Method 1055 (exact +socks5-version+ "Unexpected version") 1056 (exact +socks5-no-auth+ "Unsupported auth method") 1058 ;; Send domainname Request 1059 (let* ((host (babel:string-to-octets (uri-host uri))) 1060 (hostlen (length host)) 1061 (port (uri-port uri))) 1062 (unless (<= 1 hostlen 255) 1063 (fail 'socks5-proxy-request-failed :reason "domainname too long")) 1064 (unless (<= 1 port 65535) 1065 (fail 'socks5-proxy-request-failed :reason "Invalid port")) 1066 (write-byte +socks5-version+ output) 1067 (write-byte +socks5-connect+ output) 1068 (write-byte +socks5-reserved+ output) 1069 (write-byte +socks5-domainname+ output) 1070 (write-byte hostlen output) 1071 (write-sequence host output) 1072 (write-byte (ldb (byte 8 8) port) output) 1073 (write-byte (ldb (byte 8 0) port) output) 1074 (finish-output output) 1077 (exact +socks5-version+ "Unexpected version") 1078 (exact +socks5-succeeded+ "Unexpected result code") 1079 (drop 1 "Should be reserved byte") 1080 (let ((atyp (read-byte input nil 'eof))) 1082 ((eql atyp +socks5-ipv4+) 1083 (drop 6 "Should be IPv4 address and port")) 1084 ((eql atyp +socks5-ipv6+) 1085 (drop 18 "Should be IPv6 address and port")) 1086 ((eql atyp +socks5-domainname+) 1087 (let ((n (read-byte input nil 'eof))) 1089 (fail 'socks5-proxy-request-failed :reason "Invalid domainname length")) 1090 (drop n "Should be domainname and port"))) 1092 (fail 'socks5-proxy-request-failed :reason "Unknown address"))))))) 1094 (defun make-ssl-stream (stream ca-path ssl-key-file ssl-cert-file ssl-key-password hostname insecure) 1095 #+nil (declare (ignore stream ca-path ssl-key-file ssl-cert-file ssl-key-password hostname insecure)) 1096 #+nil (error "SSL not supported. Remove :dexador-no-ssl from *features* to enable SSL.") 1098 (cl+ssl:ensure-initialized) 1099 (let ((ctx (cl+ssl:make-context :verify-mode 1101 cl+ssl:+ssl-verify-none+ 1102 cl+ssl:+ssl-verify-peer+) 1106 (ca-path (uiop:native-namestring ca-path)) 1107 ((probe-file *ca-bundle*) *ca-bundle*) 1108 ;; In executable environment, perhaps *ca-bundle* doesn't exist. 1110 (ssl-cert-pem-p (and ssl-cert-file 1111 (std/seq:ends-with-subseq ".crt" ssl-cert-file)))) 1112 (cl+ssl:with-global-context (ctx :auto-free-p t) 1113 (when ssl-cert-pem-p 1114 (cl+ssl:use-certificate-chain-file ssl-cert-file)) 1115 (cl+ssl:make-ssl-client-stream stream 1117 :verify (not insecure) 1119 :certificate (and (not ssl-cert-pem-p) 1121 :password ssl-key-password))))) 1123 (defstruct %wrapped-stream 1126 ;; Forward methods the user might want to use on this. 1127 ;; User is not meant to interact with this object except 1128 ;; potentially to close it when they decide they don't 1129 ;; need the :keep-alive connection anymore. 1130 (defmethod close ((u %wrapped-stream) &key abort) 1131 (close (%wrapped-stream-stream u) :abort abort)) 1133 (defmethod open-stream-p ((u %wrapped-stream)) 1134 (open-stream-p (%wrapped-stream-stream u))) 1136 (defun request (uri &rest args 1137 &key (method :get) (version 1.1) 1139 basic-auth bearer-auth 1141 (connect-timeout *default-connect-timeout*) (read-timeout *default-read-timeout*) 1142 (keep-alive t) (use-connection-pool t) 1144 ssl-key-file ssl-cert-file ssl-key-password 1145 stream (verbose *verbose*) 1149 (proxy *default-proxy*) 1153 (proxy-uri (and proxy (obj/uri:uri proxy))) 1154 (original-user-supplied-stream stream) 1155 (user-supplied-stream (if (%wrapped-stream-p stream) (%wrapped-stream-stream stream) stream))) 1156 (declare (ignorable ssl-key-file ssl-cert-file ssl-key-password 1159 (type fixnum max-redirects)) 1160 (with-content-caches 1161 (labels ((make-new-connection (uri) 1163 (let* ((con-uri (uri (or proxy uri))) 1164 (socket (make-instance 'sb-bsd-sockets:inet-socket 1167 (connection (sb-bsd-sockets:socket-connect 1169 (sb-bsd-sockets:make-inet-address (net/proto/dns:resolve (uri-host con-uri))) 1170 (or (uri-port con-uri) (when insecure 80) 443) 1172 ;; :timeout connect-timeout 1173 ;;:element-type '(unsigned-byte 8) 1175 (stream (sb-bsd-sockets:socket-make-stream connection 1178 :timeout connect-timeout 1180 :element-type :default)) 1182 (scheme (uri-scheme uri))) 1183 (declare (type keyword scheme)) 1184 ;; (when read-timeout 1185 ;; (setf (io/socket:sockopt-receive-timeout connection) read-timeout)) ;; TODO 2024-06-19: test 1186 (when (socks5-proxy-p proxy-uri) 1187 (ensure-socks5-connected stream stream uri method)) 1188 (if (string= (symbol-name scheme) "HTTPS") 1189 (make-ssl-stream (if (http-proxy-p proxy-uri) 1190 (make-connect-stream uri version stream (make-proxy-authorization con-uri)) 1191 stream) ca-path ssl-key-file ssl-cert-file ssl-key-password (uri-host uri) insecure) 1194 :report "Retry the same request." 1195 (return-from request 1196 (apply #'request uri :use-connection-pool nil args))) 1198 :report "Retry the same request without checking for SSL certificate validity." 1199 (return-from request 1200 (apply #'request uri :use-connection-pool nil :insecure t args))))) 1203 (let ((scheme (uri-scheme uri))) 1204 (and (stringp scheme) 1205 (or (string= scheme "http") 1206 (string= scheme "https")))))) 1207 (socks5-proxy-p (uri) 1209 (let ((scheme (uri-scheme uri))) 1210 (and (stringp scheme) 1211 (string= scheme "socks5"))))) 1212 (connection-keep-alive-p (connection-header) 1214 (or (and (= (the real version) 1.0) 1215 (equalp connection-header "keep-alive")) 1216 (not (equalp connection-header "close"))))) 1217 (return-stream-to-pool (stream uri) 1218 (push-connection (format nil "~A://~A" 1220 (uri-authority uri)) stream #'close)) 1221 (return-stream-to-pool-or-close (stream connection-header uri) 1222 (if (and (not user-supplied-stream) use-connection-pool (connection-keep-alive-p connection-header)) 1223 (return-stream-to-pool stream uri) 1224 (when (open-stream-p stream) 1226 (finalize-connection (stream connection-header uri) 1227 "If KEEP-ALIVE is in the connection-header and the user is not requesting a stream, 1228 we will push the connection to our connection pool if allowed, otherwise we return 1229 the stream back to the user who must close it." 1232 ((and use-connection-pool (connection-keep-alive-p connection-header) (not user-supplied-stream)) 1233 (return-stream-to-pool stream uri)) 1234 ((not (connection-keep-alive-p connection-header)) 1235 (when (open-stream-p stream) 1236 (close stream))))))) 1237 (let* ((uri (uri uri)) 1238 (proxy (when (http-proxy-p proxy-uri) proxy)) 1239 (content-type (cdr (find :content-type headers :key #'car :test #'string-equal))) 1240 (multipart-p (or (and content-type 1241 (>= (length content-type) 10) 1242 (string= content-type "multipart/" :end1 10)) 1243 (and (not content-type) 1245 (find-if #'pathnamep content :key #'cdr)))) 1246 (form-urlencoded-p (or (string= content-type "application/x-www-form-urlencoded") 1247 (and (not content-type) 1249 (not multipart-p)))) 1250 (boundary (and multipart-p 1251 (make-random-string 12))) 1252 (content (if (and form-urlencoded-p (not (stringp content))) ;; user can provide already encoded content, trust them. 1253 (obj/url::url-encode-params content) 1255 (stream (or user-supplied-stream 1256 (and use-connection-pool 1257 (steal-connection (format nil "~A://~A" 1259 (uri-authority uri)))))) 1260 (reusing-stream-p (not (null stream))) ;; user provided or from connection-pool 1262 (make-new-connection uri))) 1264 (assoc :content-length headers :test #'string-equal)) 1266 (assoc :transfer-encoding headers :test #'string-equal)) 1267 (chunkedp (or (and transfer-encoding 1268 (equalp (cdr transfer-encoding) "chunked")) 1270 (null (cdr content-length))))) 1272 (fast-io:with-fast-output (buffer) 1273 (write-first-line method uri version buffer))) 1275 (flet ((write-header* (name value) 1276 (let ((header (assoc name headers :test #'string-equal))) 1279 (write-header name (cdr header))) 1280 (write-header name value))) 1282 (with-header-output (buffer) 1283 (write-header* :user-agent #.*default-user-agent*) 1284 (write-header* :host (uri-authority uri)) 1285 (write-header* :accept "*/*") 1288 (= (the real version) 1.0)) 1289 (write-header* :connection "keep-alive")) 1290 ((and (not keep-alive) 1291 (= (the real version) 1.1)) 1292 (write-header* :connection "close"))) 1293 (cond ((and bearer-auth basic-auth) 1294 (error "You should only use one Authorization header.")) 1296 (write-header* :authorization 1297 (format nil "Basic ~A" 1298 (dat/base64::string-to-base64-string 1301 (cdr basic-auth)))))) 1303 (write-header* :authorization 1304 (format nil "Bearer ~A" bearer-auth)))) 1306 (let ((scheme (uri-scheme uri))) 1307 (when (string= scheme "http") 1308 (let* ((uri (uri proxy)) 1309 (proxy-authorization (make-proxy-authorization uri))) 1310 (when proxy-authorization 1311 (write-header* :proxy-authorization proxy-authorization)))))) 1314 (write-header :content-type (format nil "~A; boundary=~A" 1315 (or content-type "multipart/form-data") 1318 (write-header :content-length 1319 (multipart-content-length content boundary)))) 1321 (write-header* :content-type "application/x-www-form-urlencoded") 1323 (write-header* :content-length (length (the string content))))) 1328 (write-header* :content-length 0))) 1330 (write-header* :content-type (or content-type "text/plain")) 1332 (write-header* :content-length (content-length content)))) 1333 ((array (unsigned-byte 8) *) 1334 (write-header* :content-type (or content-type "text/plain")) 1336 (write-header* :content-length (length content)))) 1338 (write-header* :content-type (or content-type (content-type content))) 1340 (write-header :content-length 1341 (or (cdr (assoc :content-length headers :test #'string-equal)) 1342 (content-length content)))))))) 1343 ;; Transfer-Encoding: chunked 1345 (not transfer-encoding)) 1346 (write-header* :transfer-encoding "chunked")) 1349 (loop for (name . value) in headers 1350 unless (member name '(:user-agent :host :accept 1352 :content-type :content-length) :test #'string-equal) 1353 do (write-header name value))))) 1354 (cookie-headers (and cookie-jar 1355 (build-cookie-headers uri cookie-jar)))) 1356 (macrolet ((maybe-try-again-without-reusing-stream (&optional (force nil)) 1357 `(progn ;; retrying by go retry avoids generating the header, parsing, etc. 1358 (when (open-stream-p stream) 1359 (close stream :abort t) 1362 (when ,(or force 'reusing-stream-p) 1363 (setf reusing-stream-p nil 1364 user-supplied-stream nil 1365 stream (make-new-connection uri)) 1367 (try-again-without-reusing-stream () 1368 `(maybe-try-again-without-reusing-stream t)) 1369 (with-retrying (&body body) 1371 (handler-bind (((and error 1372 ;; We should not retry errors received from the server. 1373 ;; Only technical errors such as disconnection or some 1374 ;; problems with the protocol should be retried automatically. 1375 ;; This solves https://github.com/fukamachi/dexador/issues/137 issue. 1376 (not http-request-failed)) 1378 (declare (ignorable e)) 1379 (maybe-try-again-without-reusing-stream)))) 1381 (retry-request () :report "Retry the same request." 1382 (return-from request (apply #'request uri args))) 1383 (ignore-and-continue () :report "Ignore the error and continue.")))) 1387 (unless (open-stream-p stream) 1388 (try-again-without-reusing-stream)) 1391 (write-sequence first-line-data stream) 1392 (write-sequence headers-data stream) 1393 (when cookie-headers 1394 (write-sequence cookie-headers stream)) 1395 (write-sequence +crlf+ stream) 1396 (force-output stream)) 1398 ;; Sending the content 1400 (let ((stream (if chunkedp 1401 (chunga:make-chunked-stream stream) 1404 (setf (chunga:chunked-stream-output-chunking-p stream) t)) 1407 (write-multipart-content content boundary stream) 1408 (write-as-octets stream content)) 1410 (setf (chunga:chunked-stream-output-chunking-p stream) nil)) 1411 (finish-output stream)))) 1414 (multiple-value-bind (http body response-headers-data transfer-encoding-p) 1416 (read-response stream (not (eq method :head)) verbose (not want-stream))) 1417 (let* ((status (http-status http)) 1418 (response-headers (http-headers http)) 1419 (content-length (gethash "content-length" response-headers)) 1420 (content-length (etypecase content-length 1421 (null content-length) 1422 (string (parse-integer content-length)) 1423 (integer content-length)))) 1426 (http-request-failed status 1432 (print-verbose-data :outgoing first-line-data headers-data cookie-headers +crlf+) 1433 (print-verbose-data :incoming response-headers-data)) 1435 (when-let ((set-cookies (append (gethash "set-cookie" response-headers) 1436 (ensure-list (gethash "set-cookie2" response-headers))))) 1437 (net/cookie::merge-cookies cookie-jar 1438 (remove nil (mapcar (lambda (cookie) 1439 (declare (type string cookie)) 1440 (unless (= (length cookie) 0) 1441 (net/cookie:parse-set-cookie-header cookie 1445 (when (and (member status '(301 302 303 307 308) :test #'=) 1446 (gethash "location" response-headers) 1447 (/= max-redirects 0)) 1448 ;; Need to read the response body 1449 (when (and want-stream 1450 (not (eq method :head))) 1452 ((integerp content-length) 1453 (dotimes (i content-length) 1454 (loop until (read-byte body nil nil)))) 1455 (transfer-encoding-p 1456 (read-until-crlf*2 body)))) 1458 (let* ((location-uri (uri (gethash "location" response-headers))) 1459 (same-server-p (or (null (uri-host location-uri)) 1460 (and (string= (uri-scheme location-uri) 1462 (string= (uri-host location-uri) 1464 (eql (uri-port location-uri) 1466 (if (and same-server-p 1467 (or (= status 307) (= status 308) 1468 (member method '(:get :head) :test #'eq))) 1469 (progn ;; redirection to the same host 1470 (setq uri (merge-uris location-uri uri)) 1471 (setq first-line-data 1472 (fast-io:with-fast-output (buffer) 1473 (write-first-line method uri version buffer))) 1475 ;; Rebuild cookie-headers. 1476 (setq cookie-headers (build-cookie-headers uri cookie-jar))) 1477 (decf max-redirects) 1478 (if (equalp (gethash "connection" response-headers) "close") 1479 (try-again-without-reusing-stream) 1481 (setq reusing-stream-p t) 1483 (progn ;; this is a redirection to a different host 1484 (setf location-uri (merge-uris location-uri uri)) 1485 ;; Close connection if it isn't from our connection pool or from the user and we aren't going to 1486 ;; pass it to our new call. 1487 (when (not same-server-p) (return-stream-to-pool-or-close stream (gethash "connection" response-headers) uri)) 1488 (setf (getf args :headers) 1489 (nconc `((:host . ,(uri-host location-uri))) headers)) 1490 (setf (getf args :max-redirects) 1492 ;; Redirect as GET if it's 301, 302, 303 1493 (unless (or (= status 307) (= status 308) 1494 (member method '(:get :head) :test #'eq)) 1495 (setf (getf args :method) :get)) 1496 (return-from request 1497 (apply #'request location-uri (if same-server-p 1499 (progn (remf args :stream) args)))))))) 1501 (let* ((keep-connection-alive (connection-keep-alive-p 1502 (gethash "connection" response-headers))) 1503 (body (convert-body body 1504 (gethash "content-encoding" response-headers) 1505 (gethash "content-type" response-headers) 1510 keep-connection-alive 1511 (if (and use-connection-pool keep-connection-alive (not user-supplied-stream) (streamp body)) 1512 (lambda (underlying-stream abort) 1513 (declare (ignore abort)) 1514 (when (and underlying-stream (open-stream-p underlying-stream)) 1515 ;; read any left overs the user may have not read (in case of errors on user side?) 1516 (loop while (ignore-errors (listen underlying-stream)) ;; ssl streams may close 1517 do (read-byte underlying-stream nil nil)) 1518 (when (open-stream-p underlying-stream) 1519 (push-connection (format nil "~A://~A" 1521 (uri-authority uri)) underlying-stream #'close)))) 1522 #'keep-alive-stream-close-underlying-stream)))) 1523 ;; Raise an error when the HTTP response status code is 4xx or 50x. 1524 (when (<= 400 status) 1526 (http-request-failed status 1528 :headers response-headers 1531 ;; Have to be a little careful with the fifth value stream we return -- 1532 ;; the user may be not aware that keep-alive t without use-connection-pool can leak 1533 ;; sockets, so we wrap the returned last value so when it is garbage 1534 ;; collected it gets closed. If the user is getting a stream back as BODY, 1535 ;; then we instead add a finalizer to that stream to close it when garbage collected 1536 (return-from request 1541 (when (and keep-alive 1542 (not (equalp (gethash "connection" response-headers) "close")) 1543 (or (not use-connection-pool) user-supplied-stream)) 1544 (or (and original-user-supplied-stream ;; user provided a stream 1545 (if (%wrapped-stream-p original-user-supplied-stream) ;; but, it came from us 1546 (eql (%wrapped-stream-stream original-user-supplied-stream) stream) ;; and we used it 1547 (eql original-user-supplied-stream stream)) ;; user provided a bare stream 1548 original-user-supplied-stream) ;; return what the user sent without wrapping it 1549 (if want-stream ;; add a finalizer to the body to close the stream 1551 (trivial-garbage:finalize body (lambda () (close stream))) 1553 (let ((wrapped-stream (make-%wrapped-stream :stream stream))) 1554 (trivial-garbage:finalize wrapped-stream (lambda () (close stream))) 1555 wrapped-stream))))))) 1556 (finalize-connection stream (gethash "connection" response-headers) uri)))))))))) 1559 (defun get (uri &rest args 1560 &key version headers basic-auth bearer-auth cookie-jar keep-alive use-connection-pool 1561 connect-timeout read-timeout max-redirects 1562 force-binary force-string want-stream content 1563 ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path) 1564 "Make a GET request to URI and return 1565 (values body-or-stream status response-headers uri &optional opaque-socket-stream) 1567 You may pass a real stream in as STREAM if you want us to communicate with the server via it -- 1568 though if any errors occur, we will open a new connection to the server. If you have a previous 1569 OPAQUE-SOCKET-STREAM you can pass that in as STREAM as well and we will re-use that connection. 1571 OPAQUE-SOCKET-STREAM is not returned if USE-CONNECTION-POOL is T, instead we keep track of it and 1572 re-use it when needed. 1574 If WANT-STREAM is T, then a STREAM is returned as the first value. You may read this as needed to 1575 get the body of the response. If KEEP-ALIVE and USE-CONNECTION-POOL are T, then the stream will be 1576 returned to the connection pool when you have read all the data or closed the stream. If KEEP-ALIVE 1577 is NIL then you are responsible for closing the stream when done. 1579 If KEEP-ALIVE is T and USE-CONNECTION-POOL is NIL, then the fifth value returned is a stream which 1580 you can then pass in again using the STREAM option to re-use the active connection. If you ignore 1581 the stream, it will get closed during garbage collection. 1583 If KEEP-ALIVE is T and USE-CONNECTION-POOL is T, then there is no fifth 1584 value (OPAQUE-SOCKET-STREAM) returned, but the active connection to the host/port may be reused in 1585 subsequent calls. This removes the need for the caller to keep track of the active socket-stream 1586 for subsequent calls. 1588 While CONTENT is allowed in a GET request the results are ill-defined and not advised." 1589 (declare (ignore version headers basic-auth bearer-auth cookie-jar keep-alive use-connection-pool 1590 connect-timeout read-timeout max-redirects force-binary force-string want-stream 1591 ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path content)) 1592 (apply #'request uri :method :get args)) 1594 (defun post (uri &rest args 1595 &key version content headers basic-auth bearer-auth cookie-jar keep-alive 1596 use-connection-pool connect-timeout read-timeout 1597 force-binary force-string want-stream 1598 ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path) 1599 (declare (ignore version content headers basic-auth bearer-auth cookie-jar keep-alive 1600 use-connection-pool connect-timeout read-timeout force-binary force-string 1601 want-stream ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy 1603 (apply #'request uri :method :post args)) 1605 (defun head (uri &rest args 1606 &key version headers basic-auth bearer-auth cookie-jar connect-timeout read-timeout max-redirects 1607 ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path) 1608 (declare (ignore version headers basic-auth bearer-auth cookie-jar connect-timeout read-timeout 1609 max-redirects ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path)) 1610 (apply #'request uri :method :head :use-connection-pool nil args)) 1612 (defun put (uri &rest args 1613 &key version content headers basic-auth bearer-auth cookie-jar keep-alive 1614 use-connection-pool connect-timeout read-timeout 1615 force-binary force-string want-stream 1616 ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path) 1617 (declare (ignore version content headers basic-auth bearer-auth cookie-jar keep-alive 1618 use-connection-pool connect-timeout read-timeout force-binary force-string 1619 want-stream ssl-key-file ssl-cert-file ssl-key-password stream verbose 1620 proxy insecure ca-path)) 1621 (apply #'request uri :method :put args)) 1623 (defun patch (uri &rest args 1624 &key version content headers basic-auth bearer-auth cookie-jar keep-alive 1625 use-connection-pool connect-timeout read-timeout 1626 force-binary force-string want-stream 1627 ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path) 1628 (declare (ignore version content headers basic-auth bearer-auth cookie-jar keep-alive 1629 use-connection-pool connect-timeout read-timeout force-binary force-string 1630 want-stream ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy 1632 (apply #'request uri :method :patch args)) 1634 (defun delete (uri &rest args 1635 &key version headers basic-auth bearer-auth cookie-jar keep-alive 1636 use-connection-pool connect-timeout read-timeout 1637 force-binary force-string want-stream content 1638 ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path) 1639 (declare (ignore version headers basic-auth bearer-auth cookie-jar keep-alive use-connection-pool 1640 connect-timeout read-timeout force-binary force-string want-stream ssl-key-file 1641 ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path content)) 1642 (apply #'request uri :method :delete args)) 1644 (defun fetch (uri destination &rest args 1645 &key (if-exists :error) 1646 version headers basic-auth bearer-auth cookie-jar keep-alive use-connection-pool 1647 connect-timeout read-timeout max-redirects 1648 ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path) 1649 (declare (ignore version headers basic-auth bearer-auth cookie-jar keep-alive use-connection-pool 1650 connect-timeout read-timeout max-redirects ssl-key-file ssl-cert-file 1651 ssl-key-password stream verbose proxy insecure ca-path)) 1652 (unless (and (eql if-exists nil) 1653 (probe-file destination)) 1654 (with-open-file (out destination 1655 :direction :output :element-type '(unsigned-byte 8) 1656 :if-exists if-exists 1657 :if-does-not-exist :create) 1658 (remf args :if-exists) 1659 (let ((body (apply #'req:get uri :want-stream t :force-binary t 1661 (alexandria:copy-stream body out) 1662 ;; Nominally the body gets closed, but if keep-alive is nil we need to explicitly do it. 1663 (when (open-stream-p body) 1666 (defun ignore-and-continue (e) 1667 (let ((restart (find-restart 'ignore-and-continue e))) 1669 (invoke-restart restart)))) 1671 (defun retry-request (times &key (interval 3)) 1672 (declare (type (or function integer) interval)) 1675 (let ((restart (find-restart 'retry-request times))) 1677 (invoke-restart restart)))) 1679 (retry-request-ntimes times :interval interval)))) 1681 (defun retry-request-ntimes (n &key (interval 3)) 1682 (declare (type integer n) 1683 (type (or function integer) interval)) 1685 (declare (type integer retries)) 1687 (declare (type condition e)) 1688 (let ((restart (find-restart 'retry-request e))) 1693 (function (funcall interval retries)) 1694 (integer (sleep interval))) 1695 (invoke-restart restart)))))))