CommonLispでWebサーバを作ってみる

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

Docker上で開発環境を構築。
いろんな実験や学習をするときにホストOSが汚れないのがいいなぁ。

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)
    default)))

(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))))

;;************************************************************************
;;http://cl-cookbook.sourceforge.net/strings.html
(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=\"UTF-8\" >what is your name?<input name='name' /></form></html>")
    (format t "<html><meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\"><body>Nice to meet you, ~a!<br><hr><a href=\"./greeting\">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=\"./greeting\">top</a></body></html>")))


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

全部理解できてないのが残念なところ。
labels、coerce、read-line、read-seaquence とかよくわかんないので
後で調べておこうっと。

環境をDockerHubに上げておいたので
以下コマンドで実行可能です。

docker run -d -p 8080:8080 moremagic/land-of-lisp /root/LandOfLisp/service.sh