common lisp CGI用のユーティリティ

common lispでCGIを書くときのユーティリティを書く。
あまり重いものを書く能力はないので、簡単なものを作りたい。
lisp-cgi-utilsでいいじゃないか、とは思うんだけど、自分でつくることに意味がある。。。んだと思う。

enctypeにmultipart/form-dataを指定してファイルをアップロードしたい時に、*standard-input*からバイナリを読みたいんだけどどうやって読めばいいのかわからない。

*standard-input*

からread-byteするとエラーが出る。

(with-open-file (in "/dev/stdin" :element-type '(unsigned-byte 8) :direction :input)
        (do ((b (read-byte in nil -1)
            (read-byte in nil -1)))

としても駄目だし、

(setf (stream-element-type *standard-input*) '(unsigned-byte 8))

これも駄目だった。
どうすりゃいいんだ？？

(defun coalesce (&rest rest)
  (if (null rest)
      nil
    (let ((itm (car rest)))
      (if itm
      itm
    (apply #'coalesce (cdr rest))))))

;; (defmacro with-http-context (&body forms)
;;   (unwind-protect
;;       forms
;;     ()))


(defun parse-formdata(str encode)
  (let ((result (make-hash-table :test #'equal)))
    (maphash #'(lambda (key val) 
         (if (listp val)
             (setf (gethash key result) (reverse val))
           (setf (gethash key result) val)))
         (reduce #'(lambda (hash pair)
             (destructuring-bind (key newval) 
                 (mapcar #'(lambda (itm) 
                     (urldecode itm encode)) 
                     (split-string pair #\=))
               (multiple-value-bind (val has) (gethash key hash)
                 (cond ((and has
                     (listp val))
                    (cons newval val))
                   (has
                    (setf (gethash key hash) (list newval val)))
                   (t
                    (setf (gethash key hash) newval)))))
             hash)
              (split-string str #\&)
             :initial-value (make-hash-table :test #'equal)))
    result))


(defun split-string(str c)
  (split-string_ str c 0))

(defun split-string_(str c idx)
  (cond ((null str)
     nil)
    ((<= (length str) idx)
     (list str))
    ((char= (char str idx) c)
     (cons (subseq str 0 idx) (split-string_ (subseq str (1+ idx)) c 0)))
    (t
     (split-string_ str c (1+ idx)))))

(defun concate-char(str c)
  (concatenate 'string str (format nil "~A" c)))

(defun concate(str1 str2)
  (concatenate 'string str1 str2))

(defun urlencode(str encoding)
  (reduce #'(lambda (enc c)
          (cond ((char= #\  c)
             (concate-char enc #\+))
             ((or (and (char< #\A c)
                   (char> #\z c))
              (char= #\. c)
              (char= #\_ c)
              (char= #\- c))
              (concate-char enc c))
             (t
              (concate enc (encoding c encoding)))))
      str
      :initial-value ""))

(defun encoding(char encoding)
  (let* ((s (format nil "~A" char))
     (vec (sb-ext:string-to-octets s :external-format encoding :null-terminate nil)))
    (reduce #'(lambda (enc c)
        (concate enc (format nil "%~X" c)))
        vec
        :initial-value "")))

(defun urldecode(str encoding)
  (with-input-from-string (strm str)
              (let ((dec-str ""))
                (do ((c (peek-char t strm nil 'EOF)
                    (peek-char t strm nil 'EOF)))
                ((eql c 'EOF) dec-str)
                  (cond ((char= c #\+)
                     (read-char strm nil 'EOF)
                     (setf dec-str (concate-char dec-str #\ )))
                    ((char= c #\%)
                     (setf dec-str (concate dec-str (sb-ext:octets-to-string (read-octets strm) :external-format encoding))))
                    (t
                     (read-char strm nil 'EOF)
                     (setf dec-str (concate-char dec-str c))))))))
(defun read-octets(strm)
  (let ((vec (make-array 0 :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0)))
    (do ((c (peek-char t strm nil 'EOF)
        (peek-char t strm nil 'EOF)))
    ((or (eql c 'EOF)
         (not (char= c #\%))) vec)
      (read-char strm nil 'EOF)
      (vector-push-extend (read-octet strm) vec))))
    
(defun read-octet(strm)
  (read-from-string (format nil "#x~A~A" 
                (read-char strm t)
                (read-char strm t))))