Mercurial > core / lisp/lib/net/req.lisp
changeset 374: |
d1d64b856fae |
parent: |
49c3f3d11432
|
child: |
9e133c99b080 |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Mon, 27 May 2024 03:08:21 -0400 |
permissions: |
-rw-r--r-- |
description: |
rm dexador dependency |
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 0) end) 351 (declare (optimize speed)) 352 (if (null (keep-alive-stream-stream stream)) ;; we already closed it 354 (let* ((to-read (min (print (- end start)) (keep-alive-stream-end stream))) 355 (n (read-sequence sequence (keep-alive-stream-stream stream) 357 :end (+ start to-read)))) 358 (decf (keep-alive-stream-end stream) (print (- n start))) 359 (maybe-close stream (<= (keep-alive-stream-end stream) 0)) 362 (defmethod stream-read-sequence ((stream keep-alive-chunked-stream) sequence &optional (start 0) end) 363 (declare (optimize speed)) 364 (if (null (print (keep-alive-stream-stream stream))) ;; we already closed it 366 (if (chunga:chunked-stream-input-chunking-p (chunga-stream stream)) 368 (let ((num-read (read-sequence sequence (chunga-stream stream) :start start :end end))) 370 (maybe-close stream (not (chunga:chunked-stream-input-chunking-p (chunga-stream stream))))) 373 (defmethod stream-element-type ((stream keep-alive-chunked-stream)) 374 (stream-element-type (chunga-stream stream))) 376 (defmethod stream-element-type ((stream keep-alive-stream)) 379 (defmethod open-stream-p ((stream keep-alive-stream)) 380 (let ((underlying-stream (keep-alive-stream-stream stream))) 381 (and underlying-stream (open-stream-p underlying-stream)))) 383 (defmethod close ((stream keep-alive-stream) &key abort) 384 (funcall (close-action stream) (keep-alive-stream-stream stream) abort) 385 (setf (keep-alive-stream-stream stream) nil)) 388 (declaim (type fixnum +buffer-size+)) 389 (eval-when (:compile-toplevel :load-toplevel :execute) 390 (defconstant +buffer-size+ 128)) 392 (defclass decoding-stream (fundamental-character-input-stream) 393 ((stream :type stream 395 :initform (error ":stream is required") 396 :accessor decoding-stream-stream) 397 (encoding :initarg :encoding 398 :initform (error ":encoding is required") 399 :accessor decoding-stream-encoding) 400 (buffer :type (simple-array (unsigned-byte 8) (#.+buffer-size+)) 401 :initform (make-array +buffer-size+ :element-type '(unsigned-byte 8)) 402 :accessor decoding-stream-buffer) 403 (buffer-position :type fixnum 404 :initform +buffer-size+ 405 :accessor decoding-stream-buffer-position) 406 (buffer-end-position :type fixnum 408 :accessor decoding-stream-buffer-end-position) 409 (last-char :type character 411 :accessor decoding-stream-last-char) 412 (last-char-size :type fixnum 414 :accessor decoding-stream-last-char-size) 415 (on-close :type (or null function) :initform nil :initarg :on-close))) 417 (defmethod initialize-instance :after ((stream decoding-stream) &rest initargs) 418 (declare (ignore initargs)) 419 (with-slots (encoding) stream 420 (when (keywordp encoding) 421 (setf encoding (babel-encodings:get-character-encoding encoding))))) 423 (defun make-decoding-stream (stream &key (encoding babel-encodings:*default-character-encoding*) 425 (let ((decoding-stream (make-instance 'decoding-stream 428 :on-close on-close))) 429 (fill-buffer decoding-stream) 432 (defun fill-buffer (stream) 433 (declare (optimize speed)) 434 (with-slots (stream buffer buffer-position buffer-end-position) stream 435 (declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+)) buffer) 436 (type fixnum buffer-position)) 437 (let ((to-read (- +buffer-size+ buffer-position))) 438 (declare (type fixnum to-read)) 439 (replace buffer buffer 441 :start2 buffer-position 443 (setf buffer-position 0) 444 (let ((n (read-sequence buffer stream :start to-read))) 445 (declare (type fixnum n)) 446 (unless (= n +buffer-size+) 447 (setf buffer-end-position n)))))) 449 (defun needs-to-fill-buffer-p (stream) 450 (declare (optimize speed)) 451 (when (/= -1 (the fixnum (decoding-stream-buffer-end-position stream))) 452 (return-from needs-to-fill-buffer-p nil)) 454 (with-slots (buffer-position encoding) stream 455 (< (- +buffer-size+ (the fixnum buffer-position)) 456 (the fixnum (babel-encodings:enc-max-units-per-char encoding))))) 459 (defmethod stream-read-char ((stream decoding-stream)) 460 (declare (optimize speed)) 461 (when (needs-to-fill-buffer-p stream) 462 (fill-buffer stream)) 464 (when (= (the fixnum (decoding-stream-buffer-end-position stream)) 465 (the fixnum (decoding-stream-buffer-position stream))) 466 (return-from stream-read-char :eof)) 468 (with-slots (buffer buffer-position encoding last-char last-char-size) 470 (declare (fixnum buffer-position)) 471 (let* ((mapping (babel-encodings:lookup-mapping babel::*string-vector-mappings* encoding)) 472 (counter (babel-encodings:code-point-counter mapping))) 473 (declare (type function counter)) 474 (multiple-value-bind (chars new-end) 475 (funcall counter buffer buffer-position +buffer-size+ 1) 476 (declare (ignore chars) (fixnum new-end)) 477 (let ((string (make-string 1 :element-type 'babel:unicode-char)) 478 (size (the fixnum (- new-end buffer-position)))) 479 (funcall (the function (babel-encodings:decoder mapping)) 480 buffer buffer-position new-end string 0) 481 (setf buffer-position new-end 482 last-char (aref string 0) 486 (defmethod stream-unread-char ((stream decoding-stream) char) 487 (let ((last-char (decoding-stream-last-char stream))) 488 (when (char= last-char #\Nul) 489 (error "No character to unread from this stream")) 490 (unless (char= char last-char) 491 (error "Last character read (~S) was different from ~S" 493 (with-slots (buffer-position last-char-size) stream 494 (decf buffer-position last-char-size)) 495 (with-slots (last-char last-char-size) stream 496 (setf last-char #\Nul 500 (defmethod open-stream-p ((stream decoding-stream)) 501 (open-stream-p (decoding-stream-stream stream))) 503 (defmethod stream-element-type ((stream decoding-stream)) 506 (defmethod close ((stream decoding-stream) &key abort) 507 ;; TODO: modify me to return the connection to the connection pool 508 (with-slots (stream) stream 509 (when (open-stream-p stream) 510 (close stream :abort abort)))) 513 (defun decode-body (content-type body &key default-charset on-close) 514 (let ((charset (or (and content-type 515 (detect-charset content-type body)) 517 (babel-encodings:*suppress-character-coding-errors* t)) 521 (make-decoding-stream body :encoding charset :on-close on-close) 522 (babel:octets-to-string body :encoding (keywordicate charset))) 523 (babel:character-decoding-error (e) 524 (warn (format nil "Failed to decode the body to ~S due to the following error (falling back to binary):~% ~A" 527 (return-from decode-body body))) 530 (defun content-disposition (key val) 532 (cons (content-disposition key (first val))) 534 (let* ((filename (file-namestring val)) 535 (utf8-filename-p (find-if (lambda (char) 536 (< 127 (char-code char))) 538 (format nil "Content-Disposition: form-data; name=\"~A\"; ~:[filename=\"~A\"~;filename*=UTF-8''~A~]~C~C" 542 (obj/uri:parse-uri filename) 544 #\Return #\Newline))) 546 (format nil "Content-Disposition: form-data; name=\"~A\"~C~C" 548 #\Return #\Newline)))) 550 (defmacro define-alist-cache (cache-name) 551 (let ((var (intern (format nil "*~A*" cache-name)))) 554 (defun ,(intern (format nil "LOOKUP-IN-~A" cache-name)) (elt) 556 (alexandria:assoc-value ,var elt))) 557 (defun (setf ,(intern (format nil "LOOKUP-IN-~A" cache-name))) (val elt) 559 (setf (alexandria:assoc-value ,var elt) val)) 562 ;; If bound, an alist mapping content to content-type, 563 ;; used to avoid determining content type multiple times 564 (define-alist-cache content-type-cache) 565 ;; If bound, an alist mapping content to encoded content, to avoid 566 ;; double converting content when we must calculate its length first 567 (define-alist-cache content-encoding-cache) 569 (defmacro with-content-caches (&body body) 570 `(let ((*content-type-cache* nil) 571 (*content-encoding-cache* nil)) 574 (defun content-type (value) 576 (pathname (or (lookup-in-content-type-cache value) 577 (setf (lookup-in-content-type-cache value) (mimes:mime value)))) 580 (defun multipart-value-content-type (value) 583 (destructuring-bind (val &key content-type) 585 (or content-type (content-type val)))) 586 (otherwise (content-type value)))) 588 (defun convert-to-octets (val) 589 (or (lookup-in-content-encoding-cache val) 590 (setf (lookup-in-content-encoding-cache val) 592 (string (babel:string-to-octets val)) 593 ((array (unsigned-byte 8) (*)) val) 594 (symbol (babel:string-to-octets (princ-to-string val))) 595 (cons (convert-to-octets (first val))) 596 (otherwise (babel:string-to-octets (princ-to-string val))))))) 598 (defun write-as-octets (stream val) 600 ((array (unsigned-byte 8) (*)) (write-sequence val stream)) 602 (with-open-file (in val :element-type '(unsigned-byte 8)) 603 (alexandria:copy-stream in stream))) 605 (write-sequence (convert-to-octets val) stream)) 606 (cons (write-as-octets stream (first val))) 607 (otherwise (fast-write-sequence (convert-to-octets val) stream)))) 609 (defun content-length (val) 611 (pathname (with-open-file (in val) 613 (cons (content-length (first val))) 614 (otherwise (length (convert-to-octets val))))) 616 (defun multipart-content-length (content boundary) 617 (declare (type simple-string boundary)) 618 (let ((boundary-length (length boundary))) 619 (+ (loop for (key . val) in content 623 (length (the simple-string (content-disposition key val))) 624 (let ((content-type (multipart-value-content-type val))) 626 (+ #.(length "Content-Type: ") (length content-type) 2) 632 finally (return total-length)) 633 2 boundary-length 2 2))) 635 (defun write-multipart-content (content boundary stream) 636 (let ((boundary (string-to-octets boundary))) 637 (labels ((boundary-line (&optional endp) 638 (fast-write-sequence (string-to-octets "--") stream) 639 (fast-write-sequence boundary stream) 641 (fast-write-sequence (string-to-octets "--") stream)) 643 (crlf () (fast-write-sequence +crlf+ stream))) 644 (loop for (key . val) in content 646 (fast-write-sequence (string-to-octets (content-disposition key val)) stream) 647 (let ((content-type (multipart-value-content-type val))) 651 (format nil "Content-Type: ~A~C~C" content-type #\Return #\Newline)) 654 (write-as-octets stream val) 657 (boundary-line t))))) 659 (defun decompress-body (content-encoding body) 660 (unless content-encoding 661 (return-from decompress-body body)) 664 ((string= content-encoding "gzip") 666 (chipz:make-decompressing-stream :gzip body) 667 (chipz:decompress nil (chipz:make-dstate :gzip) body))) 668 ((string= content-encoding "deflate") 670 (chipz:make-decompressing-stream :zlib body) 671 (chipz:decompress nil (chipz:make-dstate :zlib) body))) 675 (defvar *use-connection-pool* t) 676 (defvar *max-active-connections* 8 677 "Allowed number of active connections to all hosts. If you change this, 678 then call (make-new-connection-pool).") 680 (defstruct lru-pool-elt 681 (prev nil :type (or null lru-pool-elt)) 682 (next nil :type (or null lru-pool-elt)) 685 (eviction-callback nil :type (or null function))) 687 ;; An LRU-POOL can have multiple entries for the same key 689 (lock #+sb-thread (sb-thread:make-mutex :name "connection pool lock") 691 (hash-table nil :type (or null hash-table)) ;; hash table entries are lists of elements 692 (head nil :type (or null lru-pool-elt)) ;; most recently used is here and it's a doubly-linked-list 693 (tail nil :type (or null lru-pool-elt)) ;; least recently used is here 694 (num-elts 0 :type fixnum) 695 (max-elts 8 :type fixnum)) 697 (defun make-connection-pool (&optional (max-active-connections *max-active-connections*)) 698 (make-lru-pool :hash-table (make-hash-table :test 'equal) :max-elts max-active-connections)) 700 (defvar *connection-pool* nil) 702 (defun make-new-connection-pool (&optional (max-active-connections *max-active-connections*)) 703 (clear-connection-pool) 704 (setf *connection-pool* (make-connection-pool max-active-connections))) 706 (defun get-from-lru-pool (lru-pool key) 707 "Takes an element from the LRU-POOL matching KEY. Must be called with LRU-POOL-LOCK held. 708 The element is removed from the pool." 709 (let* ((hash-table (lru-pool-hash-table lru-pool)) 710 (possible-elts (gethash key (lru-pool-hash-table lru-pool)))) 712 (let ((remaining-elts (cdr possible-elts))) 714 (setf (gethash key hash-table) remaining-elts) 715 (remhash key hash-table))) 716 (let ((elt (car possible-elts))) 717 (let ((prev (lru-pool-elt-prev elt)) 718 (next (lru-pool-elt-next elt))) 720 (setf (lru-pool-elt-next prev) next) 721 (setf (lru-pool-head lru-pool) next)) 723 (setf (lru-pool-elt-prev next) prev) 724 (setf (lru-pool-tail lru-pool) prev))) 725 (decf (lru-pool-num-elts lru-pool)) 726 (lru-pool-elt-elt elt))))) 728 (defun evict-tail (lru-pool) 729 "Removes the least recently used element of the LRU-POOL and returns 730 (values evicted-element eviction-callback t) if there was 731 an element to remove, otherwise nil. Must be called with LRU-POOL-LOCK held. 733 Outside the LRU-POOL-LOCK you must call the returned EVICTION-CALLBACK with the EVICTED-ELEMENT." 734 ;; slightly different from get-from-lru-pool because we want to get rid of the 735 ;; actual oldest element (one could in principle call get-from-lru-pool on 736 ;; (lru-pool-elt-key (lru-pool-tail lru-pool)) if you didn't care 737 (let* ((tail (lru-pool-tail lru-pool))) 739 (let ((prev (lru-pool-elt-prev tail))) 741 (setf (lru-pool-elt-next prev) nil) 742 (setf (lru-pool-head lru-pool) nil)) 743 (setf (lru-pool-tail lru-pool) prev) 744 (let* ((hash-table (lru-pool-hash-table lru-pool)) 745 (key (lru-pool-elt-key tail)) 746 (remaining (cl:delete tail (gethash key hash-table)))) 748 (setf (gethash key hash-table) remaining) 749 (remhash key hash-table)))) 750 (decf (lru-pool-num-elts lru-pool)) 751 (values (lru-pool-elt-elt tail) (lru-pool-elt-eviction-callback tail) t)))) 753 (defun add-to-lru-pool (lru-pool key elt eviction-callback) 754 "Adds ELT to an LRU-POOL with potentially non-unique KEY, potentially evicting another element to 755 make room. EVICTION-CALLBACK will be called with one parameter ELT, when ELT is evicted from the 756 LRU-POOL. ADD-TO-LRU-POOL must be called with LRU-POOL-LOCK held. 758 If an element was evicted to make space, returns (values evicted-elt eviction-callback t) 759 otherwise nil. The EVICTION-CALLBACK should take one parameter, the evicted element." 760 (declare (type lru-pool lru-pool)) 761 (let* ((old-head (lru-pool-head lru-pool)) 762 (lru-pool-elt (make-lru-pool-elt :prev nil :next old-head :elt elt :key key :eviction-callback eviction-callback)) 763 (hash-table (lru-pool-hash-table lru-pool))) 764 (setf (lru-pool-head lru-pool) lru-pool-elt) 765 (push lru-pool-elt (gethash key hash-table)) 767 (setf (lru-pool-elt-prev old-head) lru-pool-elt)) 768 (unless (lru-pool-tail lru-pool) 769 (setf (lru-pool-tail lru-pool) lru-pool-elt)) 770 (when (> (incf (lru-pool-num-elts lru-pool)) (lru-pool-max-elts lru-pool)) 771 (evict-tail lru-pool)))) 773 (defmethod print-object ((obj lru-pool-elt) str) ;; avoid printing loops 774 (print-unreadable-object (obj str :type "LRU-POOL-ELT") 775 (format str "~A NEXT ~A" (lru-pool-elt-key obj) (lru-pool-elt-next obj)))) 777 (defmethod print-object ((obj lru-pool) str) ;; avoid printing loops 778 (print-unreadable-object (obj str :type "LRU-POOL") 780 (loop with lru-pool-elt = (lru-pool-head obj) 782 do (push (list (lru-pool-elt-key lru-pool-elt) (lru-pool-elt-elt lru-pool-elt)) objs) 783 do (setf lru-pool-elt (lru-pool-elt-next lru-pool-elt))) 785 (format str "~A/~A elts~%~{ ~{~A~^: ~}~^~%~}" (lru-pool-num-elts obj) (lru-pool-max-elts obj) objs) 786 (format str "empty"))))) 788 (defmacro with-lock (lock &body body) 789 #+thread-support `(sb-thread:with-mutex (,lock) 791 #-thread-support `(progn ,@body)) 793 (defun push-connection (host-port stream &optional eviction-callback) 794 "Add STREAM back to connection pool with key HOST-PORT. EVICTION-CALLBACK 795 must be a function of a single parameter, and will be called with STREAM 796 if the HOST-PORT/SOCKET pair is evicted from the connection pool." 797 (when *use-connection-pool* 798 (let ((pool *connection-pool*)) 799 (multiple-value-bind (evicted-elt eviction-callback) 800 (with-lock (lru-pool-lock pool) 801 (add-to-lru-pool pool host-port stream eviction-callback)) 802 (and eviction-callback (funcall eviction-callback evicted-elt)) 805 (defun steal-connection (host-port) 806 "Return the STREAM associated with key HOST-PORT" 807 (when *use-connection-pool* 808 (let ((pool *connection-pool*)) 809 (with-lock (lru-pool-lock pool) 810 (get-from-lru-pool pool host-port))))) 812 (defun clear-connection-pool () 813 "Remove all elements from the connection pool, calling their eviction-callbacks." 814 (when *use-connection-pool* 815 (let ((pool *connection-pool*) 816 evicted-element eviction-callback element-was-evicted) 818 (loop for count from 0 819 do (setf (values evicted-element eviction-callback element-was-evicted) 820 (with-lock (lru-pool-lock pool) 822 do (when eviction-callback (funcall eviction-callback evicted-element)) 823 while element-was-evicted))))) 825 (make-new-connection-pool) 828 (with-compilation-unit () 829 (defparameter *ca-bundle* 830 (uiop:native-namestring #P"/etc/ca-certificates/extracted/ca-bundle.trust.crt") 831 "The default public root certificates used in requests.") 834 (defun read-until-crlf*2 (stream) 835 (fast-io:with-fast-output (buf) 838 (loop for byte of-type (or (unsigned-byte 8) null) = (read-byte stream nil nil) 840 do (fast-io:fast-write-byte byte buf) 843 until (= byte (char-code #\Return))) 846 (let ((next-byte (read-byte stream nil nil))) 849 (locally (declare (type (unsigned-byte 8) next-byte)) 851 ((= next-byte (char-code #\Newline)) 852 (fast-io:fast-write-byte next-byte buf) 854 ((= next-byte (char-code #\Return)) 855 (fast-io:fast-write-byte next-byte buf) 858 (fast-io:fast-write-byte next-byte buf) 862 (let ((next-byte (read-byte stream nil nil))) 865 (locally (declare (type (unsigned-byte 8) next-byte)) 867 ((= next-byte (char-code #\Return)) 868 (fast-io:fast-write-byte next-byte buf) 871 (fast-io:fast-write-byte next-byte buf) 875 (let ((next-byte (read-byte stream nil nil))) 878 (locally (declare (type (unsigned-byte 8) next-byte)) 880 ((= next-byte (char-code #\Newline)) 881 (fast-io:fast-write-byte next-byte buf)) 882 ((= next-byte (char-code #\Return)) 883 (fast-io:fast-write-byte next-byte buf) 886 (fast-io:fast-write-byte next-byte buf) 892 (make-array 0 :element-type '(unsigned-byte 8))) 894 (defun read-response (stream has-body collect-headers read-body) 895 (let* ((http (make-http-response)) 898 (headers-data (and collect-headers 899 (fast-io:make-output-buffer))) 900 (header-finished-p nil) 903 (transfer-encoding-p) 904 (parser (make-http-parser http 907 (setq header-finished-p t 908 content-length (gethash "content-length" headers) 909 transfer-encoding-p (gethash "transfer-encoding" headers)) 910 (unless (and has-body 912 transfer-encoding-p)) 915 (lambda (data start end) 917 (fast-io:fast-write-sequence data body-data start end))) 920 (setq finishedp t))))) 921 (let ((buf (read-until-crlf*2 stream))) 922 (declare (type octet-vector buf)) 923 (when collect-headers 924 (fast-io:fast-write-sequence buf headers-data)) 925 (funcall parser buf)) 926 (unless header-finished-p 927 (error "maybe invalid header")) 932 (setq body +empty-body+)) 933 ((and content-length (not transfer-encoding-p)) 934 (let ((buf (make-array (etypecase content-length 935 (integer content-length) 936 (string (parse-integer content-length))) 937 :element-type '(unsigned-byte 8)))) 938 (read-sequence buf stream) 940 ((let ((status (http-status http))) 941 (or (= status 100) ;; Continue 942 (= status 101) ;; Switching Protocols 943 (= status 204) ;; No Content 944 (= status 304))) ;; Not Modified 945 (setq body +empty-body+)) 947 (setq body-data (fast-io:make-output-buffer)) 948 (loop for buf of-type octet-vector = (read-until-crlf*2 stream) 949 do (funcall parser buf) 951 (zerop (length buf))) 953 (setq body (fast-io:finish-output-buffer body-data))))) 957 (fast-io:finish-output-buffer headers-data)) 958 transfer-encoding-p))) 960 (defun print-verbose-data (direction &rest data) 961 (flet ((boundary-line () 962 (let ((char (ecase direction 971 (map nil (lambda (byte) 972 (princ (code-char byte))) 976 (defun convert-body (body content-encoding content-type content-length chunkedp force-binary force-string keep-alive-p on-close) 979 ((and keep-alive-p chunkedp) 980 (setf body (make-keep-alive-stream body :chunked-stream 981 (let ((chunked-stream (chunga:make-chunked-stream body))) 982 (setf (chunga:chunked-stream-input-chunking-p chunked-stream) t) 983 chunked-stream) :on-close-or-eof on-close))) 984 ((and keep-alive-p content-length) 985 (setf body (make-keep-alive-stream body :end content-length :on-close-or-eof on-close))) 987 (let ((chunked-stream (chunga:make-chunked-stream body))) 988 (setf (chunga:chunked-stream-input-chunking-p chunked-stream) t) 989 (setf body chunked-stream))))) 990 (let ((body (decompress-body content-encoding body))) 993 (decode-body content-type body 994 :default-charset (if force-string 995 babel:*default-character-encoding* 998 (defun content-disposition (key val) 1000 (let* ((filename (file-namestring val)) 1001 (utf8-filename-p (find-if (lambda (char) 1002 (< 127 (char-code char))) 1004 (format nil "Content-Disposition: form-data; name=\"~A\"; ~:[filename=\"~A\"~;filename*=UTF-8''~A~]~C~C" 1008 (obj/uri:parse-uri filename) 1010 #\Return #\Newline)) 1011 (format nil "Content-Disposition: form-data; name=\"~A\"~C~C" 1013 #\Return #\Newline))) 1015 (defun build-cookie-headers (uri cookie-jar) 1016 (with-header-output (buffer) 1017 (let ((cookies (cookie-jar-host-cookies cookie-jar (uri-host uri) (or (uri-path uri) "/") 1018 :securep (string= (uri-scheme uri) "https")))) 1020 (fast-io:fast-write-sequence (string-to-octets "Cookie: ") buffer) 1021 (fast-io:fast-write-sequence 1022 (string-to-octets (write-cookie-header cookies)) 1024 (fast-io:fast-write-sequence +crlf+ buffer))))) 1026 (defun make-connect-stream (uri version stream &optional proxy-auth) 1027 (let ((header (fast-io:with-fast-output (buffer) 1028 (write-connect-header uri version buffer proxy-auth)))) 1029 (write-sequence header stream) 1030 (force-output stream) 1031 (read-until-crlf*2 stream) 1034 (defun make-proxy-authorization (uri) 1035 (let ((proxy-auth (obj/uri:uri-userinfo uri))) 1037 (format nil "Basic ~A" 1038 (dat/base64:string-to-base64-string proxy-auth))))) 1040 (defconstant +socks5-version+ 5) 1041 (defconstant +socks5-reserved+ 0) 1042 (defconstant +socks5-no-auth+ 0) 1043 (defconstant +socks5-connect+ 1) 1044 (defconstant +socks5-domainname+ 3) 1045 (defconstant +socks5-succeeded+ 0) 1046 (defconstant +socks5-ipv4+ 1) 1047 (defconstant +socks5-ipv6+ 4) 1049 (defun ensure-socks5-connected (input output uri http-method) 1050 (labels ((fail (condition &key reason) 1051 (error (make-condition condition 1052 :body nil :status nil :headers nil 1057 (unless (eql n (read-byte input nil 'eof)) 1058 (fail 'socks5-proxy-request-failed :reason reason))) 1061 (when (eq (read-byte input nil 'eof) 'eof) 1062 (fail 'socks5-proxy-request-failed :reason reason))))) 1063 ;; Send Version + Auth Method 1064 ;; Currently, only supports no-auth method. 1065 (write-byte +socks5-version+ output) 1066 (write-byte 1 output) 1067 (write-byte +socks5-no-auth+ output) 1068 (finish-output output) 1070 ;; Receive Auth Method 1071 (exact +socks5-version+ "Unexpected version") 1072 (exact +socks5-no-auth+ "Unsupported auth method") 1074 ;; Send domainname Request 1075 (let* ((host (babel:string-to-octets (uri-host uri))) 1076 (hostlen (length host)) 1077 (port (uri-port uri))) 1078 (unless (<= 1 hostlen 255) 1079 (fail 'socks5-proxy-request-failed :reason "domainname too long")) 1080 (unless (<= 1 port 65535) 1081 (fail 'socks5-proxy-request-failed :reason "Invalid port")) 1082 (write-byte +socks5-version+ output) 1083 (write-byte +socks5-connect+ output) 1084 (write-byte +socks5-reserved+ output) 1085 (write-byte +socks5-domainname+ output) 1086 (write-byte hostlen output) 1087 (write-sequence host output) 1088 (write-byte (ldb (byte 8 8) port) output) 1089 (write-byte (ldb (byte 8 0) port) output) 1090 (finish-output output) 1093 (exact +socks5-version+ "Unexpected version") 1094 (exact +socks5-succeeded+ "Unexpected result code") 1095 (drop 1 "Should be reserved byte") 1096 (let ((atyp (read-byte input nil 'eof))) 1098 ((eql atyp +socks5-ipv4+) 1099 (drop 6 "Should be IPv4 address and port")) 1100 ((eql atyp +socks5-ipv6+) 1101 (drop 18 "Should be IPv6 address and port")) 1102 ((eql atyp +socks5-domainname+) 1103 (let ((n (read-byte input nil 'eof))) 1105 (fail 'socks5-proxy-request-failed :reason "Invalid domainname length")) 1106 (drop n "Should be domainname and port"))) 1108 (fail 'socks5-proxy-request-failed :reason "Unknown address"))))))) 1110 (defun make-ssl-stream (stream ca-path ssl-key-file ssl-cert-file ssl-key-password hostname insecure) 1111 #+nil (declare (ignore stream ca-path ssl-key-file ssl-cert-file ssl-key-password hostname insecure)) 1112 #+nil (error "SSL not supported. Remove :dexador-no-ssl from *features* to enable SSL.") 1114 (cl+ssl:ensure-initialized) 1115 (let ((ctx (cl+ssl:make-context :verify-mode 1117 cl+ssl:+ssl-verify-none+ 1118 cl+ssl:+ssl-verify-peer+) 1122 (ca-path (uiop:native-namestring ca-path)) 1123 ((probe-file *ca-bundle*) *ca-bundle*) 1124 ;; In executable environment, perhaps *ca-bundle* doesn't exist. 1126 (ssl-cert-pem-p (and ssl-cert-file 1127 (std/seq:ends-with-subseq ".crt" ssl-cert-file)))) 1128 (cl+ssl:with-global-context (ctx :auto-free-p t) 1129 (when ssl-cert-pem-p 1130 (cl+ssl:use-certificate-chain-file ssl-cert-file)) 1131 (cl+ssl:make-ssl-client-stream stream 1133 :verify (not insecure) 1135 :certificate (and (not ssl-cert-pem-p) 1137 :password ssl-key-password))))) 1139 (defstruct usocket-wrapped-stream 1142 ;; Forward methods the user might want to use on this. 1143 ;; User is not meant to interact with this object except 1144 ;; potentially to close it when they decide they don't 1145 ;; need the :keep-alive connection anymore. 1146 (defmethod close ((u usocket-wrapped-stream) &key abort) 1147 (close (usocket-wrapped-stream-stream u) :abort abort)) 1149 (defmethod open-stream-p ((u usocket-wrapped-stream)) 1150 (open-stream-p (usocket-wrapped-stream-stream u))) 1152 (defun request (uri &rest args 1153 &key (method :get) (version 1.1) 1155 basic-auth bearer-auth 1157 (connect-timeout *default-connect-timeout*) (read-timeout *default-read-timeout*) 1158 (keep-alive t) (use-connection-pool t) 1160 ssl-key-file ssl-cert-file ssl-key-password 1161 stream (verbose *verbose*) 1165 (proxy *default-proxy*) 1169 (proxy-uri (and proxy (obj/uri:uri proxy))) 1170 (original-user-supplied-stream stream) 1171 (user-supplied-stream (if (usocket-wrapped-stream-p stream) (usocket-wrapped-stream-stream stream) stream))) 1172 (declare (ignorable ssl-key-file ssl-cert-file ssl-key-password 1175 (type fixnum max-redirects)) 1176 (with-content-caches 1177 (labels ((make-new-connection (uri) 1179 (let* ((con-uri (uri (or proxy uri))) 1180 (connection (usocket:socket-connect (uri-host con-uri) 1181 (or (uri-port con-uri) (when insecure 80) 443) 1182 :timeout connect-timeout 1183 :element-type '(unsigned-byte 8))) 1185 (usocket:socket-stream connection)) 1186 (scheme (uri-scheme uri))) 1187 (declare (type keyword scheme)) 1189 #+lispworks(setf (stream:stream-read-timeout stream) read-timeout) 1190 #-lispworks(setf (usocket:socket-option connection :receive-timeout) read-timeout)) 1191 (when (socks5-proxy-p proxy-uri) 1192 (ensure-socks5-connected stream stream uri method)) 1193 (if (string= (symbol-name scheme) "HTTPS") 1194 (make-ssl-stream (if (http-proxy-p proxy-uri) 1195 (make-connect-stream uri version stream (make-proxy-authorization con-uri)) 1196 stream) ca-path ssl-key-file ssl-cert-file ssl-key-password (uri-host uri) insecure) 1199 :report "Retry the same request." 1200 (return-from request 1201 (apply #'request uri :use-connection-pool nil args))) 1203 :report "Retry the same request without checking for SSL certificate validity." 1204 (return-from request 1205 (apply #'request uri :use-connection-pool nil :insecure t args))))) 1208 (let ((scheme (uri-scheme uri))) 1209 (and (stringp scheme) 1210 (or (string= scheme "http") 1211 (string= scheme "https")))))) 1212 (socks5-proxy-p (uri) 1214 (let ((scheme (uri-scheme uri))) 1215 (and (stringp scheme) 1216 (string= scheme "socks5"))))) 1217 (connection-keep-alive-p (connection-header) 1219 (or (and (= (the real version) 1.0) 1220 (equalp connection-header "keep-alive")) 1221 (not (equalp connection-header "close"))))) 1222 (return-stream-to-pool (stream uri) 1223 (push-connection (format nil "~A://~A" 1225 (uri-authority uri)) stream #'close)) 1226 (return-stream-to-pool-or-close (stream connection-header uri) 1227 (if (and (not user-supplied-stream) use-connection-pool (connection-keep-alive-p connection-header)) 1228 (return-stream-to-pool stream uri) 1229 (when (open-stream-p stream) 1231 (finalize-connection (stream connection-header uri) 1232 "If KEEP-ALIVE is in the connection-header and the user is not requesting a stream, 1233 we will push the connection to our connection pool if allowed, otherwise we return 1234 the stream back to the user who must close it." 1237 ((and use-connection-pool (connection-keep-alive-p connection-header) (not user-supplied-stream)) 1238 (return-stream-to-pool stream uri)) 1239 ((not (connection-keep-alive-p connection-header)) 1240 (when (open-stream-p stream) 1241 (close stream))))))) 1242 (let* ((uri (uri uri)) 1243 (proxy (when (http-proxy-p proxy-uri) proxy)) 1244 (content-type (cdr (find :content-type headers :key #'car :test #'string-equal))) 1245 (multipart-p (or (and content-type 1246 (>= (length content-type) 10) 1247 (string= content-type "multipart/" :end1 10)) 1248 (and (not content-type) 1250 (find-if #'pathnamep content :key #'cdr)))) 1251 (form-urlencoded-p (or (string= content-type "application/x-www-form-urlencoded") 1252 (and (not content-type) 1254 (not multipart-p)))) 1255 (boundary (and multipart-p 1256 (make-random-string 12))) 1257 (content (if (and form-urlencoded-p (not (stringp content))) ;; user can provide already encoded content, trust them. 1258 (obj/uri::url-encode-params content) 1260 (stream (or user-supplied-stream 1261 (and use-connection-pool 1262 (steal-connection (format nil "~A://~A" 1264 (uri-authority uri)))))) 1265 (reusing-stream-p (not (null stream))) ;; user provided or from connection-pool 1267 (make-new-connection uri))) 1269 (assoc :content-length headers :test #'string-equal)) 1271 (assoc :transfer-encoding headers :test #'string-equal)) 1272 (chunkedp (or (and transfer-encoding 1273 (equalp (cdr transfer-encoding) "chunked")) 1275 (null (cdr content-length))))) 1277 (fast-io:with-fast-output (buffer) 1278 (write-first-line method uri version buffer))) 1280 (flet ((write-header* (name value) 1281 (let ((header (assoc name headers :test #'string-equal))) 1284 (write-header name (cdr header))) 1285 (write-header name value))) 1287 (with-header-output (buffer) 1288 (write-header* :user-agent #.*default-user-agent*) 1289 (write-header* :host (uri-authority uri)) 1290 (write-header* :accept "*/*") 1293 (= (the real version) 1.0)) 1294 (write-header* :connection "keep-alive")) 1295 ((and (not keep-alive) 1296 (= (the real version) 1.1)) 1297 (write-header* :connection "close"))) 1298 (cond ((and bearer-auth basic-auth) 1299 (error "You should only use one Authorization header.")) 1301 (write-header* :authorization 1302 (format nil "Basic ~A" 1303 (dat/base64::string-to-base64-string 1306 (cdr basic-auth)))))) 1308 (write-header* :authorization 1309 (format nil "Bearer ~A" bearer-auth)))) 1311 (let ((scheme (uri-scheme uri))) 1312 (when (string= scheme "http") 1313 (let* ((uri (uri proxy)) 1314 (proxy-authorization (make-proxy-authorization uri))) 1315 (when proxy-authorization 1316 (write-header* :proxy-authorization proxy-authorization)))))) 1319 (write-header :content-type (format nil "~A; boundary=~A" 1320 (or content-type "multipart/form-data") 1323 (write-header :content-length 1324 (multipart-content-length content boundary)))) 1326 (write-header* :content-type "application/x-www-form-urlencoded") 1328 (write-header* :content-length (length (the string content))))) 1333 (write-header* :content-length 0))) 1335 (write-header* :content-type (or content-type "text/plain")) 1337 (write-header* :content-length (content-length content)))) 1338 ((array (unsigned-byte 8) *) 1339 (write-header* :content-type (or content-type "text/plain")) 1341 (write-header* :content-length (length content)))) 1343 (write-header* :content-type (or content-type (content-type content))) 1345 (write-header :content-length 1346 (or (cdr (assoc :content-length headers :test #'string-equal)) 1347 (content-length content)))))))) 1348 ;; Transfer-Encoding: chunked 1350 (not transfer-encoding)) 1351 (write-header* :transfer-encoding "chunked")) 1354 (loop for (name . value) in headers 1355 unless (member name '(:user-agent :host :accept 1357 :content-type :content-length) :test #'string-equal) 1358 do (write-header name value))))) 1359 (cookie-headers (and cookie-jar 1360 (build-cookie-headers uri cookie-jar)))) 1361 (macrolet ((maybe-try-again-without-reusing-stream (&optional (force nil)) 1362 `(progn ;; retrying by go retry avoids generating the header, parsing, etc. 1363 (when (open-stream-p stream) 1364 (close stream :abort t) 1367 (when ,(or force 'reusing-stream-p) 1368 (setf reusing-stream-p nil 1369 user-supplied-stream nil 1370 stream (make-new-connection uri)) 1372 (try-again-without-reusing-stream () 1373 `(maybe-try-again-without-reusing-stream t)) 1374 (with-retrying (&body body) 1376 (handler-bind (((and error 1377 ;; We should not retry errors received from the server. 1378 ;; Only technical errors such as disconnection or some 1379 ;; problems with the protocol should be retried automatically. 1380 ;; This solves https://github.com/fukamachi/dexador/issues/137 issue. 1381 (not http-request-failed)) 1383 (declare (ignorable e)) 1384 (maybe-try-again-without-reusing-stream)))) 1386 (retry-request () :report "Retry the same request." 1387 (return-from request (apply #'request uri args))) 1388 (ignore-and-continue () :report "Ignore the error and continue.")))) 1392 (unless (open-stream-p stream) 1393 (try-again-without-reusing-stream)) 1396 (write-sequence first-line-data stream) 1397 (write-sequence headers-data stream) 1398 (when cookie-headers 1399 (write-sequence cookie-headers stream)) 1400 (write-sequence +crlf+ stream) 1401 (force-output stream)) 1403 ;; Sending the content 1405 (let ((stream (if chunkedp 1406 (chunga:make-chunked-stream stream) 1409 (setf (chunga:chunked-stream-output-chunking-p stream) t)) 1412 (write-multipart-content content boundary stream) 1413 (write-as-octets stream content)) 1415 (setf (chunga:chunked-stream-output-chunking-p stream) nil)) 1416 (finish-output stream)))) 1419 (multiple-value-bind (http body response-headers-data transfer-encoding-p) 1421 (read-response stream (not (eq method :head)) verbose (not want-stream))) 1422 (let* ((status (http-status http)) 1423 (response-headers (http-headers http)) 1424 (content-length (gethash "content-length" response-headers)) 1425 (content-length (etypecase content-length 1426 (null content-length) 1427 (string (parse-integer content-length)) 1428 (integer content-length)))) 1431 (http-request-failed status 1437 (print-verbose-data :outgoing first-line-data headers-data cookie-headers +crlf+) 1438 (print-verbose-data :incoming response-headers-data)) 1440 (when-let ((set-cookies (append (gethash "set-cookie" response-headers) 1441 (ensure-list (gethash "set-cookie2" response-headers))))) 1442 (net/cookie::merge-cookies cookie-jar 1443 (remove nil (mapcar (lambda (cookie) 1444 (declare (type string cookie)) 1445 (unless (= (length cookie) 0) 1446 (net/cookie:parse-set-cookie-header cookie 1450 (when (and (member status '(301 302 303 307 308) :test #'=) 1451 (gethash "location" response-headers) 1452 (/= max-redirects 0)) 1453 ;; Need to read the response body 1454 (when (and want-stream 1455 (not (eq method :head))) 1457 ((integerp content-length) 1458 (dotimes (i content-length) 1459 (loop until (read-byte body nil nil)))) 1460 (transfer-encoding-p 1461 (read-until-crlf*2 body)))) 1463 (let* ((location-uri (uri (gethash "location" response-headers))) 1464 (same-server-p (or (null (uri-host location-uri)) 1465 (and (string= (uri-scheme location-uri) 1467 (string= (uri-host location-uri) 1469 (eql (uri-port location-uri) 1471 (if (and same-server-p 1472 (or (= status 307) (= status 308) 1473 (member method '(:get :head) :test #'eq))) 1474 (progn ;; redirection to the same host 1475 (setq uri (merge-uris location-uri uri)) 1476 (setq first-line-data 1477 (fast-io:with-fast-output (buffer) 1478 (write-first-line method uri version buffer))) 1480 ;; Rebuild cookie-headers. 1481 (setq cookie-headers (build-cookie-headers uri cookie-jar))) 1482 (decf max-redirects) 1483 (if (equalp (gethash "connection" response-headers) "close") 1484 (try-again-without-reusing-stream) 1486 (setq reusing-stream-p t) 1488 (progn ;; this is a redirection to a different host 1489 (setf location-uri (merge-uris location-uri uri)) 1490 ;; Close connection if it isn't from our connection pool or from the user and we aren't going to 1491 ;; pass it to our new call. 1492 (when (not same-server-p) (return-stream-to-pool-or-close stream (gethash "connection" response-headers) uri)) 1493 (setf (getf args :headers) 1494 (nconc `((:host . ,(uri-host location-uri))) headers)) 1495 (setf (getf args :max-redirects) 1497 ;; Redirect as GET if it's 301, 302, 303 1498 (unless (or (= status 307) (= status 308) 1499 (member method '(:get :head) :test #'eq)) 1500 (setf (getf args :method) :get)) 1501 (return-from request 1502 (apply #'request location-uri (if same-server-p 1504 (progn (remf args :stream) args)))))))) 1506 (let* ((keep-connection-alive (connection-keep-alive-p 1507 (gethash "connection" response-headers))) 1508 (body (convert-body body 1509 (gethash "content-encoding" response-headers) 1510 (gethash "content-type" response-headers) 1515 keep-connection-alive 1516 (if (and use-connection-pool keep-connection-alive (not user-supplied-stream) (streamp body)) 1517 (lambda (underlying-stream abort) 1518 (declare (ignore abort)) 1519 (when (and underlying-stream (open-stream-p underlying-stream)) 1520 ;; read any left overs the user may have not read (in case of errors on user side?) 1521 (loop while (ignore-errors (listen underlying-stream)) ;; ssl streams may close 1522 do (read-byte underlying-stream nil nil)) 1523 (when (open-stream-p underlying-stream) 1524 (push-connection (format nil "~A://~A" 1526 (uri-authority uri)) underlying-stream #'close)))) 1527 #'keep-alive-stream-close-underlying-stream)))) 1528 ;; Raise an error when the HTTP response status code is 4xx or 50x. 1529 (when (<= 400 status) 1531 (http-request-failed status 1533 :headers response-headers 1536 ;; Have to be a little careful with the fifth value stream we return -- 1537 ;; the user may be not aware that keep-alive t without use-connection-pool can leak 1538 ;; sockets, so we wrap the returned last value so when it is garbage 1539 ;; collected it gets closed. If the user is getting a stream back as BODY, 1540 ;; then we instead add a finalizer to that stream to close it when garbage collected 1541 (return-from request 1546 (when (and keep-alive 1547 (not (equalp (gethash "connection" response-headers) "close")) 1548 (or (not use-connection-pool) user-supplied-stream)) 1549 (or (and original-user-supplied-stream ;; user provided a stream 1550 (if (usocket-wrapped-stream-p original-user-supplied-stream) ;; but, it came from us 1551 (eql (usocket-wrapped-stream-stream original-user-supplied-stream) stream) ;; and we used it 1552 (eql original-user-supplied-stream stream)) ;; user provided a bare stream 1553 original-user-supplied-stream) ;; return what the user sent without wrapping it 1554 (if want-stream ;; add a finalizer to the body to close the stream 1556 (trivial-garbage:finalize body (lambda () (close stream))) 1558 (let ((wrapped-stream (make-usocket-wrapped-stream :stream stream))) 1559 (trivial-garbage:finalize wrapped-stream (lambda () (close stream))) 1560 wrapped-stream))))))) 1561 (finalize-connection stream (gethash "connection" response-headers) uri))))))))))) 1564 (defun get (uri &rest args 1565 &key version headers basic-auth bearer-auth cookie-jar keep-alive use-connection-pool 1566 connect-timeout read-timeout max-redirects 1567 force-binary force-string want-stream content 1568 ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path) 1569 "Make a GET request to URI and return 1570 (values body-or-stream status response-headers uri &optional opaque-socket-stream) 1572 You may pass a real stream in as STREAM if you want us to communicate with the server via it -- 1573 though if any errors occur, we will open a new connection to the server. If you have a previous 1574 OPAQUE-SOCKET-STREAM you can pass that in as STREAM as well and we will re-use that connection. 1576 OPAQUE-SOCKET-STREAM is not returned if USE-CONNECTION-POOL is T, instead we keep track of it and 1577 re-use it when needed. 1579 If WANT-STREAM is T, then a STREAM is returned as the first value. You may read this as needed to 1580 get the body of the response. If KEEP-ALIVE and USE-CONNECTION-POOL are T, then the stream will be 1581 returned to the connection pool when you have read all the data or closed the stream. If KEEP-ALIVE 1582 is NIL then you are responsible for closing the stream when done. 1584 If KEEP-ALIVE is T and USE-CONNECTION-POOL is NIL, then the fifth value returned is a stream which 1585 you can then pass in again using the STREAM option to re-use the active connection. If you ignore 1586 the stream, it will get closed during garbage collection. 1588 If KEEP-ALIVE is T and USE-CONNECTION-POOL is T, then there is no fifth 1589 value (OPAQUE-SOCKET-STREAM) returned, but the active connection to the host/port may be reused in 1590 subsequent calls. This removes the need for the caller to keep track of the active socket-stream 1591 for subsequent calls. 1593 While CONTENT is allowed in a GET request the results are ill-defined and not advised." 1594 (declare (ignore version headers basic-auth bearer-auth cookie-jar keep-alive use-connection-pool 1595 connect-timeout read-timeout max-redirects force-binary force-string want-stream 1596 ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path content)) 1597 (apply #'request uri :method :get args)) 1599 (defun post (uri &rest args 1600 &key version content headers basic-auth bearer-auth cookie-jar keep-alive 1601 use-connection-pool connect-timeout read-timeout 1602 force-binary force-string want-stream 1603 ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path) 1604 (declare (ignore version content headers basic-auth bearer-auth cookie-jar keep-alive 1605 use-connection-pool connect-timeout read-timeout force-binary force-string 1606 want-stream ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy 1608 (apply #'request uri :method :post args)) 1610 (defun head (uri &rest args 1611 &key version headers basic-auth bearer-auth cookie-jar connect-timeout read-timeout max-redirects 1612 ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path) 1613 (declare (ignore version headers basic-auth bearer-auth cookie-jar connect-timeout read-timeout 1614 max-redirects ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path)) 1615 (apply #'request uri :method :head :use-connection-pool nil args)) 1617 (defun put (uri &rest args 1618 &key version content headers basic-auth bearer-auth cookie-jar keep-alive 1619 use-connection-pool connect-timeout read-timeout 1620 force-binary force-string want-stream 1621 ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path) 1622 (declare (ignore version content headers basic-auth bearer-auth cookie-jar keep-alive 1623 use-connection-pool connect-timeout read-timeout force-binary force-string 1624 want-stream ssl-key-file ssl-cert-file ssl-key-password stream verbose 1625 proxy insecure ca-path)) 1626 (apply #'request uri :method :put args)) 1628 (defun patch (uri &rest args 1629 &key version content headers basic-auth bearer-auth cookie-jar keep-alive 1630 use-connection-pool connect-timeout read-timeout 1631 force-binary force-string want-stream 1632 ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path) 1633 (declare (ignore version content headers basic-auth bearer-auth cookie-jar keep-alive 1634 use-connection-pool connect-timeout read-timeout force-binary force-string 1635 want-stream ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy 1637 (apply #'request uri :method :patch args)) 1639 (defun delete (uri &rest args 1640 &key version headers basic-auth bearer-auth cookie-jar keep-alive 1641 use-connection-pool connect-timeout read-timeout 1642 force-binary force-string want-stream content 1643 ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path) 1644 (declare (ignore version headers basic-auth bearer-auth cookie-jar keep-alive use-connection-pool 1645 connect-timeout read-timeout force-binary force-string want-stream ssl-key-file 1646 ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path content)) 1647 (apply #'request uri :method :delete args)) 1649 (defun fetch (uri destination &rest args 1650 &key (if-exists :error) 1651 version headers basic-auth bearer-auth cookie-jar keep-alive use-connection-pool 1652 connect-timeout read-timeout max-redirects 1653 ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path) 1654 (declare (ignore version headers basic-auth bearer-auth cookie-jar keep-alive use-connection-pool 1655 connect-timeout read-timeout max-redirects ssl-key-file ssl-cert-file 1656 ssl-key-password stream verbose proxy insecure ca-path)) 1657 (unless (and (eql if-exists nil) 1658 (probe-file destination)) 1659 (with-open-file (out destination 1660 :direction :output :element-type '(unsigned-byte 8) 1661 :if-exists if-exists 1662 :if-does-not-exist :create) 1663 (remf args :if-exists) 1664 (let ((body (apply #'req:get uri :want-stream t :force-binary t 1666 (alexandria:copy-stream body out) 1667 ;; Nominally the body gets closed, but if keep-alive is nil we need to explicitly do it. 1668 (when (open-stream-p body) 1671 (defun ignore-and-continue (e) 1672 (let ((restart (find-restart 'ignore-and-continue e))) 1674 (invoke-restart restart)))) 1676 (defun retry-request (times &key (interval 3)) 1677 (declare (type (or function integer) interval)) 1680 (let ((restart (find-restart 'retry-request times))) 1682 (invoke-restart restart)))) 1684 (retry-request-ntimes times :interval interval)))) 1686 (defun retry-request-ntimes (n &key (interval 3)) 1687 (declare (type integer n) 1688 (type (or function integer) interval)) 1690 (declare (type integer retries)) 1692 (declare (type condition e)) 1693 (let ((restart (find-restart 'retry-request e))) 1698 (function (funcall interval retries)) 1699 (integer (sleep interval))) 1700 (invoke-restart restart)))))))