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

さっそくコードを書いてみます。

以下、改良してみました。

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