Mercurial > core / lisp/lib/net/proto/http.lisp
changeset 369: |
de40bd522c84 |
parent: |
b1f78dffbcdd
|
child: |
386d51cf61ca |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Sun, 26 May 2024 15:39:55 -0400 |
permissions: |
-rw-r--r-- |
description: |
png 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 11 ;; minimal changes. At some point in the future it would be ideal to 12 ;; re-implement this in a sans-io style. 15 (in-package :net/proto/http) 18 (defmacro casev (keyform &body clauses) 22 ((eq val 'otherwise) val) 23 ((symbolp val) (symbol-value val)) 25 (T (error "CASEV can be used only with variables or constants"))))) 27 ,@(loop for (val . clause) in clauses 28 if (eq val 'otherwise) 29 collect `(otherwise ,@clause) 31 collect `((,@(mapcar #'get-val val)) ,@clause) 33 collect `(,(get-val val) ,@clause)))))) 35 (defmacro casev= (keyform &body clauses) 39 ((eq val 'otherwise) val) 40 ((symbolp val) (symbol-value val)) 42 (T (error "CASEV can be used only with variables or constants"))))) 44 ,@(loop for (val . clause) in clauses 45 if (eq val 'otherwise) 48 collect `((or ,@(mapcar (lambda (val) 49 `(= ,keyform ,(get-val val))) 53 collect `((= ,keyform ,(get-val val)) ,@clause)))))) 55 (defmacro case-byte (byte &body cases) 57 ,@(loop for (val . form) in cases 58 if (eq val 'otherwise) 59 collect `(,val ,@form) 61 collect `(,(mapcar #'char-code val) ,@form) 63 collect `(,(char-code val) ,@form)))) 65 (defmacro tagcase (keyform &body blocks) 66 (let ((end (gensym "END"))) 69 ,@(loop for (tag . body) in blocks 70 if (eq tag 'otherwise) 71 collect `(otherwise ,@body (go ,end)) 73 collect `(,tag (go ,(if (listp tag) (car tag) tag))))) 75 ,@(loop for (tag . body) in blocks 80 collect `(progn ,@body 84 (defmacro tagcasev (keyform &body blocks) 85 (let ((end (gensym "END"))) 88 ,@(loop for (tag . body) in blocks 89 if (eq tag 'otherwise) 90 collect `(otherwise ,@body (go ,end)) 92 collect `(,tag (go ,(if (listp tag) (car tag) tag))))) 94 ,@(loop for (tag . body) in blocks 97 else if (not (eq tag 'otherwise)) 99 collect `(progn ,@body 103 (defmacro tagcasev= (keyform &body blocks) 104 (let ((end (gensym "END"))) 107 ,@(loop for (tag . body) in blocks 108 if (eq tag 'otherwise) 109 collect `(otherwise ,@body (go ,end)) 111 collect `(,tag (go ,(if (listp tag) (car tag) tag))))) 113 ,@(loop for (tag . body) in blocks 116 else if (not (eq tag 'otherwise)) 118 collect `(progn ,@body 122 (defun make-collector () 123 (let ((none '#:none)) 124 (declare (dynamic-extent none)) 125 (with-collectors (buffer) 126 (return-from make-collector 127 (lambda (&optional (data none)) 128 (unless (eq data none) 132 (declaim (inline %whitespacep)) 133 (defun %whitespacep (char) 134 (declare (type character char) 135 (optimize (speed 3) (safety 0))) 136 (or (char= char #\Space) 139 (declaim (inline position-not-whitespace)) 140 (defun position-not-whitespace (string &key from-end) 141 (declare (type simple-string string) 142 (optimize (speed 3) (safety 0))) 143 (let* ((len (length string)) 144 (start (if from-end (1- len) 0)) 145 (end (if from-end 0 (1- len))) 146 (step-fn (if from-end #'1- #'1+))) 147 (declare (type integer len start end)) 148 (do ((i start (funcall step-fn i))) 150 (declare (type integer i)) 151 (unless (%whitespacep (aref string i)) 152 (return-from position-not-whitespace i))))) 154 (declaim (inline number-string-p)) 155 (defun number-string-p (string) 156 (declare (type simple-string string) 157 (optimize (speed 3) (safety 2))) 159 (when (zerop (length string)) 160 (return-from number-string-p nil)) 161 (let ((end (position-not-whitespace string :from-end t)) 165 ;; (return-from number-string-p)) 166 (locally (declare (type integer end) 167 (optimize (safety 0))) 169 (do ((i (the integer (or (position-not-whitespace string) 0)) (1+ i))) 171 (declare (type integer i)) 172 (let ((char (aref string i))) 173 (declare (type character char)) 176 (return-from number-string-p nil)) 177 ((digit-char-p char)) 180 (return-from number-string-p nil)) 182 (T (return-from number-string-p nil)))))))) 185 (defun make-http-parser (http &key first-line-callback header-callback body-callback finish-callback (head-request nil)) 186 (declare (type http http)) 189 (parse-fn (etypecase http 190 (http-request #'parse-request) 191 (http-response #'parse-response))) 195 (header-value-buffer nil) 201 (flet ((collect-prev-header-value () 202 (when header-value-buffer 204 (locally (declare (optimize (speed 3) (safety 0))) 206 (the (or octet-concatenated-xsubseqs octet-xsubseq) header-value-buffer))))) 208 (if (string= parsing-header-field "set-cookie") 209 (push header-value (gethash "set-cookie" headers)) 210 (multiple-value-bind (previous-value existp) 211 (gethash (the simple-string parsing-header-field) headers) 212 (setf (gethash (the simple-string parsing-header-field) headers) 214 (if (simple-string-p previous-value) 215 (concatenate 'string (the simple-string previous-value) ", " header-value) 216 (format nil "~A, ~A" previous-value header-value)) 220 :message-begin (lambda (http) 221 (declare (ignore http)) 222 (setq headers (make-hash-table :test 'equal) 223 header-complete-p nil 225 :url (lambda (http data start end) 226 (declare (type octet-vector data) 227 (type pointer start end)) 228 (setf (http-resource http) 229 (ascii-octets-to-string data :start start :end end))) 230 :status (lambda (http data start end) 231 (declare (type octet-vector data) 232 (type pointer start end)) 233 (setf (http-status-text http) 234 (ascii-octets-to-string data :start start :end end))) 235 :first-line (and first-line-callback 237 (declare (ignore http)) 238 (funcall (the function first-line-callback)))) 239 :header-field (lambda (http data start end) 240 (declare (ignore http) 241 (type octet-vector data) 242 (type pointer start end)) 243 (collect-prev-header-value) 244 (setq header-value-buffer (make-concatenated-xsubseqs)) 245 (setq parsing-header-field 246 (ascii-octets-to-lower-string data :start start :end end))) 247 :header-value (lambda (http data start end) 248 (declare (ignore http) 249 (type octet-vector data) 250 (type pointer start end)) 251 (xnconcf header-value-buffer 252 (xsubseq (subseq (the octet-vector data) start end) 0))) 253 :headers-complete (lambda (http) 254 (collect-prev-header-value) 255 (setq header-value-buffer nil) 256 (when (gethash "set-cookie" headers) 257 (setf (gethash "set-cookie" headers) 258 (nreverse (gethash "set-cookie" headers)))) 259 (setf (http-headers http) headers) 260 (when header-callback 261 (funcall (the function header-callback) headers)) 262 (when (and (not (http-chunked-p http)) 263 (not (numberp (http-content-length http)))) 265 (setq header-complete-p t)) 266 :body (and body-callback 267 (lambda (http data start end) 268 (declare (ignore http) 269 (type octet-vector data) 270 (type pointer start end)) 271 (funcall (the function body-callback) 273 :message-complete (lambda (http) 274 (declare (ignore http)) 275 (collect-prev-header-value) 276 (when finish-callback 277 (funcall (the function finish-callback))) 278 (setq completedp t))))) 280 (lambda (data &key (start 0) end) 281 (declare (optimize (speed 3) (safety 2))) 285 (when finish-callback 286 (funcall (the function finish-callback)))) 288 (locally (declare (type octet-vector data) 289 (type pointer start)) 290 (check-type end (or null pointer)) 294 (xnconc (xsubseq data-buffer 0) 295 (xsubseq (the octet-vector data) start (or end (length data)))))) 296 (setq data-buffer nil 299 (setf (http-mark http) start) 301 (funcall parse-fn http callbacks (the octet-vector data) :start start :end end :head-request head-request) 304 (subseq data (http-mark http) (or end (length data))))))))) 305 (values http header-complete-p completedp)))) 307 (defun find-boundary (content-type) 308 (declare (type string content-type)) 309 (let ((parsing-boundary nil)) 310 (parse-header-value-parameters content-type 311 :header-value-callback 312 (lambda (data start end) 313 (unless (string= data "multipart/form-data" 314 :start1 start :end1 end) 315 (return-from find-boundary nil))) 316 :header-parameter-key-callback 317 (lambda (data start end) 318 (when (string= data "boundary" 319 :start1 start :end1 end) 320 (setq parsing-boundary t))) 321 :header-parameter-value-callback 322 (lambda (data start end) 323 (when parsing-boundary 324 (return-from find-boundary (subseq data start end))))))) 327 (defconstant +cr+ (char-code #\Return)) 328 (defconstant +lf+ (char-code #\Linefeed)) 329 (defconstant +space+ (char-code #\Space)) 330 (defconstant +tab+ (char-code #\Tab)) 331 (defconstant +page+ (char-code #\Page)) 332 (defconstant +dash+ #.(char-code #\-)) 334 (define-constant +crlf+ 335 (make-array 2 :element-type '(unsigned-byte 8) 336 :initial-contents (list +cr+ +lf+)) 339 (deftype octet-vector (&optional (len '*)) 340 `(simple-array (unsigned-byte 8) (,len))) 342 (declaim (inline digit-byte-char-p 343 digit-byte-char-to-integer 345 alpha-byte-char-to-lower-char 346 alphanumeric-byte-char-p 349 (defun digit-byte-char-p (byte) 350 (declare (type (unsigned-byte 8) byte) 351 (optimize (speed 3) (safety 0))) 352 (<= #.(char-code #\0) byte #.(char-code #\9))) 354 (declaim (ftype (function ((unsigned-byte 8)) fixnum) digit-byte-char-to-integer)) 355 (defun digit-byte-char-to-integer (byte) 356 (declare (type (unsigned-byte 8) byte) 357 (optimize (speed 3) (safety 0))) 358 (the fixnum (- byte #.(char-code #\0)))) 360 (defun alpha-byte-char-p (byte) 361 (declare (type (unsigned-byte 8) byte) 362 (optimize (speed 3) (safety 0))) 363 (or (<= #.(char-code #\A) byte #.(char-code #\Z)) 364 (<= #.(char-code #\a) byte #.(char-code #\z)))) 366 (defun alpha-byte-char-to-lower-char (byte) 367 (declare (type (unsigned-byte 8) byte) 368 (optimize (speed 3) (safety 0))) 371 ((<= #.(char-code #\A) byte #.(char-code #\Z)) 372 (code-char (+ byte #x20))) 373 (T #+nil(<= #.(char-code #\a) byte #.(char-code #\z)) 376 (defun alphanumeric-byte-char-p (byte) 377 (declare (type (unsigned-byte 8) byte)) 378 (or (alpha-byte-char-p byte) 379 (digit-byte-char-p byte))) 381 (defun mark-byte-char-p (byte) 382 (declare (type (unsigned-byte 8) byte) 383 (optimize (speed 3) (safety 0))) 384 (or (= byte #.(char-code #\-)) 385 (= byte #.(char-code #\_)) 386 (= byte #.(char-code #\.)) 387 (= byte #.(char-code #\!)) 388 (= byte #.(char-code #\~)) 389 (= byte #.(char-code #\*)) 390 (= byte #.(char-code #\')) 391 (= byte #.(char-code #\()) 392 (= byte #.(char-code #\))))) 394 (declaim (ftype (function ((unsigned-byte 8)) (unsigned-byte 8)) byte-to-ascii-lower) 395 (inline byte-to-ascii-lower)) 396 (defun byte-to-ascii-lower (x) 397 (declare (type (unsigned-byte 8) x) 398 (optimize (speed 3) (safety 0))) 399 (if (<= #.(char-code #\A) x #.(char-code #\Z)) 400 (- x #.(- (char-code #\A) (char-code #\a))) 403 (declaim (inline ascii-octets-to-string)) 404 (defun ascii-octets-to-string (octets &key (start 0) (end (length octets))) 405 (declare (type octet-vector octets) 406 (type (unsigned-byte 64) start end) 407 (optimize (speed 3) (safety 0))) 408 (let* ((len (the (unsigned-byte 64) (- end start))) 409 (string (make-string len :element-type 'character))) 410 (declare (type (unsigned-byte 64) len) 411 (type simple-string string)) 415 (setf (aref string i) 416 (code-char (aref octets j)))))) 418 (declaim (inline ascii-octets-to-lower-string)) 419 (defun ascii-octets-to-lower-string (octets &key (start 0) (end (length octets))) 420 (declare (type octet-vector octets) 421 (type (unsigned-byte 64) start end) 422 (optimize (speed 3) (safety 0))) 423 (let* ((len (the (unsigned-byte 64) (- end start))) 424 (string (make-string len :element-type 'character))) 425 (declare (type (unsigned-byte 64) len) 426 (type simple-string string)) 430 (setf (aref string i) 431 (code-char (byte-to-ascii-lower (aref octets j))))))) 433 (defun append-byte-vectors (vec1 vec2) 434 (declare (type octet-vector vec1 vec2) 435 (optimize (speed 3) (safety 0))) 436 (let* ((vec1-len (length vec1)) 437 (vec2-len (length vec2)) 438 (result (make-array (+ vec1-len vec2-len) 439 :element-type '(unsigned-byte 8)))) 440 (declare (type octet-vector result)) 441 (replace result vec1 :start1 0) 442 (replace result vec2 :start1 vec1-len) 446 (defstruct (ll-multipart-parser (:constructor make-ll-multipart-parser 449 (let ((parser (make-http))) 450 (setf (http-state parser) +state-headers+) 452 (state 0 :type fixnum) 460 #.`(eval-when (:compile-toplevel :load-toplevel :execute) 462 for state in '(parsing-delimiter-dash-start 463 parsing-delimiter-dash 465 parsing-delimiter-end 466 parsing-delimiter-almost-done 467 parsing-delimiter-done 470 looking-for-delimiter 471 maybe-delimiter-start 472 maybe-delimiter-first-dash 473 maybe-delimiter-second-dash 476 collect `(defconstant ,(format-symbol t "+~A+" state) ,i))) 478 (defun http-multipart-parse (parser callbacks data &key (start 0) end) 479 (declare (type octet-vector data)) 480 (let* ((end (or end (length data))) 481 (boundary (map '(simple-array (unsigned-byte 8) (*)) #'char-code (ll-multipart-parser-boundary parser))) 482 (boundary-length (length boundary)) 483 (header-parser (ll-multipart-parser-header-parser parser))) 484 (declare (type octet-vector boundary)) 486 (return-from http-multipart-parse start)) 488 (macrolet ((with-body-cb (callback &body body) 489 `(handler-case (when-let ((,callback (callbacks-body callbacks))) 492 (error 'cb-body :error e)))) 493 (call-body-cb (&optional (end '(ll-multipart-parser-boundary-mark parser))) 494 (let ((g-end (gensym "END"))) 495 `(with-body-cb callback 496 (when (ll-multipart-parser-body-buffer parser) 497 (funcall callback parser 498 (ll-multipart-parser-body-buffer parser) 499 0 (length (ll-multipart-parser-body-buffer parser))) 500 (setf (ll-multipart-parser-body-buffer parser) nil)) 501 (when-let ((,g-end ,end)) 502 (funcall callback parser data 503 (ll-multipart-parser-body-mark parser) 505 (flush-boundary-buffer () 506 `(with-body-cb callback 507 (when (ll-multipart-parser-boundary-buffer parser) 508 (funcall callback parser 509 (ll-multipart-parser-boundary-buffer parser) 510 0 (length (ll-multipart-parser-boundary-buffer parser))) 511 (setf (ll-multipart-parser-boundary-buffer parser) nil))))) 513 (byte (aref data p))) 515 (log:debug (code-char byte)) 517 (macrolet ((go-state (tag &optional (advance 1)) 522 (otherwise `(incf p ,advance))) 523 (setf (ll-multipart-parser-state parser) ,tag) 525 (log:debug ,(princ-to-string tag)) 526 ,@(and (not (eql advance 0)) 529 (setq byte (aref data p)) 531 (log:debug (code-char byte)))) 533 (tagcasev (ll-multipart-parser-state parser) 534 (+parsing-delimiter-dash-start+ 535 (unless (= byte +dash+) 536 (go-state +header-field-start+ 0)) 537 (go-state +parsing-delimiter-dash+)) 539 (+parsing-delimiter-dash+ 540 (unless (= byte +dash+) 541 (error 'invalid-multipart-body)) 542 (go-state +parsing-delimiter+)) 545 (let ((end2 (+ p boundary-length))) 547 ((ll-multipart-parser-boundary-buffer parser) 548 (when (< (+ end (length (ll-multipart-parser-boundary-buffer parser)) -3) end2) 549 (setf (ll-multipart-parser-boundary-buffer parser) 550 (concatenate 'octet-vector 551 (ll-multipart-parser-boundary-buffer parser) 554 (let ((data2 (make-array boundary-length :element-type '(unsigned-byte 8))) 555 (boundary-buffer-length (length (ll-multipart-parser-boundary-buffer parser)))) 556 (replace data2 (ll-multipart-parser-boundary-buffer parser) 559 :start1 (- boundary-buffer-length 2)) 560 (unless (search boundary data2) 562 (when (ll-multipart-parser-body-mark parser) 564 (flush-boundary-buffer) 565 (go-state +looking-for-delimiter+)) 566 (error 'invalid-boundary)) 567 (go-state +parsing-delimiter-end+ (- boundary-length boundary-buffer-length -2)))) 570 (setf (ll-multipart-parser-boundary-buffer parser) 571 (if (ll-multipart-parser-boundary-buffer parser) 572 (concatenate 'octet-vector 573 (ll-multipart-parser-boundary-buffer parser) 574 (subseq data (max 0 (- p 2)))) 575 (subseq data (max 0 (- p 2))))) 578 (unless (search boundary data :start2 p :end2 end2) 580 (when (ll-multipart-parser-body-mark parser) 581 (go-state +looking-for-delimiter+)) 582 (error 'invalid-boundary)) 583 (go-state +parsing-delimiter-end+ boundary-length))))) 585 (+parsing-delimiter-end+ 587 (+cr+ (go-state +parsing-delimiter-almost-done+)) 588 (+lf+ (go-state +parsing-delimiter-almost-done+ 0)) 589 (+dash+ (go-state +body-almost-done+)) 592 (when (ll-multipart-parser-body-mark parser) 594 (flush-boundary-buffer) 595 (go-state +looking-for-delimiter+)) 596 (error 'invalid-boundary)))) 598 (+parsing-delimiter-almost-done+ 599 (unless (= byte +lf+) 600 (error 'invalid-boundary)) 601 (when (ll-multipart-parser-body-mark parser) 603 (when (ll-multipart-parser-boundary-mark parser) 605 (when-let ((callback (callbacks-message-complete callbacks))) 606 (handler-case (funcall callback parser) 608 (error 'cb-message-complete :error e))))) 609 (go-state +parsing-delimiter-done+)) 611 (+parsing-delimiter-done+ 612 (when-let ((callback (callbacks-message-begin callbacks))) 613 (handler-case (funcall callback parser) 615 (error 'cb-message-begin :error e)))) 616 (setf (ll-multipart-parser-body-mark parser) p) 617 (go-state +header-field-start+ 0)) 619 (+header-field-start+ 620 (let ((next (parse-headers header-parser callbacks data p end))) 621 (setq p (1- next)) ;; XXX 622 ;; parsing headers done 623 (when (= (http-state header-parser) +state-body+) 624 (when-let ((callback (callbacks-headers-complete callbacks))) 625 (handler-case (funcall callback parser) 627 (error 'cb-headers-complete :error e)))) 628 (setf (http-state header-parser) +state-headers+)) 629 (go-state +body-start+ 0))) 632 (setf (ll-multipart-parser-body-mark parser) (1+ p)) 633 (go-state +looking-for-delimiter+)) 635 (+looking-for-delimiter+ 636 (setf (ll-multipart-parser-boundary-mark parser) nil) 638 (+cr+ (setf (ll-multipart-parser-boundary-mark parser) p) 639 (go-state +maybe-delimiter-start+)) 640 (otherwise (go-state +looking-for-delimiter+)))) 642 (+maybe-delimiter-start+ 643 (unless (= byte +lf+) 644 (go-state +looking-for-delimiter+ 0)) 645 (go-state +maybe-delimiter-first-dash+)) 647 (+maybe-delimiter-first-dash+ 649 (go-state +maybe-delimiter-second-dash+) 652 (setf (ll-multipart-parser-boundary-mark parser) p) 653 (go-state +maybe-delimiter-start+)) 654 (go-state +looking-for-delimiter+)))) 656 (+maybe-delimiter-second-dash+ 658 (go-state +parsing-delimiter+) 659 (go-state +looking-for-delimiter+))) 663 (+dash+ (go-state +body-done+ 0)) 664 (otherwise (error 'invalid-multipart-body)))) 667 (when (ll-multipart-parser-body-mark parser) 669 (setf (ll-multipart-parser-body-buffer parser) nil) 671 (when-let ((callback (callbacks-message-complete callbacks))) 672 (handler-case (funcall callback parser) 674 (error 'cb-message-complete :error e)))) 675 (setf (ll-multipart-parser-body-mark parser) nil)) 678 (when (ll-multipart-parser-body-mark parser) 679 (when (<= +looking-for-delimiter+ 680 (ll-multipart-parser-state parser) 681 +maybe-delimiter-second-dash+) 682 (call-body-cb (or (ll-multipart-parser-boundary-mark parser) p))) 683 ;; buffer the last part 684 (when (ll-multipart-parser-boundary-mark parser) 685 (setf (ll-multipart-parser-body-buffer parser) 686 (if (ll-multipart-parser-body-buffer parser) 687 (concatenate 'octet-vector 688 (ll-multipart-parser-body-buffer parser) 689 (subseq data (ll-multipart-parser-boundary-mark parser))) 690 (subseq data (ll-multipart-parser-boundary-mark parser))))) 692 (setf (ll-multipart-parser-body-mark parser) 0 693 (ll-multipart-parser-boundary-mark parser) nil)) 696 (defun make-multipart-parser (content-type callback) 697 (check-type content-type string) 698 (let ((boundary (find-boundary content-type))) 700 (return-from make-multipart-parser nil)) 702 (let ((parser (make-ll-multipart-parser :boundary boundary)) 703 (headers (make-hash-table :test 'equal)) 704 parsing-content-disposition 708 (body-buffer (make-smart-buffer)) 710 (flet ((collect-prev-header-value () 711 (when header-value-buffer 713 (babel:octets-to-string 714 header-value-buffer))) 715 (when parsing-content-disposition 718 (field-meta (make-hash-table :test 'equal))) 719 (parse-header-value-parameters header-value 720 :header-parameter-key-callback 721 (lambda (data start end) 723 (string-downcase (subseq data start end)))) 724 :header-parameter-value-callback 725 (lambda (data start end) 726 (setf (gethash parsing-key field-meta) 727 (subseq data start end)))) 729 (setf (gethash parsing-header-field headers) 733 :header-field (lambda (parser data start end) 734 (declare (ignore parser)) 735 (collect-prev-header-value) 736 (setq header-value-buffer (make-concatenated-xsubseqs)) 739 (ascii-octets-to-lower-string data :start start :end end))) 740 (setq parsing-content-disposition 741 (string= header-name "content-disposition")) 742 (setq parsing-header-field header-name))) 743 :header-value (lambda (parser data start end) 744 (declare (ignore parser)) 745 (xnconcf header-value-buffer 746 (subseq (subseq data start end) 0))) 747 :headers-complete (lambda (parser) 748 (declare (ignore parser)) 749 (collect-prev-header-value)) 750 :message-complete (lambda (parser) 751 (declare (ignore parser)) 753 (gethash "name" field-meta) 757 (setq headers (make-hash-table :test 'equal) 759 header-value-buffer nil)) 760 :body (lambda (parser data start end) 761 (declare (ignore parser)) 762 (write-sequence data body-buffer start end))))) 764 (http-multipart-parse parser callbacks data) 765 (= (ll-multipart-parser-state parser) +body-done+))))) 771 (deftype status-code () '(integer 0 10000)) 776 (defconstant +state-first-line+ 0) 777 (defconstant +state-headers+ 1) 778 (defconstant +state-chunk-size+ 2) 779 (defconstant +state-body+ 3) 780 (defconstant +state-chunk-body-end-crlf+ 4) 781 (defconstant +state-trailing-headers+ 5) 783 (defstruct (http (:conc-name :http-)) 784 (method nil :type symbol) 785 (major-version 0 :type fixnum) 786 (minor-version 9 :type fixnum) 787 (status 0 :type status-code) 788 (content-length nil :type (or null integer)) 789 (chunked-p nil :type boolean) 790 (upgrade-p nil :type boolean) 795 (header-read 0 :type fixnum) 796 (mark -1 :type fixnum) 797 (state +state-first-line+ :type fixnum)) 799 (defun http-version (http) 801 (+ (http-major-version http) 802 (/ (http-minor-version http) 10)))) 804 (defstruct (http-request (:include http) 808 (defstruct (http-response (:include http) 813 (define-condition http-error (net-error) 816 (lambda (condition stream) 817 (format stream "~A: ~A" (type-of condition) (slot-value condition 'description))))) 821 ;; Callback-related errors 823 (define-condition callback-error (http-error) 824 ((error :initarg :error 826 (:report (lambda (condition stream) 827 (with-slots (description error) condition 828 (format stream "Callback Error: ~A~:[~;~:*~% ~A~]" 832 (define-condition cb-message-begin (callback-error) 833 ((description :initform "the message-begin callback failed"))) 834 (define-condition cb-url (callback-error) 835 ((description :initform "the url callback failed"))) 836 (define-condition cb-first-line (callback-error) 837 ((description :initform "the first line callback failed"))) 838 (define-condition cb-header-field (callback-error) 839 ((description :initform "the header-field callback failed"))) 840 (define-condition cb-header-value (callback-error) 841 ((description :initform "the header-value callback failed"))) 842 (define-condition cb-headers-complete (callback-error) 843 ((description :initform "the headers-complete callback failed"))) 844 (define-condition cb-body (callback-error) 845 ((description :initform "the body callback failed"))) 846 (define-condition cb-message-complete (callback-error) 847 ((description :initform "the message-complete callback failed"))) 848 (define-condition cb-status (callback-error) 849 ((description :initform "the status callback failed"))) 853 ;; Parsing-related errors 855 (define-condition parsing-error (http-error) ()) 857 (define-condition invalid-eof-state (parsing-error) 858 ((description :initform "stream ended at an unexpected time"))) 859 (define-condition header-overflow (parsing-error) 860 ((description :initform "too many header bytes seen; overflow detected"))) 861 (define-condition closed-connection (parsing-error) 862 ((description :initform "data received after completed connection: close message"))) 863 (define-condition invalid-version (parsing-error) 864 ((description :initform "invalid HTTP version"))) 865 (define-condition invalid-status (parsing-error) 866 ((description :initform "invalid HTTP status code") 867 (status-code :initarg :status-code 869 (:report (lambda (condition stream) 870 (with-slots (description status-code) condition 871 (format stream "~A: ~A~:[~;~:* (Code=~A)~]" 875 (define-condition invalid-method (parsing-error) 876 ((description :initform "invalid HTTP method"))) 877 (define-condition invalid-url (parsing-error) 878 ((description :initform "invalid URL"))) 879 (define-condition invalid-host (parsing-error) 880 ((description :initform "invalid host"))) 881 (define-condition invalid-port (parsing-error) 882 ((description :initform "invalid port"))) 883 (define-condition invalid-path (parsing-error) 884 ((description :initform "invalid path"))) 885 (define-condition invalid-query-string (parsing-error) 886 ((description :initform "invalid query string"))) 887 (define-condition invalid-fragment (parsing-error) 888 ((description :initform "invalid fragment"))) 889 (define-condition lf-expected (parsing-error) 890 ((description :initform "LF character expected"))) 891 (define-condition invalid-header-token (parsing-error) 892 ((description :initform "invalid character in header"))) 893 (define-condition invalid-content-length (parsing-error) 894 ((description :initform "invalid character in content-length header"))) 895 (define-condition invalid-chunk-size (parsing-error) 896 ((description :initform "invalid character in chunk size header"))) 897 (define-condition invalid-constant (parsing-error) 898 ((description :initform "invalid constant string"))) 900 (define-condition invalid-internal-state (parsing-error) 901 ((description :initform "encountered unexpected internal state") 902 (code :initarg :code)) 904 (lambda (condition stream) 905 (format stream "~A: ~A (Code=~A)" 907 (slot-value condition 'description) 908 (slot-value condition 'code))))) 909 (define-condition strict-error (parsing-error) 910 ((description :initform "strict mode assertion failed") 911 (form :initarg :form)) 913 (lambda (condition stream) 914 (format stream "~A: ~A~% ~A" 916 (slot-value condition 'description) 917 (slot-value condition 'form))))) 918 (define-condition paused-error (parsing-error) 919 ((description :initform "parser is paused"))) 920 (define-condition unknown-error (parsing-error) 921 ((description :initform "an unknown error occured"))) 927 (define-condition multipart-parsing-error (http-error) ()) 929 (define-condition invalid-multipart-body (multipart-parsing-error) 930 ((description :initform "invalid multipart body"))) 931 (define-condition invalid-boundary (multipart-parsing-error) 932 ((description :initform "invalid boundary"))) 936 ;; Header value parsing 938 (define-condition header-value-parsing-error (multipart-parsing-error) ()) 940 (define-condition invalid-header-value (header-value-parsing-error) 941 ((description :initform "invalid header value"))) 942 (define-condition invalid-parameter-key (header-value-parsing-error) 943 ((description :initform "invalid parameter key"))) 944 (define-condition invalid-parameter-value (header-value-parsing-error) 945 ((description :initform "invalid parameter value"))) 951 (declaim (type fixnum +max-header-line+)) 952 (defconstant +max-header-line+ 1024 953 "Maximum number of header lines allowed. 955 This restriction is for protecting users' application 956 against denial-of-service attacks where the attacker feeds 957 us a never-ending header that the application keeps buffering.") 963 (deftype pointer () 'integer) 970 (message-begin nil :type (or null function)) ;; 1 arg 971 (url nil :type (or null function)) 972 (first-line nil :type (or null function)) 973 (status nil :type (or null function)) 974 (header-field nil :type (or null function)) 975 (header-value nil :type (or null function)) 976 (headers-complete nil :type (or null function)) ;; 1 arg 977 (body nil :type (or null function)) 978 (message-complete nil :type (or null function))) 980 (defmacro callback-data (name http callbacks data start end) 981 (with-gensyms (callback e) 982 `(when-let ((,callback (,(format-symbol t "~A-~A" :callbacks name) ,callbacks))) 983 (handler-bind ((error 985 (unless (typep ,e 'http-error) 986 (error ',(format-symbol t "~A-~A" :cb name) 989 (funcall ,callback ,http ,data ,start ,end))))) 991 (defmacro callback-notify (name http callbacks) 992 (with-gensyms (callback e) 993 `(when-let ((,callback (,(format-symbol t "~A-~A" :callbacks name) ,callbacks))) 994 (handler-bind ((error 996 (unless (typep ,e 'http-error) 997 (error ',(format-symbol t "~A-~A" :cb name) 1000 (funcall ,callback ,http))))) 1006 (define-condition eof () ()) 1008 (define-condition expect-failed (parsing-error) 1009 ((description :initform "expect failed"))) 1015 (declaim (type (simple-array character (128)) +tokens+)) 1016 (define-constant +tokens+ 1018 :element-type 'character 1020 '( #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul 1021 #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul 1022 #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul 1023 #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul 1024 #\Nul #\! #\Nul #\# #\$ #\% #\& #\' 1025 #\Nul #\Nul #\* #\+ #\Nul #\- #\. #\Nul 1026 #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 1027 #\8 #\9 #\Nul #\Nul #\Nul #\Nul #\Nul #\Nul 1028 #\Nul #\a #\b #\c #\d #\e #\f #\g 1029 #\h #\i #\j #\k #\l #\m #\n #\o 1030 #\p #\q #\r #\s #\t #\u #\v #\w 1031 #\x #\y #\z #\Nul #\Nul #\Nul #\^ #\_ 1032 #\` #\a #\b #\c #\d #\e #\f #\g 1033 #\h #\i #\j #\k #\l #\m #\n #\o 1034 #\p #\q #\r #\s #\t #\u #\v #\w 1035 #\x #\y #\z #\Nul #\| #\Nul #\~ #\Nul )) 1038 (declaim (type (simple-array fixnum (128)) +unhex+)) 1039 (define-constant +unhex+ 1040 (make-array 128 :element-type 'fixnum :initial-contents 1041 '(-1 -1 -1 -1 -1 -1 -1 -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 1043 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 1044 0 1 2 3 4 5 6 7 8 9 -1 -1 -1 -1 -1 -1 1045 -1 10 11 12 13 14 15 -1 -1 -1 -1 -1 -1 -1 -1 -1 1046 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 1047 -1 10 11 12 13 14 15 -1 -1 -1 -1 -1 -1 -1 -1 -1 1048 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1)) 1051 (defun unhex-byte (byte) 1052 (aref +unhex+ byte)) 1057 (defun parse-method (data start end) 1058 (declare (type octet-vector data) 1059 (type pointer start end)) 1060 (with-octets-parsing (data :start start :end end) 1061 (return-from parse-method 1065 ("CONNECT" :CONNECT) 1067 ("CHECKOUT" :CHECKOUT) 1073 ("MKCALENDAR" :MKCALENDAR) 1074 ("MKACTIVITY" :MKACTIVITY) 1077 ("M-SEARCH" :M-SEARCH) 1079 ("OPTIONS" :OPTIONS) 1081 ("PROPFIND" :PROPFIND) 1082 ("PROPPATCH" :PROPPATCH) 1088 ("SUBSCRIBE" :SUBSCRIBE) 1091 ("UNSUBSCRIBE" :UNSUBSCRIBE) 1092 (otherwise (error 'invalid-method))) 1093 (unless (= (current) +space+) 1094 (error 'invalid-method))) 1098 (defun parse-url (data start end) 1099 (declare (type octet-vector data) 1100 (type pointer start end)) 1101 (flet ((url-char-byte-p (byte) 1102 (or (<= (char-code #\!) byte (char-code #\~)) 1104 (with-octets-parsing (data :start start :end end) 1105 (skip-while url-char-byte-p) 1106 (return-from parse-url (pos))) 1109 (defun parse-http-version (data start end) 1110 (declare (type octet-vector data) 1111 (type pointer start end)) 1113 (with-octets-parsing (data :start start :end end) 1114 (or (match? "HTTP/") 1115 (return-from parse-http-version (values nil nil (pos)))) 1116 (if (digit-byte-char-p (current)) 1117 (setq major (digit-byte-char-to-integer (current))) 1118 (return-from parse-http-version (values nil nil (pos)))) 1120 (or (skip? #\.) (return-from parse-http-version (values nil nil (pos)))) 1121 (if (digit-byte-char-p (current)) 1122 (setq minor (digit-byte-char-to-integer (current))) 1123 (return-from parse-http-version (values nil nil (pos)))) 1125 (return-from parse-http-version 1126 (values major minor (pos)))) 1129 (defun parse-status-code (http callbacks data start end) 1130 (declare (type octet-vector data) 1131 (type pointer start end)) 1132 (or (with-octets-parsing (data :start start :end end) 1133 (if (digit-byte-char-p (current)) 1134 (setf (http-status http) (digit-byte-char-to-integer (current))) 1135 (error 'invalid-status)) 1139 ((digit-byte-char-p (current)) 1140 (setf (http-status http) 1141 (+ (the fixnum (* 10 (http-status http))) 1142 (digit-byte-char-to-integer (current)))) 1143 (when (< 999 (http-status http)) 1144 (error 'invalid-status :status-code (http-status http)))) 1145 ((= (current) +space+) 1146 ;; Reading the status text 1148 (let ((status-text-start (pos))) 1149 (skip* (not #\Return)) 1152 (callback-data :status http callbacks data status-text-start (- (pos) 1))) 1159 (T (error 'invalid-status)))) 1163 (defun parse-header-field-and-value (http callbacks data start end) 1164 (declare (type octet-vector data) 1165 (type pointer start end)) 1167 (with-octets-parsing (data :start start :end end) 1168 (let ((field-start (pos)) 1170 (macrolet ((skip-until-value-start-and (&body body) 1172 ;; skip #\: and leading spaces 1174 (skip* #\Space #\Tab) 1177 ;; continue to the next line 1181 ((or (= (current) +space+) 1182 (= (current) +tab+)) 1183 (skip* #\Space #\Tab) 1184 (if (= (current) +cr+) 1189 (callback-data :header-field http callbacks data field-start field-end) 1190 (callback-data :header-value http callbacks data (pos) (pos))) 1194 (callback-data :header-field http callbacks data field-start field-end) 1195 (callback-data :header-value http callbacks data (pos) (pos))))) 1197 (handle-otherwise () 1199 ;; skip until field end 1200 (do ((char (aref +tokens+ (current)) 1201 (aref +tokens+ (current)))) 1202 ((= (current) (char-code #\:))) 1203 (declare (type character char)) 1204 (when (char= char #\Nul) 1205 (error 'invalid-header-token)) 1208 (setq field-end (pos)) 1209 (skip-until-value-start-and 1211 (parse-header-value http callbacks data (pos) end field-start field-end))))) 1212 (expect-field-end (&body body) 1213 `(if (= (current) #.(char-code #\:)) 1215 (setq field-end (pos)) 1217 (handle-otherwise)))) 1221 (skip-until-value-start-and 1222 (multiple-value-bind (value-start value-end next content-length) 1223 (parse-header-value-content-length data (pos) end) 1224 (declare (type pointer next)) 1225 (setf (http-content-length http) content-length) 1227 (callback-data :header-field http callbacks data field-start field-end) 1228 (callback-data :header-value http callbacks data value-start value-end))))) 1229 ("transfer-encoding" 1231 (skip-until-value-start-and 1232 (multiple-value-bind (value-start value-end next chunkedp) 1233 (parse-header-value-transfer-encoding data (pos) end) 1234 (declare (type pointer next)) 1235 (setf (http-chunked-p http) chunkedp) 1237 (callback-data :header-field http callbacks data field-start field-end) 1238 (callback-data :header-value http callbacks data value-start value-end))))) 1241 (skip-until-value-start-and 1242 (setf (http-upgrade-p http) T) 1243 (let ((value-start (pos))) 1244 (skip* (not #\Return)) 1247 (callback-data :header-field http callbacks data field-start field-end) 1248 (callback-data :header-value http callbacks data value-start (- (pos) 2)))))) 1249 (otherwise (handle-otherwise))))) 1253 (defun parse-header-value (http callbacks data start end &optional field-start field-end) 1254 (or (with-octets-parsing (data :start start :end end) 1255 (skip* (not #\Return)) 1259 (callback-data :header-field http callbacks data field-start field-end)) 1260 (callback-data :header-value http callbacks data start (- (pos) 2)) 1264 (defun parse-header-value-transfer-encoding (data start end) 1265 (declare (type octet-vector data) 1266 (type pointer start end)) 1267 (with-octets-parsing (data :start start :end end) 1270 (if (= (current) +cr+) 1274 (return-from parse-header-value-transfer-encoding 1275 (values start (- (pos) 2) (pos) t))) 1277 (skip+ (not #\Return)) 1280 (return-from parse-header-value-transfer-encoding 1281 (values start (- (pos) 2) (pos) nil))))) 1283 (skip* (not #\Return)) 1286 (return-from parse-header-value-transfer-encoding 1287 (values start (- (pos) 2) (pos) nil))))) 1290 (defun parse-header-value-content-length (data start end) 1291 (declare (type octet-vector data) 1292 (type pointer start end)) 1293 (let ((content-length 0)) 1294 (declare (type integer content-length)) 1295 (with-octets-parsing (data :start start :end end) 1296 (if (digit-byte-char-p (current)) 1297 (setq content-length (digit-byte-char-to-integer (current))) 1298 (error 'invalid-content-length)) 1302 ((digit-byte-char-p (current)) 1303 (setq content-length 1304 (+ (* 10 content-length) 1305 (digit-byte-char-to-integer (current))))) 1309 (return-from parse-header-value-content-length 1310 (values start (- (pos) 2) (pos) content-length))) 1311 ((= (current) +space+) 1314 (t (error 'invalid-content-length))))) 1317 (defun parse-header-line (http callbacks data start end) 1318 (declare (type octet-vector data) 1319 (type pointer start end)) 1320 (when (<= end start) 1322 (let ((current (aref data start))) 1323 (declare (type (unsigned-byte 8) current)) 1325 ((or (= current +tab+) 1326 (= current +space+)) 1327 (parse-header-value http callbacks data start end)) 1329 (parse-header-field-and-value http callbacks data start end)) 1334 (setq current (aref data start)) 1335 (unless (= current +lf+) 1336 (error 'expect-failed)) 1337 (values (1+ start) t))))) 1339 (defun parse-headers (http callbacks data start end) 1340 (declare (type http http) 1341 (type octet-vector data) 1342 (type pointer start end)) 1343 (or (with-octets-parsing (data :start start :end end) 1345 (when (= (current) +cr+) 1347 (if (= (current) +lf+) 1348 (return-from parse-headers (1+ (pos))) 1349 (error 'expect-failed))) 1351 (advance-to* (parse-header-field-and-value http callbacks data start end)) 1353 (setf (http-mark http) (pos)) 1355 (when (= +max-header-line+ (the fixnum (incf (http-header-read http)))) 1356 (error 'header-overflow)) 1357 (multiple-value-bind (next endp) 1358 (parse-header-line http callbacks data (pos) end) 1362 (setf (http-mark http) (pos))) 1363 (setf (http-mark http) (pos)) 1364 (setf (http-state http) +state-body+) 1369 (defun read-body-data (http callbacks data start end) 1370 (declare (type http http) 1371 (type octet-vector data) 1372 (type pointer start end)) 1373 (let ((readable-count (the pointer (- end start)))) 1374 (declare (dynamic-extent readable-count) 1375 (type pointer readable-count)) 1376 (if (<= (http-content-length http) readable-count) 1377 (let ((body-end (+ start (http-content-length http)))) 1378 (declare (dynamic-extent body-end)) 1379 (setf (http-content-length http) 0) 1380 (callback-data :body http callbacks data start body-end) 1381 (setf (http-mark http) body-end) 1382 (values body-end t)) 1383 ;; still needs to read 1385 (decf (http-content-length http) readable-count) 1386 (callback-data :body http callbacks data start end) 1387 (setf (http-mark http) end) 1388 (values end nil))))) 1390 (defun http-message-needs-eof-p (http) 1391 (let ((status-code (http-status http))) 1392 (declare (type status-code status-code)) 1393 (when (= status-code 0) ;; probably request 1394 (return-from http-message-needs-eof-p nil)) 1396 (when (or (< 99 status-code 200) ;; 1xx e.g. Continue 1397 (= status-code 204) ;; No Content 1398 (= status-code 304)) ;; Not Modified 1399 (return-from http-message-needs-eof-p nil)) 1401 (when (or (http-chunked-p http) 1402 (http-content-length http)) 1403 (return-from http-message-needs-eof-p nil)) 1406 (defun parse-http-body (http callbacks data start end requestp) 1407 (declare (type http http) 1408 (type octet-vector data) 1409 (type pointer start end)) 1410 (macrolet ((message-complete () 1412 (callback-notify :message-complete http callbacks) 1413 (setf (http-state http) +state-first-line+)))) 1414 (case (http-content-length http) 1416 ;; Content-Length header given but zero: Content-Length: 0\r\n 1421 (not (http-message-needs-eof-p http))) 1422 ;; Assume content-length 0 - read the next 1425 ;; By returning "start", we'll continue 1426 ;; to parse the next request in case if 1427 ;; HTTP pipelining is used. Probably 1428 ;; we need some way to enable (or disable) 1429 ;; HTTP pipelining support. 1433 (callback-data :body http callbacks data start end) 1434 (setf (http-mark http) end) 1438 ;; Content-Length header given and non-zero 1439 (multiple-value-bind (next completedp) 1440 (read-body-data http callbacks data start end) 1445 (defun parse-chunked-body (http callbacks data start end) 1446 (declare (type http http) 1447 (type octet-vector data) 1448 (type pointer start end)) 1451 (return-from parse-chunked-body start)) 1453 (or (with-octets-parsing (data :start start :end end) 1456 ((= (http-state http) +state-chunk-size+) 1458 ((= (http-state http) +state-body+) 1460 ((= (http-state http) +state-chunk-body-end-crlf+) 1462 ((= (http-state http) +state-trailing-headers+) 1463 (go trailing-headers)) 1464 (T (error 'invalid-internal-state :code (http-state http)))) 1467 (let ((unhex-val (unhex-byte (current)))) 1468 (declare (type fixnum unhex-val) 1469 (dynamic-extent unhex-val)) 1470 (when (= unhex-val -1) 1471 (error 'invalid-chunk-size)) 1472 (setf (http-content-length http) unhex-val) 1476 (if (= (current) +cr+) 1484 (setq unhex-val (unhex-byte (current))) 1488 ((or (= (current) (char-code #\;)) 1489 (= (current) (char-code #\Space))) 1490 (skip* (not #\Return)) 1496 (t (error 'invalid-chunk-size)))) 1497 (t (setf (http-content-length http) 1498 (+ (* 16 (http-content-length http)) unhex-val))))))) 1499 (setf (http-state http) +state-body+) 1501 (return-from parse-chunked-body (pos)) 1502 (setf (http-mark http) (pos)))) 1506 ((zerop (http-content-length http)) 1508 (setf (http-state http) +state-trailing-headers+) 1509 (go trailing-headers)) 1511 (multiple-value-bind (next completedp) 1512 (read-body-data http callbacks data (pos) end) 1513 (declare (type pointer next)) 1515 (return-from parse-chunked-body (pos))) 1516 (setf (http-state http) +state-chunk-body-end-crlf+) 1517 (advance-to next)))) 1524 (setf (http-state http) +state-chunk-size+) 1526 (return-from parse-chunked-body (pos)))) 1527 (setf (http-mark http) (pos)) 1531 (return-from parse-chunked-body 1532 (prog1 (parse-headers http callbacks data (pos) end) 1533 (callback-notify :message-complete http callbacks))))) 1536 (defun parse-request (http callbacks data &key (start 0) end (head-request nil)) 1537 (declare (type http http) 1538 (type octet-vector data) 1539 (ignorable head-request)) 1540 (let ((end (or end (length data)))) 1541 (declare (type pointer start end)) 1542 (handler-bind ((match-failed 1544 (declare (ignore c)) 1545 (error 'expect-failed)))) 1546 (with-octets-parsing (data :start start :end end) 1547 (setf (http-mark http) start) 1550 (let ((state (http-state http))) 1551 (declare (type fixnum state)) 1553 ((= +state-first-line+ state) 1555 ((= +state-headers+ state) 1557 ((<= +state-chunk-size+ state +state-trailing-headers+) 1559 (T (error 'invalid-internal-state :code state)))) 1562 ;; skip first empty line (some clients add CRLF after POST content) 1563 (when (= (current) +cr+) 1569 (return-from parse-request (pos))))) 1571 (setf (http-mark http) (pos)) 1572 (callback-notify :message-begin http callbacks) 1574 (multiple-value-bind (method next) 1575 (parse-method data (pos) end) 1576 (declare (type pointer next)) 1577 (setf (http-method http) method) 1580 (let ((url-start-mark (pos)) 1581 (url-end-mark (parse-url data (pos) end))) 1582 (declare (type pointer url-start-mark url-end-mark)) 1583 (tagbody retry-url-parse 1584 (advance-to* url-end-mark) 1591 (callback-data :url http callbacks data url-start-mark url-end-mark) 1594 (t (multiple-value-bind (major minor next) 1595 (parse-http-version data (pos) end) 1596 (declare (type pointer next)) 1598 ;; Invalid HTTP version. 1599 ;; Assuming it's also a part of URI. 1600 (let ((new-url-end-mark (parse-url data next end))) 1601 (when (= url-end-mark new-url-end-mark) 1602 (error 'invalid-version)) 1603 (setq url-end-mark new-url-end-mark) 1604 (go retry-url-parse))) 1605 (callback-data :url http callbacks data url-start-mark url-end-mark) 1606 (setf (http-major-version http) major 1607 (http-minor-version http) minor) 1610 (skip #\Newline))))) 1612 (setf (http-mark http) (pos)) 1613 (setf (http-state http) +state-headers+) 1614 (callback-notify :first-line http callbacks) 1617 (advance-to* (parse-headers http callbacks data (pos) end)) 1619 (callback-notify :headers-complete http callbacks) 1620 (setf (http-header-read http) 0) 1622 ;; Exit, the rest of the connect is in a different protocol. 1623 (when (http-upgrade-p http) 1624 (setf (http-state http) +state-first-line+) 1625 (callback-notify :message-complete http callbacks) 1626 (return-from parse-request (pos))) 1628 (setf (http-state http) 1629 (if (http-chunked-p http) 1634 (if (http-chunked-p http) 1635 (advance-to* (parse-chunked-body http callbacks data (pos) end)) 1637 (and (advance-to* (parse-http-body http callbacks data (pos) end t)) 1639 (return-from parse-request (pos))))) 1642 (defun parse-response (http callbacks data &key (start 0) end (head-request nil)) 1643 (declare (type http http) 1644 (type octet-vector data)) 1647 (declare (type pointer start end)) 1648 (handler-bind ((match-failed 1650 (declare (ignore c)) 1651 (error 'expect-failed)))) 1652 (with-octets-parsing (data :start start :end end) 1653 (setf (http-mark http) start) 1656 (let ((state (http-state http))) 1657 (declare (type fixnum state)) 1659 ((= +state-first-line+ state) 1661 ((= +state-headers+ state) 1663 ((<= +state-chunk-size+ state +state-trailing-headers+) 1665 (T (error 'invalid-internal-state :code state)))) 1668 (setf (http-mark http) (pos)) 1669 (callback-notify :message-begin http callbacks) 1671 (multiple-value-bind (major minor next) 1672 (parse-http-version data (pos) end) 1673 (declare (type pointer next)) 1674 (setf (http-major-version http) major 1675 (http-minor-version http) minor) 1679 ((= (current) +space+) 1681 (advance-to (parse-status-code http callbacks data (pos) end))) 1684 (T (error 'invalid-version))) 1686 (setf (http-mark http) (pos)) 1687 (setf (http-state http) +state-headers+) 1688 (callback-notify :first-line http callbacks) 1691 (advance-to* (parse-headers http callbacks data (pos) end)) 1693 (callback-notify :headers-complete http callbacks) 1694 (setf (http-header-read http) 0) 1695 (setf (http-state http) 1696 (if (http-chunked-p http) 1701 (callback-notify :message-complete http callbacks) 1702 (setf (http-state http) +state-first-line+) 1703 (return-from parse-response (pos))) 1706 (if (http-chunked-p http) 1707 (advance-to* (parse-chunked-body http callbacks data (pos) end)) 1709 (advance-to* (parse-http-body http callbacks data (pos) end nil)) 1712 (return-from parse-response (pos))))) 1715 (defun parse-header-value-parameters (data &key 1716 header-value-callback 1717 header-parameter-key-callback 1718 header-parameter-value-callback) 1719 (declare (type simple-string data) 1720 (optimize (speed 3) (safety 2))) 1722 (let* ((header-name-mark 0) 1724 parameter-value-mark 1725 parsing-quoted-string-p 1728 (char (aref data p))) 1729 (declare (type character char)) 1732 (return-from parse-header-value-parameters 0)) 1734 (macrolet ((go-state (state &optional (advance 1)) 1735 `(locally (declare (optimize (speed 3) (safety 0))) 1739 (setq char (aref data p)) 1741 (flet ((tokenp (char) 1742 (declare (optimize (speed 3) (safety 0))) 1743 (let ((byte (char-code char))) 1745 (not (char= (the character (aref +tokens+ byte)) #\Nul)))))) 1747 parsing-header-value-start 1750 (go-state parsing-header-value)) 1752 (unless (tokenp char) 1753 (error 'invalid-header-value)) 1754 (setq header-name-mark p) 1755 (go-state parsing-header-value 0))) 1757 parsing-header-value 1760 (when header-value-callback 1761 (funcall (the function header-value-callback) 1762 data header-name-mark p)) 1763 (setq header-name-mark nil) 1764 (go-state looking-for-parameter-key)) 1765 (otherwise (go-state parsing-header-value))) 1767 looking-for-parameter-key 1769 ((#\Space #\Tab #\; #\Newline #\Return) 1770 (go-state looking-for-parameter-key)) 1772 (unless (tokenp char) 1773 (error 'invalid-parameter-key)) 1774 (setq parameter-key-mark p) 1775 (go-state parsing-parameter-key))) 1777 parsing-parameter-key 1780 (assert parameter-key-mark) 1781 (when header-parameter-key-callback 1782 (funcall (the function header-parameter-key-callback) 1783 data parameter-key-mark p)) 1784 (setq parameter-key-mark nil) 1785 (go-state parsing-parameter-value-start)) 1787 (unless (tokenp char) 1788 (error 'invalid-parameter-key)) 1789 (go-state parsing-parameter-key))) 1791 parsing-parameter-value-start 1795 (setq parameter-value-mark (1+ p)) 1796 (setq parsing-quoted-string-p t) 1797 (go-state parsing-parameter-quoted-value)) 1798 ((#.+space+ #.+tab+) 1799 (go-state parsing-parameter-value-start)) 1801 (setq parameter-value-mark p) 1802 (go-state parsing-parameter-value 0))) 1804 parsing-parameter-quoted-value 1805 (if (char= char #\") 1807 (assert parameter-value-mark) 1808 (setq parsing-quoted-string-p nil) 1809 (when header-parameter-value-callback 1810 (funcall (the function header-parameter-value-callback) 1811 data parameter-value-mark p)) 1812 (setq parameter-value-mark nil) 1813 (go-state looking-for-parameter-key)) 1814 (go-state parsing-parameter-quoted-value)) 1816 parsing-parameter-value 1819 (assert parameter-value-mark) 1820 (when header-parameter-value-callback 1821 (funcall (the function header-parameter-value-callback) 1822 data parameter-value-mark p)) 1823 (setq parameter-value-mark nil) 1824 (go-state looking-for-parameter-key)) 1826 (go-state parsing-parameter-value))) 1829 (when header-name-mark 1830 (when header-value-callback 1831 (funcall (the function header-value-callback) 1832 data header-name-mark p))) 1833 (when parameter-key-mark 1834 (error 'invalid-eof-state)) 1835 (when parameter-value-mark 1836 (when parsing-quoted-string-p 1837 (error 'invalid-eof-state)) 1838 (when header-parameter-value-callback 1839 (funcall (the function header-parameter-value-callback) 1840 data parameter-value-mark p))))))