Skip to content

Commit

Permalink
restructure HTTP requests so that it is easier to get header informat…
Browse files Browse the repository at this point in the history 
…ion and add cookie support (unstable)
  • Loading branch information
@vii
vii committed Jan 11, 2010
1 parent 576cf7b commit 88c0064
Show file tree
Hide file tree
Showing 8 changed files with 173 additions and 172 deletions.
6 changes: 3 additions & 3 deletions src/blog/blog.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -98,7 +98,7 @@
(datastore-delete c))))))))))

(defpage-lambda-blog (my post-comment-url)
(lambda (text author entry-name keep-this-empty .javascript. http-peer-info! all-http-params!)
(lambda (text author entry-name keep-this-empty .javascript.)
(let ((entry-name (force-string entry-name)))
(let ((success
(when (and
Expand All @@ -115,14 +115,14 @@
(make-comment
:author author
:text text
:trace-details http-peer-info!
:trace-details (tpd2.http:servestate-origin*)
:entry-index-name entry-name)
(channel-notify entry))
t))))
(cond
(.javascript.
(if success
(webapp-respond-ajax-body all-http-params!)
(webapp-respond-ajax-body)
(tpd2.io:with-sendbuf ()
(js-to-bv (alert "Comment rejected.")))))
(success
Expand Down
95 changes: 72 additions & 23 deletions src/http/dispatcher.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,39 +5,89 @@
(paths (make-hash-table :test 'equalp))
(error-responder 'default-http-error-page))

(defun dispatch (con done path &key params host)
(dispatcher-respond (find-dispatcher host) con done path params))
(defun dispatch-servestate (con done *servestate*)
(dispatcher-respond (find-dispatcher (servestate-host*))
con done))

(defun-speedy build-http-response (&key banner headers body)
(declare (type sendbuf body))
(declare (dynamic-extent body))
(with-sendbuf ()
"HTTP/1.1 " banner +newline+
"Content-Length: " (sendbuf-len body) +newline+
headers
+newline+
body))

(defun-speedy respond-http (con done &key (banner (force-byte-vector "200 OK"))
(headers #.(byte-vector-cat "Content-Type: text/html;charset=utf-8" tpd2.io:+newline+)) body)
(defun-speedy start-http-response (&key (banner (force-byte-vector "200 OK"))
(content-type #.(byte-vector-cat "Content-Type: text/html;charset=utf-8" tpd2.io:+newline+)))
(setf (servestate-response*)
(with-sendbuf ()
"HTTP/1.1 " banner +newline+
content-type)))

(defun-speedy map-http-params (func)
(declare (dynamic-extent func) (type (function (simple-byte-vector simple-byte-vector) t) func))
(flet ((parse-params (str)
(when str
(match-bind ( (* name "=" value (or (last) "&")
'(funcall func name value)))
str)))
(parse-cookie-params (str)
(when str
(match-bind ( (* name "=" value (or (last) "," ";")
'(funcall func name value)))
str))))
(declare (inline parse-cookie-params parse-params)
(dynamic-extent #'parse-params #'parse-cookie-params))
(parse-params (servestate-query-string*))
(parse-params (servestate-post-parameters*))
(parse-cookie-params (servestate-cookie*))))

(defmacro with-http-params (bindings &body body)
(with-unique-names (f pname pvalue)
`(let ,(loop for b in bindings for (n default) = (force-list b)
collect `(,n ,default))
(flet ((,f (,pname ,pvalue)
(declare (type simple-byte-vector ,pname ,pvalue))
(case-match-fold-ascii-case ,pname
,@(loop for b in bindings
collect
(destructuring-bind
(var &optional default &key conv (name (force-byte-vector var)))
(force-list b)
(declare (ignore default))
`(,(force-byte-vector name)
(setf ,var ,(if conv
`(,conv ,pvalue)
pvalue)))
)))))
(declare (inline ,f) (dynamic-extent #',f))
(map-http-params #',f)
(locally ,@body)))))

(defmacro with-http-headers (() &body body)
`(with-sendbuf-continue ((servestate-response*))
,@body))

(defun-speedy send-http-response (con done body)
(declare (type sendbuf body))
(declare (dynamic-extent body))
(send con done (build-http-response :banner banner :headers headers :body body)))
(with-http-headers ()
"Content-Length: " (sendbuf-len body) +newline+
+newline+
body)
(send
con done
(servestate-response*)))

(defun-speedy respond-http (con done &key banner body)
(start-http-response :banner banner)
(send-http-response con done body))

(my-defun dispatcher respond (con done path params)
(let ((f (gethash path (my paths))))
(my-defun dispatcher respond (con done)
(let ((f (gethash (servestate-path*) (my paths))))
(handler-case
(cond
(f
(locally (declare (optimize speed) (type function f))
(funcall f me con done path params)
(funcall f me con done)
(values)))
(t
;(format *error-output* "LOST ~A~&" (strcat (my canonical-name) "/" path))
(respond-http con done :banner (force-byte-vector "404 Not found")
:body (funcall (my error-responder) me path params))))
:body (funcall (my error-responder) me))))
(error (e)
(format *error-output* "~&PAGE ERROR ~A~&--- ~A~&-AGAIN PAGE ERROR ~A~&" (strcat (my canonical-name) path)
(format *error-output* "~&PAGE ERROR ~A~&--- ~A~&-AGAIN PAGE ERROR ~A~&" (strcat (my canonical-name) (servestate-path*))
(backtrace-description e)
e)
(respond-http con done
Expand All @@ -47,8 +97,7 @@
(my-defun dispatcher register-path (path func)
(setf (gethash (force-byte-vector path) (my paths)) (alexandria:ensure-function func)))

(my-defun dispatcher 'default-http-error-page (path params)
(declare (ignore params path))
(my-defun dispatcher 'default-http-error-page ()
(with-sendbuf ()
"<h1>I made a mistake. Sorry for the inconvenience.</h1>"))

Expand Down
108 changes: 42 additions & 66 deletions src/http/serve.lisp
View file
Original file line number Diff line number Diff line change
@@ -1,26 +1,20 @@
(in-package #:tpd2.http)

(declaim (inline make-request))
(defstruct request
(host nil :type (or null simple-byte-vector))
(path nil :type (or null simple-byte-vector))
params
(origin nil :type (or null simple-byte-vector)))

(defvar *request*)
(declaim (type request *request*))

(defun http-serve-timeout ()
60)

(defconstant-bv +http-param-origin+ (force-byte-vector 'http-peer-info!))

(defun match-x-forwarded-for (value)
(match-bind
(+ (and (char) (progn host (or (progn "," (* (space))) (last)))))
value
host))

(defun-speedy match-request-url (url)
(match-bind (path (or (last) (progn "?" q)))
url
(setf (servestate-path*) path
(servestate-query-string*) q)))

(defconstant-bv +header-end+ (concatenate 'simple-byte-vector +newline+ +newline+))

(defprotocol http-serve (con)
Expand All @@ -29,7 +23,7 @@

(io 'http-serve-parse-headers con (io 'recvline-shared-buf con +header-end+)))


#- (and)
(defun http-serve-parse-headers-clean (con done headers)
(declare (optimize speed))
(let (
Expand Down Expand Up @@ -83,29 +77,27 @@

(defun http-serve-parse-headers (con done headers)
(declare (optimize speed))
(let (
(request-content-length 0)
host
(request-origin (con-peer-info con))
connection-close)
(let ((*servestate* (make-servestate :origin (con-peer-info con))))
(flet ((handle-header (name value)
(declare (type simple-byte-vector name value))
(unless (zerop (length value))
(case-match-fold-ascii-case name
("content-length"
(setf request-content-length (match-int value)))
("host"
(setf host value))
("connection"
(match-bind (
(+ word (or (+ (space)) (last))
'(case-match-fold-ascii-case (the simple-byte-vector word)
("close" (setf connection-close t))
("keep-alive" (setf connection-close nil)))))
#.`(case-match-fold-ascii-case name
("content-length"
(setf (servestate-content-length*) (match-int value)))
("connection"
(match-bind (
(+ word (or (+ (space)) (last))
'(case-match-fold-ascii-case (the simple-byte-vector word)
("close" (setf (servestate-connection-close*) t))
("keep-alive" (setf (servestate-connection-close*) nil)))))
value))
("x-forwarded-for"
(setf request-origin
(match-x-forwarded-for value)))))))
("x-forwarded-for"
(setf (servestate-origin*)
(match-x-forwarded-for value)))
,@(loop for f in *stored-servestate-header-fields*
collect
`(,(force-string f)
(setf (,(concat-sym 'servestate- f '*)) value)))))))
(declare (dynamic-extent #'handle-header))
(let ((pos 0))
(declare (type (integer 0 100000) pos)
Expand Down Expand Up @@ -141,7 +133,11 @@
(line ()
`(multiple-value-prog1 (u #\Return) (assert-eol))))

(let ((method (ulws)) (url (ulws)) (version-major 0) (version-minor 9))
(let ((version-major 0) (version-minor 9))
(setf (servestate-method*) (ulws))

(match-request-url (ulws))

(cond ((= (e) (char-code #\Return)))
(t
(s "HTTP/")
Expand All @@ -150,7 +146,8 @@
(setf version-minor (i))
(lws)
(assert-eol)))
(setf connection-close (not (or (< 1 version-major) (and (= 1 version-major) (< 0 version-minor)))))
(setf (servestate-connection-close*)
(not (or (< 1 version-major) (and (= 1 version-major) (< 0 version-minor)))))
(loop until (= (e) (char-code #\Return))
do (cond ((m #\Space #\Tab))
(t
Expand All @@ -160,22 +157,18 @@
(handle-header header-name (line))))))
(assert-eol)

(http-serve-process-body con done
url
:request-content-length request-content-length
:host host
:origin request-origin
:connection-close connection-close)))))))

(defprotocol http-serve-process-body (con url &key request-content-length host origin connection-close)
(io 'parse-and-dispatch con url
:host host
:origin origin
:request-body
(unless (zerop request-content-length)
(io 'recv con request-content-length)))
(http-serve-process-body con done *servestate*)))))))

(defprotocol http-serve-process-body (con servestate)
(unless (zerop (servestate-content-length servestate))
(setf (servestate-post-parameters servestate)
(force-simple-byte-vector
(io 'recv con (servestate-content-length servestate)))))

(io 'dispatch-servestate con servestate)

(cond
(connection-close
((servestate-connection-close servestate)

;;; In the case where the client did not legitimately expect a
;;; connexion close, they could pipeline more requests. Closing the
Expand All @@ -194,23 +187,6 @@
(hangup con))
(t (io 'http-serve con))))

(defprotocol parse-and-dispatch (con path-and-args &key request-body host origin)
(let (params tmp)
(without-call/cc
(flet ((parse-params (str)
(when str
(match-bind ( (* name "=" value (or (last) "&")
'(push (cons (url-encoding-decode name) (url-encoding-decode value)) params)))
str))
(values)))
(match-bind (path (or (last) (progn "?" q)))
path-and-args
(parse-params q)
(parse-params request-body)
(setf tmp path)))
(push (cons +http-param-origin+ origin) params)) ; makes sure it's first so it can't be overridden by the user
(io 'dispatch con tmp :params params :host host)))

(defun http-serve-wait-timeout ()
60)

Expand Down
13 changes: 9 additions & 4 deletions src/packages.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -237,13 +237,18 @@
#:percent-hexpair-encode
#:dispatcher-register-path
#:dispatcher-canonical-name
#:build-http-response
#:respond-http

#:with-http-params
#:with-http-headers
#:send-http-response
#:start-http-response

#:servestate-origin*
#:*servestate*

#:*default-dispatcher*
#:dispatcher-add-alias
#:find-or-make-dispatcher
#:http-parse-and-generate-response
#:+http-param-origin+

#:http-start-server
))
Expand Down
Loading

0 comments on commit 88c0064

Please sign in to comment.