commit 6585617e506123f0c619f49ba302f2bd7cdf3213
parent 325318efb57fb60a7d134c9e95843c6ce14ca586
Author: Tomas Hlavaty <tom@logand.com>
Date: Sun, 22 Sep 2013 01:05:32 +0200
added rw.socket, rw.uri, rw.http; other improvements and fixes
Diffstat:
| M | cl-rw.asd | | | 3 | +++ |
| A | http.lisp | | | 292 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| M | rw.lisp | | | 25 | +++++++++++++++++++++++-- |
| A | socket.lisp | | | 38 | ++++++++++++++++++++++++++++++++++++++ |
| M | ui.lisp | | | 41 | ++++++++++++++++++++++++++++------------- |
| A | uri.lisp | | | 52 | ++++++++++++++++++++++++++++++++++++++++++++++++++++ |
6 files changed, 436 insertions(+), 15 deletions(-)
diff --git a/cl-rw.asd b/cl-rw.asd
@@ -45,5 +45,8 @@
(:file "concurrency")
(:file "css")
(:file "html")
+ (:file "socket")
+ (:file "uri")
+ (:file "http")
(:file "calendar")
(:file "ui")))
diff --git a/http.lisp b/http.lisp
@@ -0,0 +1,292 @@
+(defpackage :rw.http
+ (:use :cl)
+ (:export :client
+ :server))
+
+(in-package :rw.http)
+
+(defun next-eol (reader)
+ (ecase (rw:next reader)
+ (#\newline :lf)
+ (#\return (case (rw:peek reader)
+ (#\newline (rw:next reader) :crlf)
+ (t :lf)))))
+
+(defun next-protocol (reader)
+ (let ((x (cdr (assoc (rw:till reader '(#\H #\T #\P #\/ #\1 #\. #\0) t)
+ '(((#\H #\T #\T #\P #\/ #\1 #\. #\0) . :http-1.0)
+ ((#\H #\T #\T #\P #\/ #\1 #\. #\1) . :http-1.1))
+ :test #'equal))))
+ (assert x)
+ x))
+
+(defun next-status (reader)
+ (unless (member (rw:peek reader) '(#\return #'\newline))
+ (values (prog1 (next-protocol reader)
+ (rw:skip reader))
+ (prog1 (rw:next-z0 reader)
+ (rw:skip reader))
+ (prog1 (coerce (rw:till reader '(#\return #'\newline)) 'string) ;; TODO better
+ (next-eol reader)))))
+
+(defun header-reader (reader)
+ (lambda ()
+ (let ((k (rw:till reader '(#\: #\return #\newline))))
+ (when k
+ (assert (eql #\: (rw:peek reader)))
+ (rw:next reader)
+ (rw:skip reader)
+ (prog1 (cons (coerce k 'string) ;; TODO better
+ (coerce (rw:till reader '(#\return #\newline)) 'string)) ;; TODO better
+ (next-eol reader))))))
+
+(defun next-headers (reader)
+ (prog1 (rw:till (rw:peek-reader (header-reader reader)))
+ (next-eol reader)))
+
+(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-headers (headers stream)
+ (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))
+
+(defun write-query (stream method protocol path query-string)
+ (write-string (ecase method
+ (:get "GET")
+ (:post "POST"))
+ stream)
+ (write-char #\space stream)
+ (write-string (or path "/") stream)
+ (when query-string
+ (write-char #\? stream)
+ (write-string query-string stream))
+ (write-char #\space stream)
+ (write-protocol stream protocol)
+ (write-crlf stream))
+
+(defun client1 (url &optional headers)
+ (destructuring-bind (&key scheme host port path query-string fragment)
+ (etypecase url
+ (list url)
+ (string (rw.uri:parse url)))
+ (declare (ignore fragment))
+ (assert (equal "http" scheme))
+ (with-open-stream (s (rw.socket:make-active-tcp-socket host (or port 80)))
+ (write-query s :get :http-1.0 path query-string)
+ (write-headers (or headers
+ `(("Host" . ,(if port
+ (format nil "~a:~a" host port)
+ host))))
+ s)
+ (write-crlf s)
+ (finish-output s)
+ (let ((r (rw:peek-reader (rw:char-reader s))))
+ (multiple-value-bind (protocol code message) (next-status r)
+ (values protocol code message (next-headers r) (next-body r)))))))
+
+(defun client (url &key headers (redirect 5))
+ (do (protocol code message headers2 body)
+ ((< (decf redirect) 0)
+ (unless (minusp redirect)
+ (list protocol code message headers2 body)))
+ (multiple-value-setq (protocol code message headers2 body)
+ (client1 url headers))
+ (if (member code '(302))
+ (setq url (cdr (assoc "Location" headers2 :test #'equal))) ;; TODO update "Host" header
+ (setq redirect 0))))
+
+;;(client "http://127.0.0.1:1234/")
+;;(client "http://logand.com")
+;;(client "http://logand.com:2234")
+
+
+
+
+;; HTTP/1.1 302 Moved Temporarily^M
+;; Content-Length: 369
+;; Date: Sat, 21 Sep 2013 13:41:11 GMT
+;; Server: Hunchentoot 1.2.3
+;; Connection: Close
+;; Location: http://NIL/?s=24rb7pccnd&a=0&c=
+;; Content-Type: text/html; charset=iso-8859-1
+
+;; <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)
+ '(((#\G #\E #\T) . :get)
+ ((#\P #\O #\S #\T) . :post))
+ :test #'equal))))
+ (assert x)
+ x))
+
+(defun next-query (reader)
+ (unless (member (rw:peek reader) '(#\return #'\newline))
+ (flet ((str (y)
+ (when y
+ (coerce y 'string))))
+ (values (prog1 (next-method reader)
+ (rw:skip reader))
+ (prog1 (str (rw:till reader '(#\space #\return #\newline)))
+ (unless (member (rw:peek reader) '(#\return #\newline))
+ (rw:skip reader '(#\space))))
+ (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 server-handler (stream handler)
+ (let ((r (rw:peek-reader (rw:char-reader stream))))
+ (multiple-value-bind (method query protocol) (next-query r)
+ (let ((headers (next-headers r)))
+ (multiple-value-bind (protocol2 code message headers2 body)
+ (funcall handler :write stream method query protocol headers
+ (when (eq :post method)
+ #+nil ;; TODO post
+ (let ((n (cdr (assoc "Content-Length" headers :test #'equal))))
+ (when n
+ (funcall handler
+ :read
+ (rw:shorter-reader
+ (rw:byte-reader stream)
+ (rw:next-z0 (rw:peek-reader (rw:reader n))))
+ method
+ query
+ protocol
+ headers)))))
+ (write-status stream protocol2 code message)
+ (write-headers (or headers2
+ '(("Connection" . "close")
+ ;;("Date" . "")
+ ;;("Last-Modified" . "")
+ ("Server" . "CL-RW")))
+ stream)
+ (write-crlf stream)
+ (etypecase body
+ (null)
+ (string (write-string body stream))
+ (function (funcall body stream))))))))
+
+(defun server-loop (socket quit handler host port)
+ (do ((q (or quit (rw:reader '(nil t)))))
+ ((funcall q))
+ (let ((c (ccl:accept-connection socket)))
+ (rw.concurrency:make-thread
+ (format nil "RW.HTTP:SERVER-HANDLER ~s ~s" host port)
+ (lambda ()
+ (with-open-stream (c c)
+ (server-handler c handler)))))))
+
+;; TODO also without threads
+;; TODO also thread limit
+;; TODO also thread pool
+(defun server (host port handler &key quit)
+ (let ((s (rw.socket:make-passive-tcp-socket host port)))
+ (rw.concurrency:make-thread
+ (format nil "RW.HTTP:SERVER-LOOP ~s ~s" host port)
+ (lambda ()
+ (with-open-stream (s s)
+ (server-loop s quit handler host port))))))
+
+(defun my-handler (msg stream method query protocol headers &optional body)
+ (ecase msg
+ (:read (rw:till (rw:peek-reader stream)))
+ (:write (values :http-1.0 200 nil nil
+ (prin1-to-string (list method query protocol headers body))))))
+
+;;(server "0.0.0.0" 1567 'my-handler :quit (lambda () nil))
diff --git a/rw.lisp b/rw.lisp
@@ -35,10 +35,12 @@
:next-u16
:next-u32
:next-u8
+ :next-z0
:peek
:peek-reader
:reader
:search-reader
+ :shorter-reader
:skip
:till
:write-octets
@@ -96,12 +98,17 @@
do (next reader)))
reader)))
-(defun till (reader &optional items)
+(defun till (reader &optional items good)
(loop
- while (let ((x (peek reader))) (and x (not (member x items))))
+ while (let ((x (peek reader)))
+ (and x
+ (if good
+ (member x items)
+ (not (member x items)))))
collect (next reader)))
;;(till (peek-reader (reader '(0 1 2 3 4))) '(3))
+;;(till (peek-reader (reader '(0 1 2 3 4))) '(0 1) t)
;;(till (skip (peek-reader (reader '(0 1 2 3 4))) 1) '(3))
;;(till (skip (peek-reader (reader #(0 1 2 3 4))) 1) '(3))
;;(with-open-file (s "/etc/passwd") (till (peek-reader (char-reader s)) '(#\:)))
@@ -142,6 +149,11 @@
(assert x))
(setf (aref z i) x)))))
+(defun next-z0 (reader)
+ (let ((x (rw:till reader '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 \9) t)))
+ (when x
+ (parse-integer (coerce x 'string))))) ;; TODO better
+
;; TODO next-u64|128
;; TODO next-s8|16|32|64|128
@@ -212,3 +224,12 @@
z2 z)))))))
;;(till (peek-reader (fibonacci-reader 10))) => 0 1 1 2 3 5 8 13 21 34
+
+(defun shorter-reader (reader size)
+ (if size
+ (let ((offset 0))
+ (lambda ()
+ (when (< offset size)
+ (incf offset)
+ (funcall reader))))
+ reader))
diff --git a/socket.lisp b/socket.lisp
@@ -0,0 +1,38 @@
+(defpackage :rw.socket
+ (:use :cl)
+ (:export :make-passive-tcp-socket
+ :make-active-tcp-socket))
+
+(in-package :rw.socket)
+
+(defun make-passive-tcp-socket (host port)
+ #-ccl
+ (error "TODO port RW.SOCKET:MAKE-PASSIVE-TCP-SOCKET")
+ #+ccl
+ (ccl:make-socket :connect :passive
+ :address-family :internet
+ :type :stream
+ :format :bivalent ;; TODO :binary
+ :local-host host
+ :local-port port
+ :reuse-address t))
+
+(defun make-active-tcp-socket (host port)
+ #-ccl
+ (error "TODO port RW.SOCKET:MAKE-ACTIVE-TCP-SOCKET")
+ #+ccl
+ (ccl:make-socket :connect :active
+ :address-family :internet
+ :type :stream
+ :format :bivalent ;; TODO :binary
+ :remote-host host
+ :remote-port port))
+
+;; eol
+;; keepalive nodelay broadcast linger
+;; backlog class out-of-band-inline
+;; local-filename remote-filename
+;; sharing basic
+;; external-format (auto-close t)
+;; connect-timeout input-timeout output-timeout deadline
+;; fd
diff --git a/ui.lisp b/ui.lisp
@@ -1,6 +1,7 @@
(defpackage :rw.ui
(:use :cl)
- (:export :checkbox
+ (:export :*http-server*
+ :checkbox
:choice-widget
:combo-item1-widget
:combo-item2-widget
@@ -25,6 +26,20 @@
(in-package :rw.ui)
+(defvar *http-server*)
+
+(defun http-method ()
+ (funcall *http-server* :method))
+
+(defun http-post-parameters ()
+ (funcall *http-server* :post-parameters))
+
+(defun set-http-header (k v)
+ (funcall *http-server* :set-parameter k v))
+
+(defun http-redirect (url)
+ (funcall *http-server* :redirect url))
+
(defvar *click-link*)
(defvar *click-form*)
@@ -40,10 +55,10 @@
(parse-nat0 (subseq x (1+ i))))))))
(defun html-reply (form)
- (setf (hunchentoot:content-type*) "text/html;charset=utf-8"
- (hunchentoot:header-out "cache-control") "no-cache, no-store"
- (hunchentoot:header-out "pragma") "no-cache"
- (hunchentoot:header-out "expires") "-1")
+ (set-http-header "Content-Type" "text/html;charset=utf-8")
+ (set-http-header "cache-control" "no-cache, no-store")
+ (set-http-header "pragma" "no-cache")
+ (set-http-header "expires" "-1")
(with-output-to-string (*standard-output*)
(rw.html:html form)))
@@ -95,7 +110,7 @@
(ecase (car form)
(:redirect
(destructuring-bind (target) (cdr form)
- (hunchentoot:redirect target)))
+ (http-redirect target)))
(:html (html-reply form))))
(defun make-stepper (sid create construct)
@@ -106,9 +121,9 @@
(with-state (state aid (lambda () actions2) dispatch clear)
;;(print (list :@@@ (hunchentoot:query-string*)))
(handle-form
- (ecase (hunchentoot:request-method*)
+ (ecase (http-method)
(:post
- (dolist (x (hunchentoot:post-parameters*))
+ (dolist (x (http-post-parameters))
(destructuring-bind (k &rest v) x
(let ((kk (when (char= #\z (char k 0))
(parse36 (subseq k 1)))))
@@ -151,11 +166,11 @@
(defparameter *session-lifespan* (* 60 60))
(defun make-session (sid create construct)
- (let ((lock (bt:make-lock "session ~s"))
+ (let ((lock (rw.concurrency:make-lock "session ~s"))
(touched (get-universal-time))
(stepper (make-stepper sid create construct)))
(lambda (aid)
- (bt:with-lock-held (lock)
+ (rw.concurrency:with-lock (lock)
(cond
((eq t aid)
(< (- (get-universal-time) touched) *session-lifespan*))
@@ -194,12 +209,12 @@
(defun make-pool ()
(let ((sessions (make-hash-table :test #'equal))
- (lock (bt:make-lock "pool ~s")))
+ (lock (rw.concurrency:make-lock "pool ~s")))
(lambda (create deconstruct construct)
(multiple-value-bind (sid aid *renv*) (funcall deconstruct)
(setq aid (parse36 aid))
(funcall
- (bt:with-lock-held (lock)
+ (rw.concurrency:with-lock (lock)
(maphash (lambda (k v)
(unless (funcall v t)
(remhash k sessions)))
@@ -212,7 +227,7 @@
(setf (gethash sid sessions)
(make-session sid create construct))
(lambda ()
- (hunchentoot:redirect
+ (http-redirect
(funcall construct sid (pretty36 0) *renv*)))))))))))))
(defparameter *pool* (make-pool))
diff --git a/uri.lisp b/uri.lisp
@@ -0,0 +1,52 @@
+(defpackage :rw.uri
+ (:use :cl)
+ (:export :parse
+ :parse-query-string))
+
+(in-package :rw.uri)
+
+;; TODO http://www.w3.org/Addressing/URL/url-spec.txt
+(defun parse (x)
+ (flet ((str (y)
+ (when y
+ (coerce y 'string))))
+ (let ((r (rw:peek-reader (rw:reader x))))
+ ;;scheme://host:port/path?query-string#fragment
+ (list :scheme (str (prog1 (rw:till r '(#\:))
+ (assert (eql #\: (rw:next r)))
+ (assert (eql #\/ (rw:next r)))
+ (assert (eql #\/ (rw:next r)))))
+ :host (str (rw:till r '(#\: #\/)))
+ :port (when (eql #\: (rw:peek r))
+ (rw:next r)
+ (rw:next-z0 r))
+ :path (str (rw:till r '(#\?)))
+ :query-string (when (eql #\? (rw:peek r))
+ (rw:next r)
+ (str (rw:till r '(#\#))))
+ :fragment (when (eql #\# (rw:peek r))
+ (rw:next r)
+ (str (rw:till r)))))))
+
+;;(parse "https://en.wikipedia.org/wiki/Uniform_Resource_Locator")
+;;(parse "http://panda:1234/?s=24rb7pccnd&a=0&c=#hello#there")
+
+(defun query-string-pair-reader (reader)
+ (let ((r (rw:peek-reader reader)))
+ (lambda ()
+ (when (eql #\& (rw:peek r))
+ (rw:next r))
+ (let ((k (rw:till r '(#\= #\&))))
+ (when k
+ (flet ((str (y) ;; TODO better
+ (when y
+ (coerce y 'string))))
+ (cons (str k)
+ (when (eql #\= (rw:next r))
+ (str (rw:till r '(#\&)))))))))))
+
+(defun parse-query-string (x)
+ (when x
+ (rw:till (rw:peek-reader (query-string-pair-reader (rw:reader x))))))
+
+;;(parse-query-string "s=24rb7pccnd&a=0&c=")
