HTTPリクエストの中身を表示するだけのHTTPサーバ

sbcl network

タイトルの通りのHTTPサーバを作成。
というか、ほとんど何も行っていないので、HTTPサーバとは云えないような気もする...。


ソースコード

(require :sb-bsd-sockets)
(use-package :sb-bsd-sockets)

;; 定数
(defconstant CRLF (coerce '(#\Return #\Newline) 'string))
(defconstant CR-code (char-code #\Return))
(defconstant LF-code (char-code #\Newline))

;; HTTP接続の準備とかを行ってくれるマクロ
(defmacro do-http-stream ((stream listen-address listen-port) &body body)
  (let ((sock (gensym))
	(client (gensym)))
    `(let ((,sock (make-instance 'inet-socket :type :stream :protocol :tcp)))
       (unwind-protect
	   (progn 
	     (setf (sockopt-reuse-address ,sock) t)
	     (socket-bind ,sock ,listen-address ,listen-port)
	     (socket-listen ,sock 30)
	     (format *error-output* ";=== Listen by ~S, port ~S ===~%"
		     (socket-name ,sock) (nth-value 1 (socket-name ,sock)))
	     (loop
	      (let ((,client (socket-accept ,sock)))
		(format *error-output* ";=== Connection from ~S, port ~S ===~%"
			(socket-peername ,client) (nth-value 1 (socket-name ,client)))
		(sb-thread:make-thread
		 (lambda ()
		   (let ((,stream (socket-make-stream ,client 
						      :input t :output t 
						      :element-type '(unsigned-byte 8))))
		     (unwind-protect
			 (progn ,@body)
		       (close ,stream))))))))
	 (socket-close ,sock)))))

;; レスポンスヘッダ
(defvar *empty-response-http-header*
  (format nil "HTTP/1.0 200 ok~A~
	       CONNECTION: close~:*~A~
               CONTENT-TYPE: text/html~:*~A~
               CONTENT-LENGTH: 0~:*~A~:*~A" CRLF))

(defun read-header (input-stream)
  (do ((acc (list #1=(read-byte input-stream)) (cons #1# acc)))
      ((and (= (first  acc) LF-code)
	    (= (second acc) CR-code)
	    (= (third  acc) LF-code)
	    (= (fourth acc) CR-code))
       (map 'string #'code-char (nreverse acc)))))

(defmacro a.when (expr &body body)
  `(let ((it ,expr))
     (when it
       ,@body)))

;; 2009/07/06の『バイト列->文字列(コンディション処理)』参照
(defun octets-to-string2 (octets default-character)
  (handler-bind ((sb-impl::octet-decoding-error
                    (lambda (c) 
                       (use-value default-character c))))
    (octets-to-string octets)))

;;;;;;;
;; 実行
(do-http-stream	(stream #(0 0 0 0) 8080)
  ;; recv
  (let ((header (read-header stream)))
    ;; header表示
    (princ header) 

    ;; content-lengthがあるなら、contentも取得する(ロジックは適当)
    (a.when (search "content-length:" header :test #'string-equal)
      (let* ((len    (parse-integer header :junk-allowed t 
                                           :start (+ it (length "content-length:"))))
             (buffer (make-array len :element-type '(unsigned-byte 8))))
        (read-sequence buffer stream)
          ;; content表示
          (princ (octets-to-string2 buffer #\?))
          (terpri) (terpri)))))
   
  ;; send
  (write-sequence (string-to-octets *empty-response-http-header*) stream))

このサーバとFirebugを併用すれば、特定のページでsubmitボタンを押した際に送信されるPOST内容とかを取得することが出来る。今日は、このために作成した
まあ、↑みたいなことがやりたいだけなら、(多分)既にあるFirefoxのアドオンとかを使った方が良いような気がするけど。


あとは、ちょっとsbclでサーバを作成したい時のテンプレートとしても使えるかもしれない。