Mercurial > core / lisp/lib/net/proto/http.lisp
changeset 698: |
96958d3eb5b0 |
parent: |
4d8451fe5423
|
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Fri, 04 Oct 2024 22:04:59 -0400 |
permissions: |
-rw-r--r-- |
description: |
fixes |
1 ;;; lib/net/proto/http.lisp --- HTTP Support 3 ;; based on https://github.com/fukamachi/fast-http 5 ;; see also: https://github.com/orthecreedence/http-parse 9 ;; Fukamachi has implemented the current state-of-the-art HTTP libraries 10 ;; (fast-http, dexador, etc). For the time being we'll be using these with 14 (in-package :net/proto/http) 17 (deftype status-code () '(integer 0 10000)) 20 (defconstant +state-first-line+ 0) 21 (defconstant +state-headers+ 1) 22 (defconstant +state-chunk-size+ 2) 23 (defconstant +state-body+ 3) 24 (defconstant +state-chunk-body-end-crlf+ 4) 25 (defconstant +state-trailing-headers+ 5) 27 (defstruct (http (:conc-name :http-)) 28 (method nil :type symbol) 29 (major-version 0 :type fixnum) 30 (minor-version 9 :type fixnum) 31 (status 0 :type status-code) 32 (content-length nil :type (or null integer)) 33 (chunked-p nil :type boolean) 34 (upgrade-p nil :type boolean) 39 (header-read 0 :type fixnum) 40 (mark -1 :type fixnum) 41 (state +state-first-line+ :type fixnum)) 43 (defun http-version (http) 45 (+ (http-major-version http) 46 (/ (http-minor-version http) 10)))) 48 (defstruct (http-request (:include http) 52 (defstruct (http-response (:include http) 57 (define-condition http-error (protocol-error) 60 (lambda (condition stream) 61 (format stream "~A: ~A" (type-of condition) (slot-value condition 'description))))) 64 ;; Callback-related errors 66 (define-condition callback-error (http-error) 67 ((error :initarg :error 69 (:report (lambda (condition stream) 70 (with-slots (description error) condition 71 (format stream "Callback Error: ~A~:[~;~:*~% ~A~]" 75 (define-condition cb-message-begin (callback-error) 76 ((description :initform "the message-begin callback failed"))) 77 (define-condition cb-url (callback-error) 78 ((description :initform "the url callback failed"))) 79 (define-condition cb-first-line (callback-error) 80 ((description :initform "the first line callback failed"))) 81 (define-condition cb-header-field (callback-error) 82 ((description :initform "the header-field callback failed"))) 83 (define-condition cb-header-value (callback-error) 84 ((description :initform "the header-value callback failed"))) 85 (define-condition cb-headers-complete (callback-error) 86 ((description :initform "the headers-complete callback failed"))) 87 (define-condition cb-body (callback-error) 88 ((description :initform "the body callback failed"))) 89 (define-condition cb-message-complete (callback-error) 90 ((description :initform "the message-complete callback failed"))) 91 (define-condition cb-status (callback-error) 92 ((description :initform "the status callback failed"))) 95 ;; Parsing-related errors 97 (define-condition parsing-error (http-error) ()) 99 (define-condition invalid-eof-state (parsing-error) 100 ((description :initform "stream ended at an unexpected time"))) 101 (define-condition header-overflow (parsing-error) 102 ((description :initform "too many header bytes seen; overflow detected"))) 103 (define-condition closed-connection (parsing-error) 104 ((description :initform "data received after completed connection: close message"))) 105 (define-condition invalid-version (parsing-error) 106 ((description :initform "invalid HTTP version"))) 107 (define-condition invalid-status (parsing-error) 108 ((description :initform "invalid HTTP status code") 109 (status-code :initarg :status-code 111 (:report (lambda (condition stream) 112 (with-slots (description status-code) condition 113 (format stream "~A: ~A~:[~;~:* (Code=~A)~]" 117 (define-condition invalid-method (parsing-error) 118 ((description :initform "invalid HTTP method"))) 119 (define-condition invalid-url (parsing-error) 120 ((description :initform "invalid URL"))) 121 (define-condition invalid-host (parsing-error) 122 ((description :initform "invalid host"))) 123 (define-condition invalid-port (parsing-error) 124 ((description :initform "invalid port"))) 125 (define-condition invalid-path (parsing-error) 126 ((description :initform "invalid path"))) 127 (define-condition invalid-query-string (parsing-error) 128 ((description :initform "invalid query string"))) 129 (define-condition invalid-fragment (parsing-error) 130 ((description :initform "invalid fragment"))) 131 (define-condition lf-expected (parsing-error) 132 ((description :initform "LF character expected"))) 133 (define-condition invalid-header-token (parsing-error) 134 ((description :initform "invalid character in header"))) 135 (define-condition invalid-content-length (parsing-error) 136 ((description :initform "invalid character in content-length header"))) 137 (define-condition invalid-chunk-size (parsing-error) 138 ((description :initform "invalid character in chunk size header"))) 139 (define-condition invalid-constant (parsing-error) 140 ((description :initform "invalid constant string"))) 142 (define-condition invalid-internal-state (parsing-error) 143 ((description :initform "encountered unexpected internal state") 144 (code :initarg :code)) 146 (lambda (condition stream) 147 (format stream "~A: ~A (Code=~A)" 149 (slot-value condition 'description) 150 (slot-value condition 'code))))) 151 (define-condition strict-error (parsing-error) 152 ((description :initform "strict mode assertion failed") 153 (form :initarg :form)) 155 (lambda (condition stream) 156 (format stream "~A: ~A~% ~A" 158 (slot-value condition 'description) 159 (slot-value condition 'form))))) 160 (define-condition paused-error (parsing-error) 161 ((description :initform "parser is paused"))) 162 (define-condition unknown-error (parsing-error) 163 ((description :initform "an unknown error occured"))) 169 (define-condition multipart-parsing-error (http-error) ()) 171 (define-condition invalid-multipart-body (multipart-parsing-error) 172 ((description :initform "invalid multipart body"))) 173 (define-condition invalid-boundary (multipart-parsing-error) 174 ((description :initform "invalid boundary"))) 178 ;; Header value parsing 180 (define-condition header-value-parsing-error (multipart-parsing-error) ()) 182 (define-condition invalid-header-value (header-value-parsing-error) 183 ((description :initform "invalid header value"))) 184 (define-condition invalid-parameter-key (header-value-parsing-error) 185 ((description :initform "invalid parameter key"))) 186 (define-condition invalid-parameter-value (header-value-parsing-error) 187 ((description :initform "invalid parameter value"))) 190 (defmacro casev (keyform &body clauses) 192 (flet ((get-val (val) 194 ((eq val 'otherwise) val) 195 ((symbolp val) (symbol-value val)) 196 ((constantp val) val) 197 (T (error "CASEV can be used only with variables or constants"))))) 199 ,@(loop for (val . clause) in clauses 200 if (eq val 'otherwise) 201 collect `(otherwise ,@clause) 203 collect `((,@(mapcar #'get-val val)) ,@clause) 205 collect `(,(get-val val) ,@clause)))))) 207 (defmacro casev= (keyform &body clauses) 209 (flet ((get-val (val) 211 ((eq val 'otherwise) val) 212 ((symbolp val) (symbol-value val)) 213 ((constantp val) val) 214 (T (error "CASEV can be used only with variables or constants"))))) 216 ,@(loop for (val . clause) in clauses 217 if (eq val 'otherwise) 218 collect `(T ,@clause) 220 collect `((or ,@(mapcar (lambda (val) 221 `(= ,keyform ,(get-val val))) 225 collect `((= ,keyform ,(get-val val)) ,@clause)))))) 227 (defmacro case-byte (byte &body cases) 229 ,@(loop for (val . form) in cases 230 if (eq val 'otherwise) 231 collect `(,val ,@form) 233 collect `(,(mapcar #'char-code val) ,@form) 235 collect `(,(char-code val) ,@form)))) 237 (defmacro tagcase (keyform &body blocks) 238 (let ((end (gensym "END"))) 241 ,@(loop for (tag . body) in blocks 242 if (eq tag 'otherwise) 243 collect `(otherwise ,@body (go ,end)) 245 collect `(,tag (go ,(if (listp tag) (car tag) tag))))) 247 ,@(loop for (tag . body) in blocks 252 collect `(progn ,@body 256 (defmacro tagcasev (keyform &body blocks) 257 (let ((end (gensym "END"))) 260 ,@(loop for (tag . body) in blocks 261 if (eq tag 'otherwise) 262 collect `(otherwise ,@body (go ,end)) 264 collect `(,tag (go ,(if (listp tag) (car tag) tag))))) 266 ,@(loop for (tag . body) in blocks 269 else if (not (eq tag 'otherwise)) 271 collect `(progn ,@body 275 (defmacro tagcasev= (keyform &body blocks) 276 (let ((end (gensym "END"))) 279 ,@(loop for (tag . body) in blocks 280 if (eq tag 'otherwise) 281 collect `(otherwise ,@body (go ,end)) 283 collect `(,tag (go ,(if (listp tag) (car tag) tag))))) 285 ,@(loop for (tag . body) in blocks 288 else if (not (eq tag 'otherwise)) 290 collect `(progn ,@body 294 (defun make-collector () 295 (let ((none '#:none)) 296 (declare (dynamic-extent none)) 297 (with-collectors (buffer) 298 (return-from make-collector 299 (lambda (&optional (data none)) 300 (unless (eq data none) 304 (declaim (inline %whitespacep)) 305 (defun %whitespacep (char) 306 (declare (type character char) 307 (optimize (speed 3) (safety 0))) 308 (or (char= char #\Space) 311 (declaim (inline position-not-whitespace)) 312 (defun position-not-whitespace (string &key from-end) 313 (declare (type simple-string string) 314 (optimize (speed 3) (safety 0))) 315 (let* ((len (length string)) 316 (start (if from-end (1- len) 0)) 317 (end (if from-end 0 (1- len))) 318 (step-fn (if from-end #'1- #'1+))) 319 (declare (type integer len start end)) 320 (do ((i start (funcall step-fn i))) 322 (declare (type integer i)) 323 (unless (%whitespacep (aref string i)) 324 (return-from position-not-whitespace i))))) 326 (declaim (inline number-string-p)) 327 (defun number-string-p (string) 328 (declare (type simple-string string) 329 (optimize (speed 3) (safety 2))) 331 (when (zerop (length string)) 332 (return-from number-string-p nil)) 333 (let ((end (position-not-whitespace string :from-end t)) 337 ;; (return-from number-string-p)) 338 (locally (declare (type integer end) 339 (optimize (safety 0))) 341 (do ((i (the integer (or (position-not-whitespace string) 0)) (1+ i))) 343 (declare (type integer i)) 344 (let ((char (aref string i))) 345 (declare (type character char)) 348 (return-from number-string-p nil)) 349 ((digit-char-p char)) 352 (return-from number-string-p nil)) 354 (T (return-from number-string-p nil)))))))) 357 (defun make-http-parser (http &key first-line-callback header-callback body-callback finish-callback (head-request nil)) 358 (declare (type http http)) 361 (parse-fn (etypecase http 362 (http-request #'parse-request) 363 (http-response #'parse-response))) 367 (header-value-buffer nil) 373 (flet ((collect-prev-header-value () 374 (when header-value-buffer 376 (locally (declare (optimize (speed 3) (safety 0))) 378 (the (or octet-concatenated-xsubseqs octet-xsubseq) header-value-buffer))))) 380 (if (string= parsing-header-field "set-cookie") 381 (push header-value (gethash "set-cookie" headers)) 382 (multiple-value-bind (previous-value existp) 383 (gethash (the simple-string parsing-header-field) headers) 384 (setf (gethash (the simple-string parsing-header-field) headers) 386 (if (simple-string-p previous-value) 387 (concatenate 'string (the simple-string previous-value) ", " header-value) 388 (format nil "~A, ~A" previous-value header-value)) 392 :message-begin (lambda (http) 393 (declare (ignore http)) 394 (setq headers (make-hash-table :test 'equal) 395 header-complete-p nil 397 :url (lambda (http data start end) 398 (declare (type octet-vector data) 399 (type pointer start end)) 400 (setf (http-resource http) 401 (ascii-octets-to-string data :start start :end end))) 402 :status (lambda (http data start end) 403 (declare (type octet-vector data) 404 (type pointer start end)) 405 (setf (http-status-text http) 406 (ascii-octets-to-string data :start start :end end))) 407 :first-line (and first-line-callback 409 (declare (ignore http)) 410 (funcall (the function first-line-callback)))) 411 :header-field (lambda (http data start end) 412 (declare (ignore http) 413 (type octet-vector data) 414 (type pointer start end)) 415 (collect-prev-header-value) 416 (setq header-value-buffer (make-concatenated-xsubseqs)) 417 (setq parsing-header-field 418 (ascii-octets-to-lower-string data :start start :end end))) 419 :header-value (lambda (http data start end) 420 (declare (ignore http) 421 (type octet-vector data) 422 (type pointer start end)) 423 (xnconcf header-value-buffer 424 (xsubseq (subseq (the octet-vector data) start end) 0))) 425 :headers-complete (lambda (http) 426 (collect-prev-header-value) 427 (setq header-value-buffer nil) 428 (when (gethash "set-cookie" headers) 429 (setf (gethash "set-cookie" headers) 430 (nreverse (gethash "set-cookie" headers)))) 431 (setf (http-headers http) headers) 432 (when header-callback 433 (funcall (the function header-callback) headers)) 434 (when (and (not (http-chunked-p http)) 435 (not (numberp (http-content-length http)))) 437 (setq header-complete-p t)) 438 :body (and body-callback 439 (lambda (http data start end) 440 (declare (ignore http) 441 (type octet-vector data) 442 (type pointer start end)) 443 (funcall (the function body-callback) 445 :message-complete (lambda (http) 446 (declare (ignore http)) 447 (collect-prev-header-value) 448 (when finish-callback 449 (funcall (the function finish-callback))) 450 (setq completedp t))))) 452 (lambda (data &key (start 0) end) 453 (declare (optimize (speed 3) (safety 2))) 457 (when finish-callback 458 (funcall (the function finish-callback)))) 460 (locally (declare (type octet-vector data) 461 (type pointer start)) 462 (check-type end (or null pointer)) 466 (xnconc (xsubseq data-buffer 0) 467 (xsubseq (the octet-vector data) start (or end (length data)))))) 468 (setq data-buffer nil 471 (setf (http-mark http) start) 473 (funcall parse-fn http callbacks (the octet-vector data) :start start :end end :head-request head-request) 476 (subseq data (http-mark http) (or end (length data))))))))) 477 (values http header-complete-p completedp)))) 479 (defun find-boundary (content-type) 480 (declare (type string content-type)) 481 (let ((parsing-boundary nil)) 482 (parse-header-value-parameters content-type 483 :header-value-callback 484 (lambda (data start end) 485 (unless (string= data "multipart/form-data" 486 :start1 start :end1 end) 487 (return-from find-boundary nil))) 488 :header-parameter-key-callback 489 (lambda (data start end) 490 (when (string= data "boundary" 491 :start1 start :end1 end) 492 (setq parsing-boundary t))) 493 :header-parameter-value-callback 494 (lambda (data start end) 495 (when parsing-boundary 496 (return-from find-boundary (subseq data start end))))))) 499 (defconstant +cr+ (char-code #\Return)) 500 (defconstant +lf+ (char-code #\Linefeed)) 501 (defconstant +space+ (char-code #\Space)) 502 (defconstant +tab+ (char-code #\Tab)) 503 (defconstant +page+ (char-code #\Page)) 504 (defconstant +dash+ #.(char-code #\-)) 506 (define-constant +crlf+ 507 (make-array 2 :element-type '(unsigned-byte 8) 508 :initial-contents (list +cr+ +lf+)) 511 (deftype octet-vector (&optional (len '*)) 512 `(simple-array (unsigned-byte 8) (,len))) 514 (declaim (inline digit-byte-char-p 515 digit-byte-char-to-integer 517 alpha-byte-char-to-lower-char 518 alphanumeric-byte-char-p 521 (defun digit-byte-char-p (byte) 522 (declare (type (unsigned-byte 8) byte) 523 (optimize (speed 3) (safety 0))) 524 (<= #.(char-code #\0) byte #.(char-code #\9))) 526 (declaim (ftype (function ((unsigned-byte 8)) fixnum) digit-byte-char-to-integer)) 527 (defun digit-byte-char-to-integer (byte) 528 (declare (type (unsigned-byte 8) byte) 529 (optimize (speed 3) (safety 0))) 530 (the fixnum (- byte #.(char-code #\0)))) 532 (defun alpha-byte-char-p (byte) 533 (declare (type (unsigned-byte 8) byte) 534 (optimize (speed 3) (safety 0))) 535 (or (<= #.(char-code #\A) byte #.(char-code #\Z)) 536 (<= #.(char-code #\a) byte #.(char-code #\z)))) 538 (defun alpha-byte-char-to-lower-char (byte) 539 (declare (type (unsigned-byte 8) byte) 540 (optimize (speed 3) (safety 0))) 543 ((<= #.(char-code #\A) byte #.(char-code #\Z)) 544 (code-char (+ byte #x20))) 545 (T #+nil(<= #.(char-code #\a) byte #.(char-code #\z)) 548 (defun alphanumeric-byte-char-p (byte) 549 (declare (type (unsigned-byte 8) byte)) 550 (or (alpha-byte-char-p byte) 551 (digit-byte-char-p byte))) 553 (defun mark-byte-char-p (byte) 554 (declare (type (unsigned-byte 8) byte) 555 (optimize (speed 3) (safety 0))) 556 (or (= byte #.(char-code #\-)) 557 (= byte #.(char-code #\_)) 558 (= byte #.(char-code #\.)) 559 (= byte #.(char-code #\!)) 560 (= byte #.(char-code #\~)) 561 (= byte #.(char-code #\*)) 562 (= byte #.(char-code #\')) 563 (= byte #.(char-code #\()) 564 (= byte #.(char-code #\))))) 566 (declaim (ftype (function ((unsigned-byte 8)) (unsigned-byte 8)) byte-to-ascii-lower) 567 (inline byte-to-ascii-lower)) 568 (defun byte-to-ascii-lower (x) 569 (declare (type (unsigned-byte 8) x) 570 (optimize (speed 3) (safety 0))) 571 (if (<= #.(char-code #\A) x #.(char-code #\Z)) 572 (- x #.(- (char-code #\A) (char-code #\a))) 575 (declaim (inline ascii-octets-to-string)) 576 (defun ascii-octets-to-string (octets &key (start 0) (end (length octets))) 577 (declare (type octet-vector octets) 578 (type (unsigned-byte 64) start end) 579 (optimize (speed 3) (safety 0))) 580 (let* ((len (the (unsigned-byte 64) (- end start))) 581 (string (make-string len :element-type 'character))) 582 (declare (type (unsigned-byte 64) len) 583 (type simple-string string)) 587 (setf (aref string i) 588 (code-char (aref octets j)))))) 590 (declaim (inline ascii-octets-to-lower-string)) 591 (defun ascii-octets-to-lower-string (octets &key (start 0) (end (length octets))) 592 (declare (type octet-vector octets) 593 (type (unsigned-byte 64) start end) 594 (optimize (speed 3) (safety 0))) 595 (let* ((len (the (unsigned-byte 64) (- end start))) 596 (string (make-string len :element-type 'character))) 597 (declare (type (unsigned-byte 64) len) 598 (type simple-string string)) 602 (setf (aref string i) 603 (code-char (byte-to-ascii-lower (aref octets j))))))) 605 (defun append-byte-vectors (vec1 vec2) 606 (declare (type octet-vector vec1 vec2) 607 (optimize (speed 3) (safety 0))) 608 (let* ((vec1-len (length vec1)) 609 (vec2-len (length vec2)) 610 (result (make-array (+ vec1-len vec2-len) 611 :element-type '(unsigned-byte 8)))) 612 (declare (type octet-vector result)) 613 (replace result vec1 :start1 0) 614 (replace result vec2 :start1 vec1-len) 618 (defstruct (ll-multipart-parser (:constructor make-ll-multipart-parser 621 (let ((parser (make-http))) 622 (setf (http-state parser) +state-headers+) 624 (state 0 :type fixnum) 632 #.`(eval-when (:compile-toplevel :load-toplevel :execute) 634 for state in '(parsing-delimiter-dash-start 635 parsing-delimiter-dash 637 parsing-delimiter-end 638 parsing-delimiter-almost-done 639 parsing-delimiter-done 642 looking-for-delimiter 643 maybe-delimiter-start 644 maybe-delimiter-first-dash 645 maybe-delimiter-second-dash 648 collect `(defconstant ,(format-symbol t "+~A+" state) ,i))) 650 (defun http-multipart-parse (parser callbacks data &key (start 0) end) 651 (declare (type octet-vector data)) 652 (let* ((end (or end (length data))) 653 (boundary (map '(simple-array (unsigned-byte 8) (*)) #'char-code (ll-multipart-parser-boundary parser))) 654 (boundary-length (length boundary)) 655 (header-parser (ll-multipart-parser-header-parser parser))) 656 (declare (type octet-vector boundary)) 658 (return-from http-multipart-parse start)) 660 (macrolet ((with-body-cb (callback &body body) 661 `(handler-case (when-let ((,callback (callbacks-body callbacks))) 664 (error 'cb-body :error e)))) 665 (call-body-cb (&optional (end '(ll-multipart-parser-boundary-mark parser))) 666 (let ((g-end (gensym "END"))) 667 `(with-body-cb callback 668 (when (ll-multipart-parser-body-buffer parser) 669 (funcall callback parser 670 (ll-multipart-parser-body-buffer parser) 671 0 (length (ll-multipart-parser-body-buffer parser))) 672 (setf (ll-multipart-parser-body-buffer parser) nil)) 673 (when-let ((,g-end ,end)) 674 (funcall callback parser data 675 (ll-multipart-parser-body-mark parser) 677 (flush-boundary-buffer () 678 `(with-body-cb callback 679 (when (ll-multipart-parser-boundary-buffer parser) 680 (funcall callback parser 681 (ll-multipart-parser-boundary-buffer parser) 682 0 (length (ll-multipart-parser-boundary-buffer parser))) 683 (setf (ll-multipart-parser-boundary-buffer parser) nil))))) 685 (byte (aref data p))) 687 (log:debug (code-char byte)) 689 (macrolet ((go-state (tag &optional (advance 1)) 694 (otherwise `(incf p ,advance))) 695 (setf (ll-multipart-parser-state parser) ,tag) 697 (log:debug ,(princ-to-string tag)) 698 ,@(and (not (eql advance 0)) 701 (setq byte (aref data p)) 703 (log:debug (code-char byte)))) 705 (tagcasev (ll-multipart-parser-state parser) 706 (+parsing-delimiter-dash-start+ 707 (unless (= byte +dash+) 708 (go-state +header-field-start+ 0)) 709 (go-state +parsing-delimiter-dash+)) 711 (+parsing-delimiter-dash+ 712 (unless (= byte +dash+) 713 (error 'invalid-multipart-body)) 714 (go-state +parsing-delimiter+)) 717 (let ((end2 (+ p boundary-length))) 719 ((ll-multipart-parser-boundary-buffer parser) 720 (when (< (+ end (length (ll-multipart-parser-boundary-buffer parser)) -3) end2) 721 (setf (ll-multipart-parser-boundary-buffer parser) 722 (concatenate 'octet-vector 723 (ll-multipart-parser-boundary-buffer parser) 726 (let ((data2 (make-array boundary-length :element-type '(unsigned-byte 8))) 727 (boundary-buffer-length (length (ll-multipart-parser-boundary-buffer parser)))) 728 (replace data2 (ll-multipart-parser-boundary-buffer parser) 731 :start1 (- boundary-buffer-length 2)) 732 (unless (search boundary data2) 734 (when (ll-multipart-parser-body-mark parser) 736 (flush-boundary-buffer) 737 (go-state +looking-for-delimiter+)) 738 (error 'invalid-boundary)) 739 (go-state +parsing-delimiter-end+ (- boundary-length boundary-buffer-length -2)))) 742 (setf (ll-multipart-parser-boundary-buffer parser) 743 (if (ll-multipart-parser-boundary-buffer parser) 744 (concatenate 'octet-vector 745 (ll-multipart-parser-boundary-buffer parser) 746 (subseq data (max 0 (- p 2)))) 747 (subseq data (max 0 (- p 2))))) 750 (unless (search boundary data :start2 p :end2 end2) 752 (when (ll-multipart-parser-body-mark parser) 753 (go-state +looking-for-delimiter+)) 754 (error 'invalid-boundary)) 755 (go-state +parsing-delimiter-end+ boundary-length))))) 757 (+parsing-delimiter-end+ 759 (+cr+ (go-state +parsing-delimiter-almost-done+)) 760 (+lf+ (go-state +parsing-delimiter-almost-done+ 0)) 761 (+dash+ (go-state +body-almost-done+)) 764 (when (ll-multipart-parser-body-mark parser) 766 (flush-boundary-buffer) 767 (go-state +looking-for-delimiter+)) 768 (error 'invalid-boundary)))) 770 (+parsing-delimiter-almost-done+ 771 (unless (= byte +lf+) 772 (error 'invalid-boundary)) 773 (when (ll-multipart-parser-body-mark parser) 775 (when (ll-multipart-parser-boundary-mark parser) 777 (when-let ((callback (callbacks-message-complete callbacks))) 778 (handler-case (funcall callback parser) 780 (error 'cb-message-complete :error e))))) 781 (go-state +parsing-delimiter-done+)) 783 (+parsing-delimiter-done+ 784 (when-let ((callback (callbacks-message-begin callbacks))) 785 (handler-case (funcall callback parser) 787 (error 'cb-message-begin :error e)))) 788 (setf (ll-multipart-parser-body-mark parser) p) 789 (go-state +header-field-start+ 0)) 791 (+header-field-start+ 792 (let ((next (parse-headers header-parser callbacks data p end))) 793 (setq p (1- next)) ;; XXX 794 ;; parsing headers done 795 (when (= (http-state header-parser) +state-body+) 796 (when-let ((callback (callbacks-headers-complete callbacks))) 797 (handler-case (funcall callback parser) 799 (error 'cb-headers-complete :error e)))) 800 (setf (http-state header-parser) +state-headers+)) 801 (go-state +body-start+ 0))) 804 (setf (ll-multipart-parser-body-mark parser) (1+ p)) 805 (go-state +looking-for-delimiter+)) 807 (+looking-for-delimiter+ 808 (setf (ll-multipart-parser-boundary-mark parser) nil) 810 (+cr+ (setf (ll-multipart-parser-boundary-mark parser) p) 811 (go-state +maybe-delimiter-start+)) 812 (otherwise (go-state +looking-for-delimiter+)))) 814 (+maybe-delimiter-start+ 815 (unless (= byte +lf+) 816 (go-state +looking-for-delimiter+ 0)) 817 (go-state +maybe-delimiter-first-dash+)) 819 (+maybe-delimiter-first-dash+ 821 (go-state +maybe-delimiter-second-dash+) 824 (setf (ll-multipart-parser-boundary-mark parser) p) 825 (go-state +maybe-delimiter-start+)) 826 (go-state +looking-for-delimiter+)))) 828 (+maybe-delimiter-second-dash+ 830 (go-state +parsing-delimiter+) 831 (go-state +looking-for-delimiter+))) 835 (+dash+ (go-state +body-done+ 0)) 836 (otherwise (error 'invalid-multipart-body)))) 839 (when (ll-multipart-parser-body-mark parser) 841 (setf (ll-multipart-parser-body-buffer parser) nil) 843 (when-let ((callback (callbacks-message-complete callbacks))) 844 (handler-case (funcall callback parser) 846 (error 'cb-message-complete :error e)))) 847 (setf (ll-multipart-parser-body-mark parser) nil)) 850 (when (ll-multipart-parser-body-mark parser) 851 (when (<= +looking-for-delimiter+ 852 (ll-multipart-parser-state parser) 853 +maybe-delimiter-second-dash+) 854 (call-body-cb (or (ll-multipart-parser-boundary-mark parser) p))) 855 ;; buffer the last part 856 (when (ll-multipart-parser-boundary-mark parser) 857 (setf (ll-multipart-parser-body-buffer parser) 858 (if (ll-multipart-parser-body-buffer parser) 859 (concatenate 'octet-vector 860 (ll-multipart-parser-body-buffer parser) 861 (subseq data (ll-multipart-parser-boundary-mark parser))) 862 (subseq data (ll-multipart-parser-boundary-mark parser))))) 864 (setf (ll-multipart-parser-body-mark parser) 0 865 (ll-multipart-parser-boundary-mark parser) nil)) 868 (defun make-multipart-parser (content-type callback) 869 (check-type content-type string) 870 (let ((boundary (find-boundary content-type))) 872 (return-from make-multipart-parser nil)) 874 (let ((parser (make-ll-multipart-parser :boundary boundary)) 875 (headers (make-hash-table :test 'equal)) 876 parsing-content-disposition 880 (body-buffer (make-smart-buffer)) 882 (flet ((collect-prev-header-value () 883 (when header-value-buffer 885 (babel:octets-to-string 886 header-value-buffer))) 887 (when parsing-content-disposition 890 (field-meta (make-hash-table :test 'equal))) 891 (parse-header-value-parameters header-value 892 :header-parameter-key-callback 893 (lambda (data start end) 895 (string-downcase (subseq data start end)))) 896 :header-parameter-value-callback 897 (lambda (data start end) 898 (setf (gethash parsing-key field-meta) 899 (subseq data start end)))) 901 (setf (gethash parsing-header-field headers) 905 :header-field (lambda (parser data start end) 906 (declare (ignore parser)) 907 (collect-prev-header-value) 908 (setq header-value-buffer (make-concatenated-xsubseqs)) 911 (ascii-octets-to-lower-string data :start start :end end))) 912 (setq parsing-content-disposition 913 (string= header-name "content-disposition")) 914 (setq parsing-header-field header-name))) 915 :header-value (lambda (parser data start end) 916 (declare (ignore parser)) 917 (xnconcf header-value-buffer 918 (subseq (subseq data start end) 0))) 919 :headers-complete (lambda (parser) 920 (declare (ignore parser)) 921 (collect-prev-header-value)) 922 :message-complete (lambda (parser) 923 (declare (ignore parser)) 925 (gethash "name" field-meta) 929 (setq headers (make-hash-table :test 'equal) 931 header-value-buffer nil)) 932 :body (lambda (parser data start end) 933 (declare (ignore parser)) 934 (write-sequence data body-buffer start end))))) 936 (http-multipart-parse parser callbacks data) 937 (= (ll-multipart-parser-state parser) +body-done+))))) 945 (declaim (type fixnum +max-header-line+)) 946 (defconstant +max-header-line+ 1024 947 "Maximum number of header lines allowed. 949 This restriction is for protecting users' application 950 against denial-of-service attacks where the attacker feeds 951 us a never-ending header that the application keeps buffering.") 957 (deftype pointer () 'integer) 964 (message-begin nil :type (or null function)) ;; 1 arg 965 (url nil :type (or null function)) 966 (first-line nil :type (or null function)) 967 (status nil :type (or null function)) 968 (header-field nil :type (or null function)) 969 (header-value nil :type (or null function)) 970 (headers-complete nil :type (or null function)) ;; 1 arg 971 (body nil :type (or null function)) 972 (message-complete nil :type (or null function))) 974 (defmacro callback-data (name http callbacks data start end) 975 (with-gensyms (callback e) 976 `(when-let ((,callback (,(format-symbol t "~A-~A" :callbacks name) ,callbacks))) 977 (handler-bind ((error 979 (unless (typep ,e 'http-error) 980 (error ',(format-symbol t "~A-~A" :cb name) 983 (funcall ,callback ,http ,data ,start ,end))))) 985 (defmacro callback-notify (name http callbacks) 986 (with-gensyms (callback e) 987 `(when-let ((,callback (,(format-symbol t "~A-~A" :callbacks name) ,callbacks))) 988 (handler-bind ((error 990 (unless (typep ,e 'http-error) 991 (error ',(format-symbol t "~A-~A" :cb name) 994 (funcall ,callback ,http))))) 1000 (define-condition eof () ()) 1002 (define-condition expect-failed (parsing-error) 1003 ((description :initform "expect failed"))) 1009 (declaim (type (simple-array character (128)) +tokens+)) 1010 (define-constant +tokens+ 1012 :element-type 'character 1014 '( #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul 1015 #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul 1016 #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul 1017 #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul 1018 #\Nul #\! #\Nul #\# #\$ #\% #\& #\' 1019 #\Nul #\Nul #\* #\+ #\Nul #\- #\. #\Nul 1020 #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 1021 #\8 #\9 #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul 1022 #\Nul #\a #\b #\c #\d #\e #\f #\g 1023 #\h #\i #\j #\k #\l #\m #\n #\o 1024 #\p #\q #\r #\s #\t #\u #\v #\w 1025 #\x #\y #\z #\Nul #\Nul #\Nul #\^ #\_ 1026 #\` #\a #\b #\c #\d #\e #\f #\g 1027 #\h #\i #\j #\k #\l #\m #\n #\o 1028 #\p #\q #\r #\s #\t #\u #\v #\w 1029 #\x #\y #\z #\Nul #\| #\Nul #\~ #\Nul )) 1032 (declaim (type (simple-array fixnum (128)) +unhex+)) 1033 (define-constant +unhex+ 1034 (make-array 128 :element-type 'fixnum :initial-contents 1035 '(-1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 1036 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 1037 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 1038 0 1 2 3 4 5 6 7 8 9 -1 -1 -1 -1 -1 -1 1039 -1 10 11 12 13 14 15 -1 -1 -1 -1 -1 -1 -1 -1 -1 1040 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 1041 -1 10 11 12 13 14 15 -1 -1 -1 -1 -1 -1 -1 -1 -1 1042 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1)) 1045 (defun unhex-byte (byte) 1046 (aref +unhex+ byte)) 1051 (defun parse-method (data start end) 1052 (declare (type octet-vector data) 1053 (type pointer start end)) 1054 (with-octets-parsing (data :start start :end end) 1055 (return-from parse-method 1059 ("CONNECT" :CONNECT) 1061 ("CHECKOUT" :CHECKOUT) 1067 ("MKCALENDAR" :MKCALENDAR) 1068 ("MKACTIVITY" :MKACTIVITY) 1071 ("M-SEARCH" :M-SEARCH) 1073 ("OPTIONS" :OPTIONS) 1075 ("PROPFIND" :PROPFIND) 1076 ("PROPPATCH" :PROPPATCH) 1082 ("SUBSCRIBE" :SUBSCRIBE) 1085 ("UNSUBSCRIBE" :UNSUBSCRIBE) 1086 (otherwise (error 'invalid-method))) 1087 (unless (= (current) +space+) 1088 (error 'invalid-method))) 1092 (defun parse-url (data start end) 1093 (declare (type octet-vector data) 1094 (type pointer start end)) 1095 (flet ((url-char-byte-p (byte) 1096 (or (<= (char-code #\!) byte (char-code #\~)) 1098 (with-octets-parsing (data :start start :end end) 1099 (skip-while url-char-byte-p) 1100 (return-from parse-url (pos))) 1103 (defun parse-http-version (data start end) 1104 (declare (type octet-vector data) 1105 (type pointer start end)) 1107 (with-octets-parsing (data :start start :end end) 1108 (or (match? "HTTP/") 1109 (return-from parse-http-version (values nil nil (pos)))) 1110 (if (digit-byte-char-p (current)) 1111 (setq major (digit-byte-char-to-integer (current))) 1112 (return-from parse-http-version (values nil nil (pos)))) 1114 (or (skip? #\.) (return-from parse-http-version (values nil nil (pos)))) 1115 (if (digit-byte-char-p (current)) 1116 (setq minor (digit-byte-char-to-integer (current))) 1117 (return-from parse-http-version (values nil nil (pos)))) 1119 (return-from parse-http-version 1120 (values major minor (pos)))) 1123 (defun parse-status-code (http callbacks data start end) 1124 (declare (type octet-vector data) 1125 (type pointer start end)) 1126 (or (with-octets-parsing (data :start start :end end) 1127 (if (digit-byte-char-p (current)) 1128 (setf (http-status http) (digit-byte-char-to-integer (current))) 1129 (error 'invalid-status)) 1133 ((digit-byte-char-p (current)) 1134 (setf (http-status http) 1135 (+ (the fixnum (* 10 (http-status http))) 1136 (digit-byte-char-to-integer (current)))) 1137 (when (< 999 (http-status http)) 1138 (error 'invalid-status :status-code (http-status http)))) 1139 ((= (current) +space+) 1140 ;; Reading the status text 1142 (let ((status-text-start (pos))) 1143 (skip* (not #\Return)) 1146 (callback-data :status http callbacks data status-text-start (- (pos) 1))) 1153 (T (error 'invalid-status)))) 1157 (defun parse-header-field-and-value (http callbacks data start end) 1158 (declare (type octet-vector data) 1159 (type pointer start end)) 1161 (with-octets-parsing (data :start start :end end) 1162 (let ((field-start (pos)) 1164 (macrolet ((skip-until-value-start-and (&body body) 1166 ;; skip #\: and leading spaces 1168 (skip* #\Space #\Tab) 1171 ;; continue to the next line 1175 ((or (= (current) +space+) 1176 (= (current) +tab+)) 1177 (skip* #\Space #\Tab) 1178 (if (= (current) +cr+) 1183 (callback-data :header-field http callbacks data field-start field-end) 1184 (callback-data :header-value http callbacks data (pos) (pos))) 1188 (callback-data :header-field http callbacks data field-start field-end) 1189 (callback-data :header-value http callbacks data (pos) (pos))))) 1191 (handle-otherwise () 1193 ;; skip until field end 1194 (do ((char (aref +tokens+ (current)) 1195 (aref +tokens+ (current)))) 1196 ((= (current) (char-code #\:))) 1197 (declare (type character char)) 1198 (when (char= char #\Nul) 1199 (error 'invalid-header-token)) 1202 (setq field-end (pos)) 1203 (skip-until-value-start-and 1205 (parse-header-value http callbacks data (pos) end field-start field-end))))) 1206 (expect-field-end (&body body) 1207 `(if (= (current) #.(char-code #\:)) 1209 (setq field-end (pos)) 1211 (handle-otherwise)))) 1215 (skip-until-value-start-and 1216 (multiple-value-bind (value-start value-end next content-length) 1217 (parse-header-value-content-length data (pos) end) 1218 (declare (type pointer next)) 1219 (setf (http-content-length http) content-length) 1221 (callback-data :header-field http callbacks data field-start field-end) 1222 (callback-data :header-value http callbacks data value-start value-end))))) 1223 ("transfer-encoding" 1225 (skip-until-value-start-and 1226 (multiple-value-bind (value-start value-end next chunkedp) 1227 (parse-header-value-transfer-encoding data (pos) end) 1228 (declare (type pointer next)) 1229 (setf (http-chunked-p http) chunkedp) 1231 (callback-data :header-field http callbacks data field-start field-end) 1232 (callback-data :header-value http callbacks data value-start value-end))))) 1235 (skip-until-value-start-and 1236 (setf (http-upgrade-p http) T) 1237 (let ((value-start (pos))) 1238 (skip* (not #\Return)) 1241 (callback-data :header-field http callbacks data field-start field-end) 1242 (callback-data :header-value http callbacks data value-start (- (pos) 2)))))) 1243 (otherwise (handle-otherwise))))) 1247 (defun parse-header-value (http callbacks data start end &optional field-start field-end) 1248 (or (with-octets-parsing (data :start start :end end) 1249 (skip* (not #\Return)) 1253 (callback-data :header-field http callbacks data field-start field-end)) 1254 (callback-data :header-value http callbacks data start (- (pos) 2)) 1258 (defun parse-header-value-transfer-encoding (data start end) 1259 (declare (type octet-vector data) 1260 (type pointer start end)) 1261 (with-octets-parsing (data :start start :end end) 1264 (if (= (current) +cr+) 1268 (return-from parse-header-value-transfer-encoding 1269 (values start (- (pos) 2) (pos) t))) 1271 (skip+ (not #\Return)) 1274 (return-from parse-header-value-transfer-encoding 1275 (values start (- (pos) 2) (pos) nil))))) 1277 (skip* (not #\Return)) 1280 (return-from parse-header-value-transfer-encoding 1281 (values start (- (pos) 2) (pos) nil))))) 1284 (defun parse-header-value-content-length (data start end) 1285 (declare (type octet-vector data) 1286 (type pointer start end)) 1287 (let ((content-length 0)) 1288 (declare (type integer content-length)) 1289 (with-octets-parsing (data :start start :end end) 1290 (if (digit-byte-char-p (current)) 1291 (setq content-length (digit-byte-char-to-integer (current))) 1292 (error 'invalid-content-length)) 1296 ((digit-byte-char-p (current)) 1297 (setq content-length 1298 (+ (* 10 content-length) 1299 (digit-byte-char-to-integer (current))))) 1303 (return-from parse-header-value-content-length 1304 (values start (- (pos) 2) (pos) content-length))) 1305 ((= (current) +space+) 1308 (t (error 'invalid-content-length))))) 1311 (defun parse-header-line (http callbacks data start end) 1312 (declare (type octet-vector data) 1313 (type pointer start end)) 1314 (when (<= end start) 1316 (let ((current (aref data start))) 1317 (declare (type (unsigned-byte 8) current)) 1319 ((or (= current +tab+) 1320 (= current +space+)) 1321 (parse-header-value http callbacks data start end)) 1323 (parse-header-field-and-value http callbacks data start end)) 1328 (setq current (aref data start)) 1329 (unless (= current +lf+) 1330 (error 'expect-failed)) 1331 (values (1+ start) t))))) 1333 (defun parse-headers (http callbacks data start end) 1334 (declare (type http http) 1335 (type octet-vector data) 1336 (type pointer start end)) 1337 (or (with-octets-parsing (data :start start :end end) 1339 (when (= (current) +cr+) 1341 (if (= (current) +lf+) 1342 (return-from parse-headers (1+ (pos))) 1343 (error 'expect-failed))) 1345 (advance-to* (parse-header-field-and-value http callbacks data start end)) 1347 (setf (http-mark http) (pos)) 1349 (when (= +max-header-line+ (the fixnum (incf (http-header-read http)))) 1350 (error 'header-overflow)) 1351 (multiple-value-bind (next endp) 1352 (parse-header-line http callbacks data (pos) end) 1356 (setf (http-mark http) (pos))) 1357 (setf (http-mark http) (pos)) 1358 (setf (http-state http) +state-body+) 1363 (defun read-body-data (http callbacks data start end) 1364 (declare (type http http) 1365 (type octet-vector data) 1366 (type pointer start end)) 1367 (let ((readable-count (the pointer (- end start)))) 1368 (declare (dynamic-extent readable-count) 1369 (type pointer readable-count)) 1370 (if (<= (http-content-length http) readable-count) 1371 (let ((body-end (+ start (http-content-length http)))) 1372 (declare (dynamic-extent body-end)) 1373 (setf (http-content-length http) 0) 1374 (callback-data :body http callbacks data start body-end) 1375 (setf (http-mark http) body-end) 1376 (values body-end t)) 1377 ;; still needs to read 1379 (decf (http-content-length http) readable-count) 1380 (callback-data :body http callbacks data start end) 1381 (setf (http-mark http) end) 1382 (values end nil))))) 1384 (defun http-message-needs-eof-p (http) 1385 (let ((status-code (http-status http))) 1386 (declare (type status-code status-code)) 1387 (when (= status-code 0) ;; probably request 1388 (return-from http-message-needs-eof-p nil)) 1390 (when (or (< 99 status-code 200) ;; 1xx e.g. Continue 1391 (= status-code 204) ;; No Content 1392 (= status-code 304)) ;; Not Modified 1393 (return-from http-message-needs-eof-p nil)) 1395 (when (or (http-chunked-p http) 1396 (http-content-length http)) 1397 (return-from http-message-needs-eof-p nil)) 1400 (defun parse-http-body (http callbacks data start end requestp) 1401 (declare (type http http) 1402 (type octet-vector data) 1403 (type pointer start end)) 1404 (macrolet ((message-complete () 1406 (callback-notify :message-complete http callbacks) 1407 (setf (http-state http) +state-first-line+)))) 1408 (case (http-content-length http) 1410 ;; Content-Length header given but zero: Content-Length: 0\r\n 1415 (not (http-message-needs-eof-p http))) 1416 ;; Assume content-length 0 - read the next 1419 ;; By returning "start", we'll continue 1420 ;; to parse the next request in case if 1421 ;; HTTP pipelining is used. Probably 1422 ;; we need some way to enable (or disable) 1423 ;; HTTP pipelining support. 1427 (callback-data :body http callbacks data start end) 1428 (setf (http-mark http) end) 1432 ;; Content-Length header given and non-zero 1433 (multiple-value-bind (next completedp) 1434 (read-body-data http callbacks data start end) 1439 (defun parse-chunked-body (http callbacks data start end) 1440 (declare (type http http) 1441 (type octet-vector data) 1442 (type pointer start end)) 1445 (return-from parse-chunked-body start)) 1447 (or (with-octets-parsing (data :start start :end end) 1450 ((= (http-state http) +state-chunk-size+) 1452 ((= (http-state http) +state-body+) 1454 ((= (http-state http) +state-chunk-body-end-crlf+) 1456 ((= (http-state http) +state-trailing-headers+) 1457 (go trailing-headers)) 1458 (T (error 'invalid-internal-state :code (http-state http)))) 1461 (let ((unhex-val (unhex-byte (current)))) 1462 (declare (type fixnum unhex-val) 1463 (dynamic-extent unhex-val)) 1464 (when (= unhex-val -1) 1465 (error 'invalid-chunk-size)) 1466 (setf (http-content-length http) unhex-val) 1470 (if (= (current) +cr+) 1478 (setq unhex-val (unhex-byte (current))) 1482 ((or (= (current) (char-code #\;)) 1483 (= (current) (char-code #\Space))) 1484 (skip* (not #\Return)) 1490 (t (error 'invalid-chunk-size)))) 1491 (t (setf (http-content-length http) 1492 (+ (* 16 (http-content-length http)) unhex-val))))))) 1493 (setf (http-state http) +state-body+) 1495 (return-from parse-chunked-body (pos)) 1496 (setf (http-mark http) (pos)))) 1500 ((zerop (http-content-length http)) 1502 (setf (http-state http) +state-trailing-headers+) 1503 (go trailing-headers)) 1505 (multiple-value-bind (next completedp) 1506 (read-body-data http callbacks data (pos) end) 1507 (declare (type pointer next)) 1509 (return-from parse-chunked-body (pos))) 1510 (setf (http-state http) +state-chunk-body-end-crlf+) 1511 (advance-to next)))) 1518 (setf (http-state http) +state-chunk-size+) 1520 (return-from parse-chunked-body (pos)))) 1521 (setf (http-mark http) (pos)) 1525 (return-from parse-chunked-body 1526 (prog1 (parse-headers http callbacks data (pos) end) 1527 (callback-notify :message-complete http callbacks))))) 1530 (defun parse-request (http callbacks data &key (start 0) end (head-request nil)) 1531 (declare (type http http) 1532 (type octet-vector data) 1533 (ignorable head-request)) 1534 (let ((end (or end (length data)))) 1535 (declare (type pointer start end)) 1536 (handler-bind ((match-failed 1538 (declare (ignore c)) 1539 (error 'expect-failed)))) 1540 (with-octets-parsing (data :start start :end end) 1541 (setf (http-mark http) start) 1544 (let ((state (http-state http))) 1545 (declare (type fixnum state)) 1547 ((= +state-first-line+ state) 1549 ((= +state-headers+ state) 1551 ((<= +state-chunk-size+ state +state-trailing-headers+) 1553 (T (error 'invalid-internal-state :code state)))) 1556 ;; skip first empty line (some clients add CRLF after POST content) 1557 (when (= (current) +cr+) 1563 (return-from parse-request (pos))))) 1565 (setf (http-mark http) (pos)) 1566 (callback-notify :message-begin http callbacks) 1568 (multiple-value-bind (method next) 1569 (parse-method data (pos) end) 1570 (declare (type pointer next)) 1571 (setf (http-method http) method) 1574 (let ((url-start-mark (pos)) 1575 (url-end-mark (parse-url data (pos) end))) 1576 (declare (type pointer url-start-mark url-end-mark)) 1577 (tagbody retry-url-parse 1578 (advance-to* url-end-mark) 1585 (callback-data :url http callbacks data url-start-mark url-end-mark) 1588 (t (multiple-value-bind (major minor next) 1589 (parse-http-version data (pos) end) 1590 (declare (type pointer next)) 1592 ;; Invalid HTTP version. 1593 ;; Assuming it's also a part of URI. 1594 (let ((new-url-end-mark (parse-url data next end))) 1595 (when (= url-end-mark new-url-end-mark) 1596 (error 'invalid-version)) 1597 (setq url-end-mark new-url-end-mark) 1598 (go retry-url-parse))) 1599 (callback-data :url http callbacks data url-start-mark url-end-mark) 1600 (setf (http-major-version http) major 1601 (http-minor-version http) minor) 1604 (skip #\Newline))))) 1606 (setf (http-mark http) (pos)) 1607 (setf (http-state http) +state-headers+) 1608 (callback-notify :first-line http callbacks) 1611 (advance-to* (parse-headers http callbacks data (pos) end)) 1613 (callback-notify :headers-complete http callbacks) 1614 (setf (http-header-read http) 0) 1616 ;; Exit, the rest of the connect is in a different protocol. 1617 (when (http-upgrade-p http) 1618 (setf (http-state http) +state-first-line+) 1619 (callback-notify :message-complete http callbacks) 1620 (return-from parse-request (pos))) 1622 (setf (http-state http) 1623 (if (http-chunked-p http) 1628 (if (http-chunked-p http) 1629 (advance-to* (parse-chunked-body http callbacks data (pos) end)) 1631 (and (advance-to* (parse-http-body http callbacks data (pos) end t)) 1633 (return-from parse-request (pos))))) 1636 (defun parse-response (http callbacks data &key (start 0) end (head-request nil)) 1637 (declare (type http http) 1638 (type octet-vector data)) 1641 (declare (type pointer start end)) 1642 (handler-bind ((match-failed 1644 (declare (ignore c)) 1645 (error 'expect-failed)))) 1646 (with-octets-parsing (data :start start :end end) 1647 (setf (http-mark http) start) 1650 (let ((state (http-state http))) 1651 (declare (type fixnum state)) 1653 ((= +state-first-line+ state) 1655 ((= +state-headers+ state) 1657 ((<= +state-chunk-size+ state +state-trailing-headers+) 1659 (T (error 'invalid-internal-state :code state)))) 1662 (setf (http-mark http) (pos)) 1663 (callback-notify :message-begin http callbacks) 1665 (multiple-value-bind (major minor next) 1666 (parse-http-version data (pos) end) 1667 (declare (type pointer next)) 1668 (setf (http-major-version http) major 1669 (http-minor-version http) minor) 1673 ((= (current) +space+) 1675 (advance-to (parse-status-code http callbacks data (pos) end))) 1678 (T (error 'invalid-version))) 1680 (setf (http-mark http) (pos)) 1681 (setf (http-state http) +state-headers+) 1682 (callback-notify :first-line http callbacks) 1685 (advance-to* (parse-headers http callbacks data (pos) end)) 1687 (callback-notify :headers-complete http callbacks) 1688 (setf (http-header-read http) 0) 1689 (setf (http-state http) 1690 (if (http-chunked-p http) 1695 (callback-notify :message-complete http callbacks) 1696 (setf (http-state http) +state-first-line+) 1697 (return-from parse-response (pos))) 1700 (if (http-chunked-p http) 1701 (advance-to* (parse-chunked-body http callbacks data (pos) end)) 1703 (advance-to* (parse-http-body http callbacks data (pos) end nil)) 1706 (return-from parse-response (pos))))) 1709 (defun parse-header-value-parameters (data &key 1710 header-value-callback 1711 header-parameter-key-callback 1712 header-parameter-value-callback) 1713 (declare (type simple-string data) 1714 (optimize (speed 3) (safety 2))) 1716 (let* ((header-name-mark 0) 1718 parameter-value-mark 1719 parsing-quoted-string-p 1722 (char (aref data p))) 1723 (declare (type character char)) 1726 (return-from parse-header-value-parameters 0)) 1728 (macrolet ((go-state (state &optional (advance 1)) 1729 `(locally (declare (optimize (speed 3) (safety 0))) 1733 (setq char (aref data p)) 1735 (flet ((tokenp (char) 1736 (declare (optimize (speed 3) (safety 0))) 1737 (let ((byte (char-code char))) 1739 (not (char= (the character (aref +tokens+ byte)) #\Nul)))))) 1741 parsing-header-value-start 1744 (go-state parsing-header-value)) 1746 (unless (tokenp char) 1747 (error 'invalid-header-value)) 1748 (setq header-name-mark p) 1749 (go-state parsing-header-value 0))) 1751 parsing-header-value 1754 (when header-value-callback 1755 (funcall (the function header-value-callback) 1756 data header-name-mark p)) 1757 (setq header-name-mark nil) 1758 (go-state looking-for-parameter-key)) 1759 (otherwise (go-state parsing-header-value))) 1761 looking-for-parameter-key 1763 ((#\Space #\Tab #\; #\Newline #\Return) 1764 (go-state looking-for-parameter-key)) 1766 (unless (tokenp char) 1767 (error 'invalid-parameter-key)) 1768 (setq parameter-key-mark p) 1769 (go-state parsing-parameter-key))) 1771 parsing-parameter-key 1774 (assert parameter-key-mark) 1775 (when header-parameter-key-callback 1776 (funcall (the function header-parameter-key-callback) 1777 data parameter-key-mark p)) 1778 (setq parameter-key-mark nil) 1779 (go-state parsing-parameter-value-start)) 1781 (unless (tokenp char) 1782 (error 'invalid-parameter-key)) 1783 (go-state parsing-parameter-key))) 1785 parsing-parameter-value-start 1789 (setq parameter-value-mark (1+ p)) 1790 (setq parsing-quoted-string-p t) 1791 (go-state parsing-parameter-quoted-value)) 1792 ((#.+space+ #.+tab+) 1793 (go-state parsing-parameter-value-start)) 1795 (setq parameter-value-mark p) 1796 (go-state parsing-parameter-value 0))) 1798 parsing-parameter-quoted-value 1799 (if (char= char #\") 1801 (assert parameter-value-mark) 1802 (setq parsing-quoted-string-p nil) 1803 (when header-parameter-value-callback 1804 (funcall (the function header-parameter-value-callback) 1805 data parameter-value-mark p)) 1806 (setq parameter-value-mark nil) 1807 (go-state looking-for-parameter-key)) 1808 (go-state parsing-parameter-quoted-value)) 1810 parsing-parameter-value 1813 (assert parameter-value-mark) 1814 (when header-parameter-value-callback 1815 (funcall (the function header-parameter-value-callback) 1816 data parameter-value-mark p)) 1817 (setq parameter-value-mark nil) 1818 (go-state looking-for-parameter-key)) 1820 (go-state parsing-parameter-value))) 1823 (when header-name-mark 1824 (when header-value-callback 1825 (funcall (the function header-value-callback) 1826 data header-name-mark p))) 1827 (when parameter-key-mark 1828 (error 'invalid-eof-state)) 1829 (when parameter-value-mark 1830 (when parsing-quoted-string-p 1831 (error 'invalid-eof-state)) 1832 (when header-parameter-value-callback 1833 (funcall (the function header-parameter-value-callback) 1834 data parameter-value-mark p))))))