commit 7abeb13ae856820658d16b34c2a1cd9520423965
parent 32b65f17938113f4f7b5a50abd97aea94dcccd7e
Author: Tomas Hlavaty <tom@logand.com>
Date: Sun, 6 Dec 2015 17:16:56 +0100
add demo-webserver
webserver for serving static files
Diffstat:
6 files changed, 416 insertions(+), 156 deletions(-)
diff --git a/demo-counter.lisp b/demo-counter.lisp
@@ -1,4 +1,4 @@
-;;; Copyright (C) 2013, 2014 Tomas Hlavaty <tom@logand.com>
+;;; Copyright (C) 2013, 2014, 2015 Tomas Hlavaty <tom@logand.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
@@ -98,7 +98,9 @@
(rw.http:server (rw.socket:make-ipv4-address "0.0.0.0")
2349
'counter-handler
- :quit (lambda () nil)))
+ :quit (lambda () nil)
+ :allowed-methods '(:get :post)
+ :ignore-errors-p t))
;;(start)
diff --git a/demo-webserver.lisp b/demo-webserver.lisp
@@ -0,0 +1,148 @@
+;;; Copyright (C) 2015 Tomas Hlavaty <tom@logand.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+
+(defpackage :rw.demo.webserver
+ (:use :cl))
+
+(in-package :rw.demo.webserver)
+
+(defparameter *root* #p"/nix/store/l549rl2lmyk7dvsrv4mrrwgwbswf8q6l-logand-website/share/logandWebsite/data/")
+
+(defun part-reader (query)
+ (let ((r (rw:peek-reader (rw:reader (reverse query)))))
+ (lambda ()
+ (when (rw:peek r)
+ (prog1 (let ((x (rw:till r '(#\/))))
+ (if x
+ (coerce (nreverse x) 'string)
+ :nothing))
+ (rw:skip r '(#\/)))))))
+
+(defun query-pathname (query)
+ (let* ((tail (rw:till (rw:peek-reader (part-reader query))))
+ (head (pop tail)))
+ (merge-pathnames
+ (make-pathname :directory (cons :relative (nreverse tail))
+ :name (if (eq :nothing head)
+ "index"
+ (pathname-name head))
+ :type (if (eq :nothing head)
+ "html"
+ (pathname-type head)))
+ *root*)))
+
+(defun query-file (query) ;; TODO strip ?...
+ (when (every (lambda (c)
+ (or (char<= #\A c #\Z)
+ (char<= #\a c #\z)
+ (char<= #\0 c #\9)
+ (member c '(#\/ #\. #\- #\_))))
+ query)
+ (let ((f (probe-file (query-pathname query))))
+ (when f
+ (ignore-errors
+ (with-open-file (s f :if-does-not-exist nil)
+ f))))))
+
+(defun content-type (pathname)
+ (or (cdr (assoc (pathname-type pathname) rw.http:*mime-types* :test #'equalp))
+ rw.http:*default-mime-type*))
+
+(defun webserver-handler (msg stream method query protocol headers &optional body)
+ (declare (ignore stream protocol headers body))
+ (ecase msg
+ ;;(:read (rw:till (rw:peek-reader stream)))
+ (:write
+ (or (when (member method '(:get :head))
+ (let ((f (query-file query)))
+ (when f
+ `(:http-1.0
+ :code 200
+ :headers (("Connection" . "close")
+ ("Content-Type" . ,(content-type f)))
+ :body ,(and (eq :get method) f)))))
+ '(:http-1.0
+ :code 404
+ :headers (("Connection" . "close")
+ ("Content-Type" . "text/plain;charset=UTF-8"))
+ :body "404 Not Found")))))
+
+(defun start ()
+ (rw.http:server (rw.socket:make-ipv4-address "0.0.0.0")
+ 2341
+ 'webserver-handler
+ :quit (lambda () nil)
+ :allowed-methods '(:get :head)
+ :ignore-errors-p nil #+nil t))
+
+;;(start)
+
+(defun save-image ()
+ #-(or ccl cmucl sbcl)
+ (error "TODO RW.DEMO.WEBSERVER::SAVE-IMAGE")
+ #+clisp
+ (ext:saveinitmem "cl-rw-demo-webserver"
+ :executable t
+ :quiet t
+ :norc
+ :init-function (lambda ()
+ (handler-case
+ (progn
+ (start)
+ (loop (sleep 1)))
+ (condition ()
+ (quit 1)))))
+ #+ccl ;; TODO no debug on ^C
+ (ccl:save-application "cl-rw-demo-webserver"
+ :prepend-kernel t
+ :error-handler :quit-quietly
+ :toplevel-function (lambda ()
+ (handler-case
+ (progn
+ (start)
+ (loop (sleep 1)))
+ (condition ()
+ (ccl:quit 1)))))
+ #+cmu
+ (ext:save-lisp "cl-rw-demo-webserver"
+ :executable t
+ :batch-mode t
+ :print-herald nil
+ :process-command-line nil
+ :load-init-file nil
+ :init-function (lambda ()
+ (handler-case
+ (progn
+ (start)
+ (loop (sleep 1)))
+ (condition ()
+ (ext:quit)))))
+ #+sbcl
+ (sb-ext:save-lisp-and-die "cl-rw-demo-webserver"
+ :executable t
+ :toplevel (lambda ()
+ (handler-case
+ (progn
+ (start)
+ (loop (sleep 1)))
+ (condition ()
+ (sb-ext:exit :code 1 :abort t))))))
diff --git a/demo-zappel.lisp b/demo-zappel.lisp
@@ -1,4 +1,4 @@
-;;; Copyright (C) 2013, 2014 Tomas Hlavaty <tom@logand.com>
+;;; Copyright (C) 2013, 2014, 2015 Tomas Hlavaty <tom@logand.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
@@ -188,7 +188,9 @@
(rw.http:server (rw.socket:make-ipv4-address "0.0.0.0")
2340
'zappel-handler
- :quit (lambda () nil)))
+ :quit (lambda () nil)
+ :allowed-methods '(:get :post)
+ :ignore-errors-p t))
;;(start)
diff --git a/http.lisp b/http.lisp
@@ -1,14 +1,126 @@
+;;; Copyright (C) 2013, 2014, 2015 Tomas Hlavaty <tom@logand.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+
;; TODO remove all those coerce list<->string?
;; TODO !!! post parsing with multiline textarea
;; TODO !!! file(s) upload
(defpackage :rw.http
(:use :cl)
- (:export :client
+ (:export :*default-mime-type*
+ :*http-codes*
+ :*mime-types*
+ :client
:server))
(in-package :rw.http)
+(defparameter *mime-types*
+ '(("css" . "text/css;charset=UTF-8")
+ ("gif" . "image/gif")
+ ("html" . "text/html;charset=UTF-8")
+ ("js" . "application/javascript;charset=UTF-8")
+ ("png" . "image/png")
+ ("txt" . "text/plain;charset=UTF-8")))
+
+(defparameter *default-mime-type* "application/octet-stream")
+
+(defparameter *http-codes*
+ ;; https://en.wikipedia.org/wiki/List_of_HTTP_status_codes
+ '((200 . "OK")
+ (201 . "Created")
+ (202 . "Accepted")
+ (203 . "Non-Authoritative Information (since HTTP/1.1)")
+ (204 . "No Content")
+ (205 . "Reset Content")
+ (206 . "Partial Content")
+ (207 . "Multi-Status (WebDAV; RFC 4918)")
+ (208 . "Already Reported (WebDAV; RFC 5842)")
+ (226 . "IM Used (RFC 3229)")
+ (300 . "Multiple Choices")
+ (301 . "Moved Permanently")
+ (302 . "Found")
+ (303 . "See Other (since HTTP/1.1)")
+ (304 . "Not Modified")
+ (305 . "Use Proxy (since HTTP/1.1)")
+ (306 . "Switch Proxy")
+ (307 . "Temporary Redirect (since HTTP/1.1)")
+ (308 . "Permanent Redirect (approved as experimental RFC)[12]")
+ (400 . "Bad Request")
+ (401 . "Unauthorized")
+ (402 . "Payment Required")
+ (403 . "Forbidden")
+ (404 . "Not Found")
+ (405 . "Method Not Allowed")
+ (406 . "Not Acceptable")
+ (407 . "Proxy Authentication Required")
+ (408 . "Request Timeout")
+ (409 . "Conflict")
+ (410 . "Gone")
+ (411 . "Length Required")
+ (412 . "Precondition Failed")
+ (413 . "Request Entity Too Large")
+ (414 . "Request-URI Too Long")
+ (415 . "Unsupported Media Type")
+ (416 . "Requested Range Not Satisfiable")
+ (417 . "Expectation Failed")
+ (418 . "I'm a teapot (RFC 2324)")
+ (419 . "Authentication Timeout (not in RFC 2616)")
+ ;;(420 . "Method Failure (Spring Framework)")
+ ;;(420 . "Enhance Your Calm (Twitter)")
+ (422 . "Unprocessable Entity (WebDAV; RFC 4918)")
+ (423 . "Locked (WebDAV; RFC 4918)")
+ ;;(424 . "Failed Dependency (WebDAV; RFC 4918)")
+ ;;(424 . "Method Failure (WebDAV)[14]")
+ (425 . "Unordered Collection (Internet draft)")
+ (426 . "Upgrade Required (RFC 2817)")
+ (428 . "Precondition Required (RFC 6585)")
+ (429 . "Too Many Requests (RFC 6585)")
+ (431 . "Request Header Fields Too Large (RFC 6585)")
+ (444 . "No Response (Nginx)")
+ (449 . "Retry With (Microsoft)")
+ (450 . "Blocked by Windows Parental Controls (Microsoft)")
+ ;;(451 . "Unavailable For Legal Reasons (Internet draft)")
+ ;;(451 . "Redirect (Microsoft)")
+ (494 . "Request Header Too Large (Nginx)")
+ (495 . "Cert Error (Nginx)")
+ (496 . "No Cert (Nginx)")
+ (497 . "HTTP to HTTPS (Nginx)")
+ (499 . "Client Closed Request (Nginx)")
+ (500 . "Internal Server Error")
+ (501 . "Not Implemented")
+ (502 . "Bad Gateway")
+ (503 . "Service Unavailable")
+ (504 . "Gateway Timeout")
+ (505 . "HTTP Version Not Supported")
+ (506 . "Variant Also Negotiates (RFC 2295)")
+ (507 . "Insufficient Storage (WebDAV; RFC 4918)")
+ (508 . "Loop Detected (WebDAV; RFC 5842)")
+ (509 . "Bandwidth Limit Exceeded (Apache bw/limited extension)")
+ (510 . "Not Extended (RFC 2774)")
+ (511 . "Network Authentication Required (RFC 6585)")
+ (598 . "Network read timeout error (Unknown)")
+ (599 . "Network connect timeout error (Unknown)")))
+
(defun next-eol (reader)
(ecase (rw:next reader)
(#\newline :lf)
@@ -86,20 +198,22 @@
(defun next-body (reader) ;; TODO better, respect content-length!
(coerce (rw:till reader) 'string))
-(defun write-crlf (stream)
- (write-char (code-char 13) stream)
- (write-char (code-char 10) stream))
+(defun write-crlf (writer)
+ (rw:write-octets writer '(13 10)))
-(defun write-headers (headers stream)
+(defun write-headers (writer headers)
(dolist (x headers)
- (format stream "~a: ~a" (car x) (cdr x))
- (write-crlf stream)))
-
-(defun write-protocol (stream protocol)
- (write-string (ecase protocol
- (:http-1.0 "HTTP/1.0")
- (:http-1.1 "HTTP/1.1"))
- stream))
+ (rw:write-utf8-string writer (car x))
+ (rw:write-octets writer #.(rw.string:string-to-octets ": " :utf-8))
+ (rw:write-utf8-string writer (cdr x))
+ (write-crlf writer)))
+
+(defun write-protocol (writer protocol)
+ (rw:write-octets
+ writer
+ (ecase protocol
+ (:http-1.0 #.(rw.string:string-to-octets "HTTP/1.0" :utf-8))
+ (:http-1.1 #.(rw.string:string-to-octets "HTTP/1.1" :utf-8)))))
(defun write-query (stream method protocol path query-string)
(write-string (ecase method
@@ -164,20 +278,25 @@
;; <html><head><title>302 Moved Temporarily</title></head><body><h1>Moved Temporarily</h1>The document has moved <a href='http://NIL/?s=24rb7pccnd&a=0&c='>here</a><p><hr><address><a href='http://weitz.de/hunchentoot/'>Hunchentoot 1.2.3</a> <a href='http://openmcl.clozure.com/'>(Clozure Common Lisp Version 1.9-r15767 (LinuxARM32))</a></address></p></body></html>Connection closed by foreign host.
-(defun next-method (reader)
- (let ((x (cdr (assoc (rw:till reader '(#\G #\E #\T #\P #\O #\S) t)
+(defun next-method (reader allowed-methods)
+ (let ((x (cdr (assoc (rw:till (rw:peek-reader (rw:shorter-reader reader 5))
+ '(#\G #\E #\T
+ #\H #\A #\D
+ #\P #\O #\S)
+ t)
'(((#\G #\E #\T) . :get)
+ ((#\H #\E #\A #\D) . :head)
((#\P #\O #\S #\T) . :post))
:test #'equal))))
- (assert x)
+ (assert (member x allowed-methods))
x))
-(defun next-query (reader)
+(defun next-query (reader allowed-methods)
(unless (member (rw:peek reader) '(#\return #\newline))
(flet ((str (y)
(when y
(coerce y 'string))))
- (values (prog1 (next-method reader)
+ (values (prog1 (next-method reader allowed-methods)
(rw:skip reader))
(prog1 (str (rw:till reader '(#\space #\return #\newline)))
(unless (member (rw:peek reader) '(#\return #\newline))
@@ -185,90 +304,16 @@
(prog1 (next-protocol reader)
(next-eol reader))))))
-(defun write-status (stream protocol code message)
- (write-protocol stream protocol)
- (write-char #\space stream)
- (princ code stream)
- (write-char #\space stream)
- (write-string (or message
- ;; https://en.wikipedia.org/wiki/List_of_HTTP_status_codes
- (ecase code
- (200 "OK")
- (201 "Created")
- (202 "Accepted")
- (203 "Non-Authoritative Information (since HTTP/1.1)")
- (204 "No Content")
- (205 "Reset Content")
- (206 "Partial Content")
- (207 "Multi-Status (WebDAV; RFC 4918)")
- (208 "Already Reported (WebDAV; RFC 5842)")
- (226 "IM Used (RFC 3229)")
- (300 "Multiple Choices")
- (301 "Moved Permanently")
- (302 "Found")
- (303 "See Other (since HTTP/1.1)")
- (304 "Not Modified")
- (305 "Use Proxy (since HTTP/1.1)")
- (306 "Switch Proxy")
- (307 "Temporary Redirect (since HTTP/1.1)")
- (308 "Permanent Redirect (approved as experimental RFC)[12]")
- (400 "Bad Request")
- (401 "Unauthorized")
- (402 "Payment Required")
- (403 "Forbidden")
- (404 "Not Found")
- (405 "Method Not Allowed")
- (406 "Not Acceptable")
- (407 "Proxy Authentication Required")
- (408 "Request Timeout")
- (409 "Conflict")
- (410 "Gone")
- (411 "Length Required")
- (412 "Precondition Failed")
- (413 "Request Entity Too Large")
- (414 "Request-URI Too Long")
- (415 "Unsupported Media Type")
- (416 "Requested Range Not Satisfiable")
- (417 "Expectation Failed")
- (418 "I'm a teapot (RFC 2324)")
- (419 "Authentication Timeout (not in RFC 2616)")
- ;;(420 "Method Failure (Spring Framework)")
- ;;(420 "Enhance Your Calm (Twitter)")
- (422 "Unprocessable Entity (WebDAV; RFC 4918)")
- (423 "Locked (WebDAV; RFC 4918)")
- ;;(424 "Failed Dependency (WebDAV; RFC 4918)")
- ;;(424 "Method Failure (WebDAV)[14]")
- (425 "Unordered Collection (Internet draft)")
- (426 "Upgrade Required (RFC 2817)")
- (428 "Precondition Required (RFC 6585)")
- (429 "Too Many Requests (RFC 6585)")
- (431 "Request Header Fields Too Large (RFC 6585)")
- (444 "No Response (Nginx)")
- (449 "Retry With (Microsoft)")
- (450 "Blocked by Windows Parental Controls (Microsoft)")
- ;;(451 "Unavailable For Legal Reasons (Internet draft)")
- ;;(451 "Redirect (Microsoft)")
- (494 "Request Header Too Large (Nginx)")
- (495 "Cert Error (Nginx)")
- (496 "No Cert (Nginx)")
- (497 "HTTP to HTTPS (Nginx)")
- (499 "Client Closed Request (Nginx)")
- (500 "Internal Server Error")
- (501 "Not Implemented")
- (502 "Bad Gateway")
- (503 "Service Unavailable")
- (504 "Gateway Timeout")
- (505 "HTTP Version Not Supported")
- (506 "Variant Also Negotiates (RFC 2295)")
- (507 "Insufficient Storage (WebDAV; RFC 4918)")
- (508 "Loop Detected (WebDAV; RFC 5842)")
- (509 "Bandwidth Limit Exceeded (Apache bw/limited extension)")
- (510 "Not Extended (RFC 2774)")
- (511 "Network Authentication Required (RFC 6585)")
- (598 "Network read timeout error (Unknown)")
- (599 "Network connect timeout error (Unknown)")))
- stream)
- (write-crlf stream))
+(defun write-status (writer protocol code message)
+ (write-protocol writer protocol)
+ (rw:write-u8 writer #.(char-code #\space))
+ (rw:write-utf8-string writer (princ-to-string code))
+ (rw:write-u8 writer #.(char-code #\space))
+ (rw:write-utf8-string writer
+ (or message
+ (cdr (assoc code *http-codes*))
+ (error "unknown http code ~s" code)))
+ (write-crlf writer))
(defun multipart-reader (reader boundary)
(let* ((start-boundary `(#\- #\- ,@boundary))
@@ -303,63 +348,82 @@
(when body
(coerce body 'string)))))))
-(defun server-handler (stream handler)
- (let ((r (rw:peek-reader (rw:char-reader stream))))
- (multiple-value-bind (method query protocol) (next-query r)
- (let ((form (let ((headers (next-headers r)))
+(defun server-read (breader creader method)
+ (let ((headers (next-headers creader)))
+ (values
+ headers
+ (when (eq :post method)
+ (rw:slurp
+ (multipart-reader
+ (rw:shorter-reader
+ breader
+ (cdr (assoc "Content-Length" headers :test #'equal)))
+ (coerce
+ (cdr (assoc "boundary"
+ (cdr (assoc "Content-Type" headers :test #'equal))
+ :test #'equal))
+ 'list)))))))
+
+(defun server-write (form writer)
+ (ecase (car form)
+ (:http-1.0
+ (destructuring-bind (&key code message headers body) (cdr form)
+ (write-status writer :http-1.0 code message)
+ (write-headers writer
+ (or headers
+ '(("Connection" . "close")
+ ;;("Date" . "")
+ ;;("Last-Modified" . "")
+ #+nil("Server" . "CL-RW"))))
+ (write-crlf writer)
+ (etypecase body
+ (null)
+ (string (rw:write-utf8-string writer body))
+ (pathname
+ (with-open-file (s body :element-type '(unsigned-byte 8))
+ (rw:copy (rw:byte-reader s) writer)))
+ (cons
+ (rw:write-utf8-string writer
+ (with-output-to-string (*standard-output*)
+ (rw.html:html body)))
+ #+nil(let ((*standard-output* stream)) (rw.html:html body))) ;; TODO xml, css...
+ (function (funcall body writer)))))))
+
+(defun server-handler (stream handler allowed-methods ignore-errors-p)
+ (flet ((body ()
+ (with-open-stream (stream stream)
+ (let* ((br (rw:byte-reader stream))
+ (cr (rw:peek-reader (rw:utf8-reader br :charp t))))
+ (multiple-value-bind (method query protocol)
+ (next-query cr allowed-methods)
+ (server-write
+ (multiple-value-bind (headers body)
+ (server-read br cr method)
(funcall handler :write stream method query protocol headers
- (when (eq :post method)
- (rw:slurp
- (multipart-reader
- (rw:shorter-reader
- r
- (cdr (assoc "Content-Length" headers :test #'equal)))
- (coerce
- (cdr (assoc "boundary"
- (cdr (assoc "Content-Type" headers :test #'equal))
- :test #'equal))
- 'list))))))))
- (ecase (car form)
- (:http-1.0
- (destructuring-bind (&key code message headers body) (cdr form)
- (write-status stream :http-1.0 code message)
- (write-headers (or headers
- '(("Connection" . "close")
- ;;("Date" . "")
- ;;("Last-Modified" . "")
- ("Server" . "CL-RW")))
- stream)
- (write-crlf stream)
- (etypecase body
- (null)
- (string (write-string body stream))
- (pathname
- (with-open-file (in body :element-type '(unsigned-byte 8))
- (rw:copy (rw:byte-reader in) (rw:byte-writer stream))))
- (cons (let ((*standard-output* stream)) (rw.html:html body))) ;; TODO xml, css...
- (function (funcall body stream))))))))))
-
-#-clisp
-(defun accept-loop (socket quit handler host port)
+ body))
+ (rw:byte-writer stream)))))))
+ (if ignore-errors-p
+ (ignore-errors (body))
+ (body))))
+
+(defun accept-loop (socket quit handler host port allowed-methods ignore-errors-p)
(do ((q (or quit (rw:reader '(nil t)))))
((funcall q))
(let ((c (rw.socket:accept socket)))
(rw.concurrency:make-thread
(format nil "RW.HTTP:SERVER-HANDLER ~s ~s" host port)
(lambda ()
- (ignore-errors
- (with-open-stream (c c)
- (server-handler c handler))))))))
+ (server-handler c handler allowed-methods ignore-errors-p))))))
;; TODO also without threads
;; TODO also thread limit
;; TODO also thread pool
-#-clisp
-(defun server (host port handler &key quit)
+(defun server (host port handler &key quit allowed-methods ignore-errors-p)
(let ((s (rw.socket:make-tcp-server-socket host port)))
(flet ((accept ()
(with-open-stream (s s)
- (accept-loop s quit handler host port))))
+ (accept-loop s quit handler host port allowed-methods
+ ignore-errors-p))))
(if (rw.concurrency:threads-supported-p)
(rw.concurrency:make-thread
(format nil "RW.HTTP:ACCEPT-LOOP ~s ~s" host port)
diff --git a/rw.lisp b/rw.lisp
@@ -1,4 +1,4 @@
-;;; Copyright (C) 2013, 2014 Tomas Hlavaty <tom@logand.com>
+;;; Copyright (C) 2013, 2014, 2015 Tomas Hlavaty <tom@logand.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
@@ -78,6 +78,9 @@
:write-u32be
:write-u32le
:write-u8
+ :write-utf8-char
+ :write-utf8-codepoint
+ :write-utf8-string
:writer
:z0))
@@ -377,9 +380,14 @@
z))
(t (wrong))))))
-(defun utf8-reader (octet-reader)
- (lambda ()
- (next-utf8 octet-reader)))
+(defun utf8-reader (octet-reader &key charp)
+ (if charp
+ (lambda ()
+ (let ((x (next-utf8 octet-reader)))
+ (when x
+ (code-char x))))
+ (lambda ()
+ (next-utf8 octet-reader))))
;;(rw:till (rw:peek-reader (utf8-reader (rw:reader #(#x24)))))
;;(rw:till (rw:peek-reader (utf8-reader (rw:reader #(#xc2 #xa2)))))
@@ -486,6 +494,38 @@
;; TODO write-u64|128
;; TODO write-s8|16|32|64|128
+(defun write-utf8-codepoint (writer x) ;; TODO
+ (cond
+ ((<= 0 x #x7f)
+ (write-u8 writer x))
+ ((<= #x000080 x #x0007ff) ;; 110xxxxx 10xxxxxx
+ (write-u8 writer (logior #b11000000 (ash x -6)))
+ (write-u8 writer (logior #b10000000 (logand x #b00111111))))
+ ((or (<= #x000800 x #x00d7ff) ;; 1110xxxx 10xxxxxx 10xxxxxx
+ (<= #x00e000 x #x00ffff))
+ (write-u8 writer (logior #b11100000 (ash x -12)))
+ (write-u8 writer (logior #b10000000 (logand (ash x -6) #b00111111)))
+ (write-u8 writer (logior #b10000000 (logand x #b00111111))))
+ ((<= #x010000 x #x10ffff) ;; 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
+ (write-u8 writer (logior #b11110000 (ash x -18)))
+ (write-u8 writer (logior #b10000000 (logand (ash x -12) #b00111111)))
+ (write-u8 writer (logior #b10000000 (logand (ash x -6) #b00111111)))
+ (write-u8 writer (logior #b10000000 (logand x #b00111111))))
+ (t (error "wrong utf8 codepoint ~s" x))))
+
+;;(let ((*print-base* 16) (b (make-array 0 :adjustable t :fill-pointer 0))) (write-utf8-codepoint (writer b) #x24) (princ-to-string b)) => 24
+;;(let ((*print-base* 16) (b (make-array 0 :adjustable t :fill-pointer 0))) (write-utf8-codepoint (writer b) #xa2) (princ-to-string b)) => C2 A2
+;;(let ((*print-base* 16) (b (make-array 0 :adjustable t :fill-pointer 0))) (write-utf8-codepoint (writer b) #x20ac) (princ-to-string b)) => E2 82 AC
+;;(let ((*print-base* 16) (b (make-array 0 :adjustable t :fill-pointer 0))) (write-utf8-codepoint (writer b) #x10348) (princ-to-string b)) => F0 90 8D 88
+
+(defun write-utf8-char (writer x)
+ (write-utf8-codepoint writer (char-code x)))
+
+(defun write-utf8-string (writer x)
+ (loop
+ for e across x
+ do (write-utf8-char writer e)))
+
(defun line-reader (reader)
(let ((r (peek-reader reader)))
(lambda ()
diff --git a/socket.lisp b/socket.lisp
@@ -1,4 +1,4 @@
-;;; Copyright (C) 2013, 2014 Tomas Hlavaty <tom@logand.com>
+;;; Copyright (C) 2013, 2014, 2015 Tomas Hlavaty <tom@logand.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
@@ -333,8 +333,11 @@
(car (sb-bsd-sockets:host-ent-addresses
(sb-bsd-sockets:get-host-by-name remote-host)))
remote-port)
- (sb-bsd-sockets:socket-make-stream x :input t :output t ;;:buffering :none
- :element-type :default))
+ (sb-bsd-sockets:socket-make-stream x
+ :input t
+ :output t
+ ;;:buffering :none
+ :element-type '(unsigned-byte 8)))
#+cmucl
(let ((x (ext:connect-to-inet-socket remote-host remote-port)))
(sys:make-fd-stream x :input x :output x :element-type '(unsigned-byte 8)))
@@ -397,6 +400,7 @@
(socket:socket-accept socket)
#+(or sbcl ecl mkcl)
(sb-bsd-sockets:socket-make-stream (sb-bsd-sockets:socket-accept socket)
+ :element-type '(unsigned-byte 8)
:input t
:output t
:auto-close t)
