Land of Lisp P247
Webサーバを作ろう をやってみました。


core@localhost ~ $ docker run -ti ubuntu /bin/bash
root@306141dac20c:/# apt-get update
root@306141dac20c:/# apt-get upgrade

root@306141dac20c:/# apt-get install -y clisp
root@306141dac20c:/# apt-get install -y vim
root@306141dac20c:/# apt-get install -y curl


  • UTF-8 で formを送信。
  • タグの無毒化。
  • それからトップページへのリンクとかつけてみました。
(defun http-char (c1 c2 &optional (default #\Space))
  (let ((code (parse-integer
    (coerce (list c1 c2) string)
    :radix 16
    :junk-allowed t)))
  (if code
    (code-char code)

(defun decode-param (s) (labels ((f (lst) (when lst (case (car lst) (#\% (cons (http-char (cadr lst) (caddr lst)) (f (cdddr lst)))) (#+ (cons #\space (f (cdr lst)))) (otherwise (cons (car lst) (f (cdr lst)))))))) (coerce (f (coerce s list)) string)))

(defun http-byte (c1 c2 &optional (default #.(char-code #\space))) (let ((code (parse-integer (coerce (list (code-char c1) (code-char c2)) string) :radix 16 :junk-allowed t))) (or code default)))

(defun decode-param-utf8 (s) (labels ((f (lst) (when lst (case (car lst) (#.(char-code #\%) (cons (http-byte (cadr lst) (caddr lst)) (f (cdddr lst)))) (#.(char-code #+) (cons #.(char-code #\space) (f (cdr lst)))) (otherwise (cons (car lst) (f (cdr lst)))))))) (ext:convert-string-from-bytes (coerce (f (coerce (ext:convert-string-to-bytes s charset:utf-8) list)) vector) charset:utf-8)))

(defun parse-params (s) (let ((i1 (position #\= s)) (i2 (position #& s))) (cond (i1 (cons (cons (intern (string-upcase (subseq s 0 i1))) (decode-param-utf8 (subseq s (1+ i1) i2))) (and i2 (parse-params (subseq s (1+ i2)))))) ((equal s "") nil) (t s))))

(defun parse-url (s) (let* ((url (subseq s (+ 2 (position #\space s)) (position #\space s :from-end t))) (x (position #\? url))) (if x (cons (subseq url 0 x) (parse-params (subseq url (1+ x)))) (cons url ’()))))

(defun get-header (stream) (let* ((s (read-line stream)) (h (let ((i (position #: s))) (when i (cons (intern (string-upcase (subseq s 0 i))) (subseq s (+ i 2))))))) (when h (cons h (get-header stream)))))

(defun get-content-params (stream header) (let ((length (cdr (assoc content-length header)))) (when length (let ((content (make-string (parse-integer length)))) (read-sequence content stream) (parse-params content)))))

(defun serve (request-handler) (let ((socket (socket-server 8080))) (unwind-protect (loop (with-open-stream (stream (socket-accept socket)) (let* ((url (parse-url (read-line stream))) (path (car url)) (header (get-header stream)) (params (append (cdr url) (get-content-params stream header))) (standard-output stream)) (funcall request-handler path header params)))) (socket-server-close socket))))

;;************************************************************************ ;; (defun replace-all (string part replacement &key (test #‘char=)) "Returns a new string in which all the occurences of the part is replaced with replacement." (with-output-to-string (out) (loop with part-length = (length part) for old-pos = 0 then (+ pos part-length) for pos = (search part string :start2 old-pos :test test) do (write-string string out :start old-pos :end (or pos (length string))) when pos do (write-string replacement out) while pos)))

(defun hello-request-handler (path header params) (if (equal path "greeting") (let ((name (assoc name params))) (if (not name) (princ "<html><form accept-charset=&quot;UTF-8&quot; >what is your name?<input name=‘name’ /></form></html>") (format t "<html><meta http-equiv=&quot;Content-Type&quot; content=&quot;text/html; charset=UTF-8&quot;><body>Nice to meet you, ~a!<br><hr><a href=&quot;./greeting&quot;>back.</a></body></html>" (replace-all (replace-all (cdr name) "<" "&lt") ">" "&gt")))) (princ "<html><body>Sorry… I don’t know that page.<br><hr><a href=&quot;./greeting&quot;>top</a></body></html>")))

;************************************************************************ (setf default-file-encoding charset:utf-8) (serve #‘hello-request-handler)

labels、coerce、read-line、read-seaquence とかよくわかんないので