;;;; WHJ.20180504
;;;; 创建HTTP GET、POST、HEAD测试
;;;; WHJ.20200220
;;;; 完善优化
(in-package :cl-user)
(defparameter +newline+ (coerce (list #\return #\newline ) 'string))
;当前与服务器的sockt连接
(defparameter *conn* nil)
;文档内容编码格式
(defvar *html-charset* charset:utf-8)
;创建 socket连接
(defun cli-init (host &optional (port 80))
(handler-case
(progn
(socket-status *conn*)
(close *conn*))
(error (e) nil))
(setf *conn* (socket-connect port host :external-format :unix)))
(defun http-stream-mode (byte-flag)
(setf (stream-element-type *conn*) (if byte-flag '(unsigned-byte 8) 'character)))
(defun string2bytes (string)
(convert-string-to-bytes string *html-charset*))
(defun http-write-string (str)
(write-string str *conn*))
(defun http-write (string &optional (newline t))
;(format *debug-io* "DEBUG:~a~%" string)
(http-write-string string)
(when newline
(http-write-string +newline+)))
(defun http-write-bytes (vec)
(write-sequence vec *conn*))
(defun http-read-byte ()
(read-byte *conn* nil))
(defun http-read-line ()
(read-line *conn* nil))
(defun urlencode (string)
(reduce
(lambda (x y) (format nil "~a%~(~x~)" x y))
(convert-string-to-bytes string *html-charset*)
:initial-value ""))
;解析k=v,分别对k，v 调用urlencode得到 k1,v1 ,然后再合成k1=v1
(defun encode-keyvalue-string (kv-string)
(let ((index= (search "=" kv-string)))
(format nil "~a=~a" (urlencode (subseq kv-string 0 index=)) (urlencode (subseq kv-string (1+ index=))))))
(defun get-content-length (html-header-list)
(let* ((flag "Content-Length:")
(content-length-header (find-if (lambda (x) (search flag x)) html-header-list)))
(if content-length-header
(parse-integer (subseq content-length-header (+ (search flag content-length-header) (length flag))) :junk-allowed t)
0)))
(defun decode-bytes (byte-sequence charset)
(convert-string-from-bytes
(if (listp byte-sequence)
(coerce byte-sequence 'vector)
byte-sequence)
charset))
(defun split-url (url)
(let* ((s (+ 3 (search "://" url)))
(e (search "/" url :start2 s)))
(unless e (setf e (length url)))
(let ((host (subseq url s e))
(rel-url (subseq url e))
(port (if (search "http:" (string-downcase url)) 80 443)))
(let ((p1 (position #\: host :from-end t)))
(when p1
(setf port (parse-integer (subseq host (1+ p1)))
host (subseq host 0 p1))))
(values host port (if (string= rel-url "") "/" rel-url)))))
;;;; for test
(defun save-to-file (vbuf file)
(with-open-file (out file :direction :output :element-type '(unsigned-byte 8))
(write-sequence vbuf out)))
(defun read-file-bytes (file)
(with-open-file (in file :direction :input :element-type '(unsigned-byte 8))
(let ((vbuf (make-array (file-length in))))
(read-sequence vbuf in)
vbuf)))
;http://www.lispworks.com/documentation/HyperSpec/Graphics/LWLarge.gif
(defun http-get-file (url)
(multiple-value-bind (host port rel-url) (split-url url)
(cli-init host port)
(http-stream-mode nil)
(http-write (format nil "GET ~a HTTP/1.1" rel-url))
(http-write (format nil "Host: ~a" host))
(http-write "User-Agent: Mozilla/5.0 (Windows NT 6.1; WOW64; Trident/7.0; rv:11.0) like Gecko")
(http-write +newline+ t)
(terpri *debug-io*)
(when *conn*
(http-stream-mode nil)
(let* ((tmp-list (loop for x = (http-read-line)
while (and x (plusp (length x)))
collect x))
(content-length (get-content-length tmp-list)))
(http-stream-mode t)
;读取返回内容
(coerce (loop for i from 0 to (1- content-length) for x = (http-read-byte) while x collect x) 'vector)))))
(defun http-get (url)
(multiple-value-bind (host port rel-url) (split-url url)
(cli-init host port)
(http-stream-mode nil)
(http-write (format nil "GET ~a HTTP/1.1" rel-url))
(http-write (format nil "Host: ~a" host))
(http-write "User-Agent: Mozilla/5.0 (Windows NT 6.1; WOW64; Trident/7.0; rv:11.0) like Gecko")
(http-write +newline+ nil)
(when *conn*
(http-stream-mode nil)
(let* ((tmp-list (loop for x = (http-read-line)
while (and x (plusp (length x)))
collect x))
(content-length (get-content-length tmp-list)))
(http-stream-mode t)
;读取返回内容
(format *debug-io* "DEBUG: content-length:~a~%" content-length)
(let ((vbuf (make-array (1- content-length))))
(read-sequence vbuf *conn*)
(values
(decode-bytes
;(loop for i from 0 to (1- content-length) for x = (http-read-byte) while x collect x)
vbuf
*html-charset*)
tmp-list))))))
(defun http-post (url data)
;转义 data 特殊字符
(setf data
(reduce
(lambda (x y) (format nil "~a&~a" x y))
(mapcar #'encode-keyvalue-string (split #\& data))))
(multiple-value-bind (host port rel-url) (split-url url)
(cli-init host port)
(http-write (format nil "POST ~a HTTP/1.1" rel-url))
(http-write (format nil "Host: ~a" host))
(http-write "Content-Type: application/x-www-form-urlencoded")
(http-write (format nil "Content-Length: ~d" (length data)))
(http-write +newline+ nil)
(http-write data nil)
(when *conn*
(http-stream-mode nil)
(let* ((tmp-list (loop for x = (http-read-line)
while (and x (plusp (length x)))
collect x))
(content-length (get-content-length tmp-list)))
(http-stream-mode t)
;读取返回内容
(decode-bytes
(loop for i from 0 to (1- content-length) for x = (http-read-byte) while x collect x)
*html-charset*)))))
(defun vector-append-vector-or-list (dst-vector src-vector-or-list)
(map 'vector (lambda (x) (vector-push-extend x dst-vector)) src-vector-or-list)
dst-vector)
(defun http-post-form-data-header (boundary)
(string2bytes
(with-output-to-string (out)
(format out "Content-Type: multipart/form-data; boundary=~a" boundary)
(format out "~a~a" #\return #\newline)
(format out "~a~a" #\return #\newline))))
(defun http-post-form-data-text (boundary name text)
(string2bytes (with-output-to-string (out)
(format out "--~a" boundary)
(format out "~a~a" #\return #\newline)
(format out "content-disposition: form-data; name=~s" name)
(format out "~a~a" #\return #\newline)
(format out "~a~a" #\return #\newline)
(format out text)
(format out "~a~a" #\return #\newline))))
(defun http-post-form-data-file (boundary name filepath fileName content-type)
(let ((vtmp (make-array 4096 :fill-pointer 0 :adjustable t)))
(vector-append-vector-or-list
vtmp
(string2bytes (with-output-to-string (out)
(format out "--~a" boundary)
(format out "~a~a" #\return #\newline)
(format out "content-disposition: form-data; name=~s; filename=~s" name fileName)
(format out "~a~a" #\return #\newline)
(format out "content-type: ~a" content-type)
(format out "~a~a" #\return #\newline)
(format out "~a~a" #\return #\newline)
)))
(vector-append-vector-or-list vtmp (read-file-bytes filepath))
(vector-append-vector-or-list vtmp (list 13 10))
vtmp))
(defun http-post2 (url)
(multiple-value-bind (host port rel-url) (split-url url)
(cli-init host port)
(let (vtmp
(len 0)
(boundary "AAAAA")
(vbuf (make-array 4096 :fill-pointer 0 :adjustable t)))
(vector-append-vector-or-list vbuf (http-post-form-data-header boundary))
(setf vtmp (http-post-form-data-text boundary "text1" "abcd"))
(vector-append-vector-or-list vbuf vtmp)
(incf len (length vtmp))
(setf vtmp (http-post-form-data-text boundary "text2" "这是汉字部分"));
(vector-append-vector-or-list vbuf vtmp)
(incf len (length vtmp))
(setf vtmp (http-post-form-data-file boundary "file1" "e:\\aa.png" "mytest1.png" "image/png"))
(vector-append-vector-or-list vbuf vtmp)
(incf len (length vtmp))
(setf vtmp (http-post-form-data-file boundary "file2" "e:\\aa.png" "mytest2.png" "image/png"))
(vector-append-vector-or-list vbuf vtmp)
(incf len (length vtmp))
(setf vtmp (http-post-form-data-file boundary "file3" "e:\\ChromeSetup.exe" "ch.exe" "application/octer-stream"))
(vector-append-vector-or-list vbuf vtmp)
(incf len (length vtmp))
(setf vtmp (string2bytes (format nil "--~a--" boundary)))
(vector-append-vector-or-list vbuf vtmp)
(incf len (length vtmp))
(http-write (format nil "POST ~a HTTP/1.1" rel-url))
(http-write (format nil "Host: ~a" host))
(http-write (format nil "Content-Length: ~a" len))
(http-write-bytes vbuf))
(when *conn*
(http-stream-mode nil)
(let* ((tmp-list (loop for x = (http-read-line)
while (and x (plusp (length x)))
collect x))
(content-length (get-content-length tmp-list)))
(http-stream-mode t)
;读取返回内容
(decode-bytes
(loop for i from 0 to (1- content-length) for x = (http-read-byte) while x collect x)
*html-charset*)))))
(defun http-head (url)
(multiple-value-bind (host port rel-url) (split-url url)
(cli-init host port)
(http-write (format nil "HEAD ~a HTTP/1.1" rel-url))
(http-write (format nil "HOST: ~a" host))
(http-write +newline+ nil)
(when *conn*
(http-stream-mode nil)
(let* ((tmp-list (loop for x = (http-read-line)
while (and x (plusp (length x)))
collect x))
(content-length (get-content-length tmp-list)))
(format nil "~%~{~a~^~%~}~%" tmp-list)))))
;;;; options 方法返回Allow头部表明服务器的实现方法集
(defun http-options (url)
(multiple-value-bind (host port rel-url) (split-url url)
(cli-init host port)
(http-write (format nil "OPTIONS ~a HTTP/1.1" rel-url))
(http-write (format nil "Host: ~a" host))
(http-write "Accept: *")
(http-write +newline+ nil)
(when *conn*
(http-stream-mode nil)
(let* ((tmp-list (loop for x = (http-read-line)
while (and x (plusp (length x)))
collect x))
(content-length (get-content-length tmp-list)))
(http-stream-mode t)
;读取返回内容
(format nil
"~{~a~%~}~a~%"
tmp-list
(decode-bytes (loop for i from 0 to (1- content-length) for x = (http-read-byte) while x collect x)
*html-charset*))))))
;;;; (http-put "http://localhost:37212/data/test1.txt" "这是一个中文的put请求")
(defun http-put (url data)
(multiple-value-bind (host port rel-url) (split-url url)
(cli-init host port)
(http-write (format nil "PUT ~a HTTP/1.1" rel-url))
(http-write (format nil "Host: ~a" host))
(http-write "Content-Type: text/plain")
(http-write (format nil "Content-Length: ~a" (length (convert-string-to-bytes data *html-charset*))))
(http-write +newline+ nil)
(http-write data nil)
(when *conn*
(http-stream-mode nil)
(let* ((tmp-list (loop for x = (http-read-line)
while (and x (plusp (length x)))
collect x))
(content-length (get-content-length tmp-list)))
(http-stream-mode t)
;读取返回内容
(decode-bytes
(loop for i from 0 to (1- content-length) for x = (http-read-byte) while x collect x)
*html-charset*)))))
扫一扫
2534
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
