cl-rw

Layered streams for Common Lisp
git clone https://logand.com/git/cl-rw.git/
Log | Files | Refs

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:
Mdemo-counter.lisp | 6++++--
Ademo-webserver.lisp | 148+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Mdemo-zappel.lisp | 6++++--
Mhttp.lisp | 354+++++++++++++++++++++++++++++++++++++++++++++++--------------------------------
Mrw.lisp | 48++++++++++++++++++++++++++++++++++++++++++++----
Msocket.lisp | 10+++++++---
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&amp;a=0&amp;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)