;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; WEBAPP.LISP - cl-webapp for CLISP ;; ;; by らむだ ;; ;; * これは何？ ;; ;; Common Lisp による HTTP サーバーの小さな実装です（本体は 200 行くらい）． ;; 一応普通の Web サーバーとしても使えます． ;; ;; (defwebapp ;; :name "Sample Application - 2" ;; :base-url "html" ;; :document-root ;; #+clisp "~/public_html" ;; #+cmu "home:public_html") ;; ;; の :document-root に設定するパスを公開したいディレクトリに書き換えて ;; ロードし，サーバーを起動してhttp://127.0.0.1/html/index.html に ;; ブラウザでアクセスすれば↑の例では ~/public_html/index.html が表示 ;; されます． ;; ;; しかし，別に Web サーバーが作りたかったわけではなく cmucl + mod_lisp ;; の環境で構築した cl-webapp を Windows でも使えるようにしたいわけです． ;; もちろん mod_lisp に比べるとパフォーマンスも機能も断然劣りますが ;; とりあえず Windows でも lisp を試したいので…． ;; ;; * 動作に必要なもの ;; ;; * Windows で使う場合 ;; + CLISP 2.32 のバイナリ ;; ;; * FreeBSD + CLISP で使う場合 ;; + CLISP 2.32 のバイナリ ;; ;; * FreeBSD + CMUCL で使う場合 ;; + CMUCL 18e (開発は CVS 版つかってますがきっと 18e でも大丈夫) ;; + CLOCC (の PORT パッケージ) ;; ;; * 起動方法 ;; ;; 1. (compile-file "webapp.lisp") でコンパイル ;; 2. (load-file "webapp") でロード ;; 3. (webapp:serve 8080) で 8080 ポートで起動 ;; ;; 3'. mp サポートの CMUCL なら ;; (mp::start-idle-and-top-level-loops) ;; すでにしてあれば不要 ;; して ;; (mp:make-process (lambda () (webapp:serve 8080)) :name "Webapp") ;; とか． ;; ;; * アプリケーションの作り方 ;; ;; 1. アプリケーションを定義 ;; (defclass () ()) ;; (defwebapp "Sample Application" "application-url") ;; 2. page-view メソッドを定義 ;; (defmethod page-view ((self ) (req )) ;; (write-line "

My First Application!!

")) ;; ;; あとは (serve 8080) とかでサーバーを立ちあげてブラウザで ;; http://localhost:8080/application-url ;; にアクセスすると My First Application!! と書かれたページが表示される． ;; ;; * 問題（解決済み） ;; - WindowsXP Pro + CLISP 2.32 (Win32 バイナリ) の環境で ;; ソケットの read/write でエラーが出る．原因不明． ;; -> エンコーディングを指定したら治った？ ;; - ソースにに手を入れたら一旦サーバーを止めてロードし直さないと ;; いけないのでちょっと不便． ;; -> CMUCL に対応して MP パッケージを使う事でごまかす． ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; for CLISP hack ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; うーん Windows はよくわからない…なんか read-line が失敗するので ;; とりあえずエンコーディングを UNIX と揃えてごまかす #-UNIX (eval-when (:execute :load-toplevel :compile-toplevel) (let ((encoding (make-encoding :charset "ISO-8859-1" :line-terminator :unix))) (system::set-default-file-encoding encoding) (system::set-foreign-encoding encoding) (system::set-misc-encoding encoding))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; CL-Webapp ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+clisp (defpackage :cl-webapp (:use :cl :ext :socket) (:nicknames :webapp) (:export :serve)) #-clisp (defpackage :cl-webapp (:use :cl :port) (:nicknames :webapp) (:export :serve)) (in-package :cl-webapp) (defclass () ((header :accessor header-of :initform nil) (method :accessor method-of :initform nil) (url :accessor url-of :initform nil) (param :accessor param-of :initform nil))) (defclass () ((base-url :accessor base-url-of :initarg :base-url) (name :accessor name-of :initarg :name))) (defclass () ((server-socket :accessor server-socket-of :initform nil) (applications :accessor applications-of :initform (make-hash-table :test #'equal)) (default :accessor default-of :initform (make-instance ')) (port :accessor port-of :initform nil) (request :accessor request-of :initform nil))) (defgeneric parse-http-header (self str)) (defgeneric parse-parameter (self str)) (defgeneric parse-url (self str)) (defgeneric start-server (self port)) (defgeneric request (self s)) (defgeneric parse-request (self s)) (defgeneric dispatch (self s)) (defgeneric debug-show (req)) (defgeneric page-view (application request)) (defmethod parse-http-header ((self ) str) (let* ((p (position #\: str)) (end (position-if (complement #'(lambda (c) (or (eql c #\return) (eql c #\linefeed)))) str :from-end t)) (v (and p (list (url-decode-string (subseq str 0 p)) (url-decode-string (subseq str (+ p 2) (and end (1+ end)))))))) (push v (header-of self)))) (defmethod parse-parameter ((self ) str) (let ((p1 (position #\= str)) (p2 (position #\& str))) (cond (p1 (push (list (url-decode-string (subseq str 0 p1)) (url-decode-string (subseq str (1+ p1) p2))) (param-of self)) (when p2 (parse-parameter self (subseq str (1+ p2))))) ((string= str "") nil ) (t (url-decode-string str))))) (defun url-decode-string (s) (with-output-to-string (out) (do ((i 0 (1+ i))) ((>= i (length s)) out) (let ((c (char s i))) (case c (#\% (setf c (code-char (parse-integer s :start (+ i 1) :end (+ i 3) :radix 16 :junk-allowed t))) (unless (or (null c) (eql c #\linefeed)) (write-char c out)) (incf i 2)) (#\+ (write-char #\Space out)) (otherwise (write-char c out))))))) (defmethod parse-url ((self ) str) (let ((p1 (position #\Space str)) (p2 (position #\Space str :from-end t))) ;;(write-line "[request]") ; for debug (write-line str) ; for debug (when (and p1 p2 (> p2 p1)) (let ((method (subseq str 0 p1)) (url (subseq str (+ p1 1) p2)) (args nil)) (when (and ;;(string= method "GET") (setf p1 (position #\? url))) (setf args (subseq url (1+ p1)) url (subseq url 0 p1)) (parse-parameter self args)) (setf (method-of self) method (url-of self) url))))) (defmethod start-server ((self ) port) (unless (server-socket-of self) (unwind-protect (progn (setf (server-socket-of self) #+clisp (socket-server port) #-clisp (port:open-socket-server port) (port-of self) port) (loop (request self #+clisp (socket-accept (server-socket-of self)) #-clisp (port:socket-accept (server-socket-of self)) ))) #+clisp(socket-server-close (server-socket-of self)) #-clisp(port:socket-server-close (server-socket-of self)) (setf (server-socket-of self) nil)))) (defmethod request ((self ) s) (unwind-protect (progn (parse-request self s) (dispatch self s)) (finish-output s) (close s))) (defmethod parse-request ((self ) s) (let ((request (make-instance '))) (setf (request-of self) request) ;; parse url & arguments (parse-url request (read-line s)) ;; parse http header (loop for line = (read-line s nil :eof) until (<= (length line) 2) do ;;(write-line line) ; for debug (parse-http-header request line)) ;; parse POSTed data (let ((h (assoc "Content-Length" (header-of request) :test #'equal))) (when (and h (listen s)) (let* ((length (parse-integer (second h))) ;;(str (make-string (1- length))) (str (make-string length))) #+clisp(read-char s) ;; chop NEWLINE ;;#+clisp ;;(read-char-sequence str s) ;;#+cmu (read-sequence str s) (parse-parameter request str)))))) (defmethod dispatch ((self ) s) (let* ((request (request-of self)) (url (url-of request)) (application (or (gethash (subseq url 0 (position #\/ url :start (if (>= (length url) 1) 1 0))) (applications-of self)) (default-of self)))) (let ((*standard-output* s)) (page-view application request)))) (defmethod debug-show ((req )) (format t "
~%header: ~S~%method: ~S~%url: ~S~%param: ~S~%
~%" (header-of req) (method-of req) (url-of req) (param-of req))) (defmethod page-view ((application ) (request )) (write-line "HTTP/1.0 200 OK") (write-line "Content-Type: text/html; charset=EUC-JP") (write-line "") (write-line "") (write-line "

Webapp for Common Lisp

") (write-line "

対応するアプリケーションがありません．

") ;;(debug-show request) ;; POST TEST ;;(write-line "
") ;;(write-line "") ;;(write-line "") ;;(write-line "
") (write-line "")) (defvar *server* (make-instance ')) (defun serve (&optional (port 8080)) (start-server *server* port)) (defmacro defwebapp (class name-key name base-url-key base-url &rest option) (assert (eq name-key :name)) (assert (eq base-url-key :base-url)) `(setf (gethash ,base-url (webapp::applications-of webapp::*server*)) (make-instance ',class :name ,name :base-url ,base-url ,@option))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Sample Application 1 - テキストだけのページ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass () ()) (defwebapp :name "Sample Application - 1" :base-url "/hello") (defmethod page-view ((app ) (req )) (write-line "HTTP/1.0 200 OK") (write-line "Content-Type: text/html") (write-line "") (write-line "") (write-line "") (write-line "Sample Application") (write-line "") (write-line "

Hello, World!!

") (write-line "

こんにちは世界!!

") (write-line "
日本語：漢字とかソソソとか．とりあえず EUC なら通るのかな？
") (write-line "")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Sample Application 2 - static html ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass () ((document-root :accessor document-root-of :initarg :document-root))) (defwebapp :name "Sample Application - 2" :base-url "/html" :document-root #+clisp "~/public_html" #+cmu "home:public_html") (defmethod page-view ((app ) (req )) (let* ((url (url-of req)) (path (concatenate 'string (document-root-of app) (subseq url (length (base-url-of app))))) (type (subseq url (- (length url) 4))) (file (and (not (eq (char path (1- (length path))) #\/)) (probe-file path)))) (cond (file (write-line "HTTP/1.0 200 OK") (cond ((string-equal type ".css") (write-line "Content-Type: text/css")) ((or (string-equal type "html") (string-equal type ".htm")) (write-line "Content-Type: text/html")) ((string-equal type ".png") (write-line "Content-Type: image/png")) ((or (string-equal type ".jpg") (string-equal type ".jpeg")) (write-line "Content-Type: image/jpeg")) ((string-equal type ".gif") (write-line "Content-Type: image/gif")) (t (write-line "Content-Type: text/plain"))) (write-line "") (with-open-file (s file :direction :input #+clisp :element-type #+clisp 'unsigned-byte) (let* ((size (file-length s)) #+clisp (buf (make-array size :element-type 'unsigned-byte)) #-clisp (buf (make-string size))) (read-sequence buf s) #+clisp (write-sequence (ext:convert-string-from-bytes buf 'charset:iso-8859-1) *standard-output*) #-clisp (write-sequence buf *standard-output*)))) (t (write-line "HTTP/1.0 404 OK") (write-line "Content-Type: text/html") (write-line "") (write-line "") (write-line "

Webapp - Static Contents

") (write-line "
")
	   (format t "~A(~A) is NOT FOUND" url path)
	   (write-line "
") (write-line "")))))