From 61e6b430d30db4e2ae14533700d3f2d54d375602 Mon Sep 17 00:00:00 2001 From: Xu Jingtao Date: Wed, 29 May 2013 15:30:54 +0800 Subject: [PATCH 1/4] following the token syntax of java/python. --- read.lisp | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/read.lisp b/read.lisp index 7a9ffbd..9aa4c64 100644 --- a/read.lisp +++ b/read.lisp @@ -61,10 +61,12 @@ HTTP-REQUEST. Returns NIL if there is no such header amongst HEADERS." (when-let (content-type (header-value :content-type headers)) (with-sequence-from-string (stream content-type) - (let* ((*current-error-message* "Corrupted Content-Type header:") + (let* ((*current-error-message* (format nil "Corrupted Content-Type header:(~s)" content-type)) (type (read-token stream)) - (subtype (and (assert-char stream #\/) - (read-token stream))) + (subtype (let ((subtype-pos (position #\/ type :test #'char=))) + (cond (subtype-pos + (prog1 (subseq type (1+ subtype-pos)) + (setf type (subseq type 0 subtype-pos))))))) (parameters (read-name-value-pairs stream))) (values type subtype parameters))))) From 2905acfdeac14a6a9671ccc144d2fa1e94fd2d0d Mon Sep 17 00:00:00 2001 From: Jingtao Xu Date: Mon, 26 Jun 2017 16:53:22 +0800 Subject: [PATCH 2/4] add timeout support for sbcl. --- request.lisp | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/request.lisp b/request.lisp index de82b2f..73fe319 100644 --- a/request.lisp +++ b/request.lisp @@ -229,6 +229,7 @@ headers of the chunked stream \(if any) as a second value." #+:lispworks (read-timeout 20) #+(and :lispworks (not :lw-does-not-have-write-timeout)) (write-timeout 20 write-timeout-provided-p) + #+sbcl (io-timeout 20) #+:openmcl deadline &aux (unparsed-uri (if (stringp uri) (copy-seq uri) (puri:copy-uri uri)))) @@ -574,6 +575,10 @@ Any encodings in Transfer-Encoding, such as chunking, are always performed." connection-timeout :nodelay :if-supported))) raw-http-stream http-stream) + #+sbcl + (when io-timeout + (setf (sb-impl::fd-stream-timeout http-stream) + (coerce io-timeout 'single-float))) #+:openmcl (when deadline ;; it is correct to set the deadline here even though From a960fa3e36150a4a54332782f9ef16ad4abdfab0 Mon Sep 17 00:00:00 2001 From: Jingtao Xu Date: Wed, 4 Jan 2023 19:16:16 +0800 Subject: [PATCH 3/4] Add support to encode unicode characters in uri path. --- request.lisp | 37 +++++++++++++++++++++++-------------- 1 file changed, 23 insertions(+), 14 deletions(-) diff --git a/request.lisp b/request.lisp index 73fe319..389b30c 100644 --- a/request.lisp +++ b/request.lisp @@ -223,6 +223,7 @@ headers of the chunked stream \(if any) as a second value." want-stream stream preserve-uri + (encode-unicode-path-p t) decode-content ; default to nil for backwards compatibility #+(or abcl clisp lispworks mcl openmcl sbcl) (connection-timeout 20) @@ -658,20 +659,28 @@ Any encodings in Transfer-Encoding, such as chunking, are always performed." (puri:uri-query uri) nil)) (write-http-line "~A ~A ~A" (string-upcase method) - (if (and preserve-uri - (stringp unparsed-uri)) - (trivial-uri-path unparsed-uri) - (puri:render-uri (if (and proxy - (null stream) - (not proxying-https-p) - (not real-host)) - uri - (make-instance 'puri:uri - :path (puri:uri-path uri) - :parsed-path (puri:uri-parsed-path uri) - :query (puri:uri-query uri) - :escaped t)) - nil)) + (let ((uri-string (if (and preserve-uri + (stringp unparsed-uri)) + (trivial-uri-path unparsed-uri) + (puri:render-uri (if (and proxy + (null stream) + (not proxying-https-p) + (not real-host)) + uri + (make-instance 'puri:uri + :path (puri:uri-path uri) + :parsed-path (puri:uri-parsed-path uri) + :query (puri:uri-query uri) + :escaped t)) + nil)))) + (if encode-unicode-path-p + (with-output-to-string (*standard-output*) + (loop for c across uri-string + if (> (char-code c) 255) + ;; It's not a latin-1 character, so we need to encode it. + do (write-string (funcall url-encoder (format nil "~c" c) external-format-in)) + else do (write-char c))) + uri-string)) (string-upcase protocol)) (when (not (assoc "Host" additional-headers :test #'string-equal)) (write-header "Host" "~A~@[:~A~]" (puri:uri-host uri) (non-default-port uri))) From fcb123422a80c09ee24ce5e5ad257059b3992b8e Mon Sep 17 00:00:00 2001 From: Jingtao Xu Date: Wed, 31 May 2023 14:28:05 +0800 Subject: [PATCH 4/4] fix up drakma for LispWorks 8.0 --- drakma.asd | 2 +- request.lisp | 20 ++++++++++---------- util.lisp | 2 +- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/drakma.asd b/drakma.asd index 41765e6..e4d5974 100644 --- a/drakma.asd +++ b/drakma.asd @@ -59,7 +59,7 @@ :cl-ppcre #-:drakma-no-chipz :chipz #-:lispworks :usocket - #-(or :lispworks7.1 (and :allegro (not :allegro-cl-express)) :mocl-ssl :drakma-no-ssl) :cl+ssl) + #-(or :lispworks7+ (and :allegro (not :allegro-cl-express)) :mocl-ssl :drakma-no-ssl) :cl+ssl) :perform (test-op (o s) (asdf:load-system :drakma-test) (asdf:perform 'asdf:test-op :drakma-test))) diff --git a/request.lisp b/request.lisp index 4a8d3f9..f814d0b 100644 --- a/request.lisp +++ b/request.lisp @@ -160,7 +160,7 @@ headers of the chunked stream \(if any) as a second value." (header-value :content-length headers))) (parse-integer value))) (element-type (if textp - #+:lispworks7.1 'lw:simple-char #-:lispworks7.1 'character + #+:lispworks7+ 'lw:simple-char #-:lispworks7+ 'character 'octet))) (values (cond ((eql content-length 0) nil) (content-length @@ -240,8 +240,8 @@ headers of the chunked stream \(if any) as a second value." decode-content ; default to nil for backwards compatibility #+(or abcl clisp lispworks mcl openmcl sbcl) (connection-timeout 20) - #+:lispworks7.1 (read-timeout 20) - #+(and :lispworks7.1 (not :lw-does-not-have-write-timeout)) + #+:lispworks7+ (read-timeout 20) + #+(and :lispworks7+ (not :lw-does-not-have-write-timeout)) (write-timeout 20 write-timeout-provided-p) #+sbcl (io-timeout 20) #+:openmcl @@ -491,7 +491,7 @@ decoded according to any encodings specified in the Content-Encoding header. The actual decoding is done by the DECODE-STREAM generic function, and you can implement new methods to support additional encodings. Any encodings in Transfer-Encoding, such as chunking, are always performed." - #+lispworks7.1 + #+lispworks7+ (declare (ignore certificate key certificate-password verify max-depth ca-file ca-directory)) (unless (member protocol '(:http/1.0 :http/1.1) :test #'eq) (parameter-error "Don't know how to handle protocol ~S." protocol)) @@ -570,7 +570,7 @@ Any encodings in Transfer-Encoding, such as chunking, are always performed." (drakma-warn "Disabling WRITE-TIMEOUT because it doesn't mix well with SSL.")) (setq write-timeout nil)) (setq http-stream (or stream - #+:lispworks7.1 + #+:lispworks7+ (comm:open-tcp-stream host port :element-type 'octet :timeout connection-timeout @@ -580,7 +580,7 @@ Any encodings in Transfer-Encoding, such as chunking, are always performed." #-:lw-does-not-have-write-timeout write-timeout :errorp t) - #-:lispworks7.1 + #-:lispworks7+ (usocket:socket-stream (usocket:socket-connect host port :element-type 'octet @@ -616,14 +616,14 @@ Any encodings in Transfer-Encoding, such as chunking, are always performed." (when (and use-ssl ;; don't attach SSL to existing streams (not stream)) - #+:lispworks7.1 + #+:lispworks7+ (comm:attach-ssl http-stream :ssl-side :client #-(or lispworks4 lispworks5 lispworks6) :tlsext-host-name #-(or lispworks4 lispworks5 lispworks6) (puri:uri-host uri)) - #-:lispworks7.1 + #-:lispworks7+ (setq http-stream (make-ssl-stream http-stream :hostname (puri:uri-host uri) :certificate certificate @@ -657,14 +657,14 @@ Any encodings in Transfer-Encoding, such as chunking, are always performed." ;; got a connection; we have to read a blank line, ;; turn on SSL, and then we can transmit (read-line* http-stream) - #+:lispworks7.1 + #+:lispworks7+ (comm:attach-ssl raw-http-stream :ssl-side :client #-(or lispworks4 lispworks5 lispworks6) :tlsext-host-name #-(or lispworks4 lispworks5 lispworks6) (puri:uri-host uri)) - #-:lispworks7.1 + #-:lispworks7+ (setq http-stream (wrap-stream (make-ssl-stream raw-http-stream :hostname (puri:uri-host uri) diff --git a/util.lisp b/util.lisp index d8bde96..c49f90c 100644 --- a/util.lisp +++ b/util.lisp @@ -295,7 +295,7 @@ which are not meant as separators." (setq cookie-start (1+ end-pos)) (go next-cookie)))))) -#-:lispworks7.1 +#-:lispworks7+ (defun make-ssl-stream (http-stream &key certificate key certificate-password verify (max-depth 10) ca-file ca-directory hostname) "Attaches SSL to the stream HTTP-STREAM and returns the SSL stream