eschulte pushed a commit to branch master
in repository elpa.
commit 5cb2812c321c4d6b2f7935f0cab5df0fc18aff73
Author: Eric Schulte <schulte.e...@gmail.com>
Date: Thu Jan 9 22:33:43 2014 -0700
accept single-function handlers
---
doc/web-server.texi | 12 ++++--
examples/000-hello-world.el | 9 ++--
examples/001-hello-world-utf8.el | 35 ++++++++---------
examples/002-hello-world-html.el | 12 ++---
examples/006-basic-authentication.el | 44 ++++++++++-----------
examples/009-web-socket.el | 25 +++++-------
examples/010-current-buffer.el | 17 ++++----
examples/011-org-agenda.el | 23 +++++------
examples/012-search-bbdb.el | 37 +++++++++---------
examples/013-org-export-service.el | 68 +++++++++++++++++-----------------
web-server.el | 32 +++++++++------
11 files changed, 156 insertions(+), 158 deletions(-)
diff --git a/doc/web-server.texi b/doc/web-server.texi
index e29963c..f75805a 100644
--- a/doc/web-server.texi
+++ b/doc/web-server.texi
@@ -80,10 +80,14 @@ listed (@pxref{Function Index}).
@chapter Handlers
@cindex handlers
-The function @code{ws-start} takes takes two arguments
-@code{handlers} and @code{port}. It starts a server listening on
-@code{port} responding to requests with @code{handlers}, an
-association list composed of pairs of matchers and handler functions.
+The function @code{ws-start} takes takes two arguments @code{handlers}
+and @code{port}. It starts a server listening on @code{port}
+responding to requests with @code{handlers}. @code{Handlers} may be
+either a single function or an association list composed of pairs of
+matchers and handler functions. When @code{handlers} is a single
+function the given function is used to serve every request, when it is
+an association list, the function of the first matcher to match each
+request handles that request.
@section Matchers
@cindex matchers
diff --git a/examples/000-hello-world.el b/examples/000-hello-world.el
index b2b8e82..e0ed687 100644
--- a/examples/000-hello-world.el
+++ b/examples/000-hello-world.el
@@ -1,8 +1,7 @@
;;; hello-world.el --- simple hello world server using Emacs Web Server
(ws-start
- '(((lambda (_) t) .
- (lambda (request)
- (with-slots (process headers) request
- (ws-response-header process 200 '("Content-type" . "text/plain"))
- (process-send-string process "hello world")))))
+ (lambda (request)
+ (with-slots (process headers) request
+ (ws-response-header process 200 '("Content-type" . "text/plain"))
+ (process-send-string process "hello world")))
9000)
diff --git a/examples/001-hello-world-utf8.el b/examples/001-hello-world-utf8.el
index e92e626..1108cfb 100644
--- a/examples/001-hello-world-utf8.el
+++ b/examples/001-hello-world-utf8.el
@@ -1,21 +1,20 @@
;;; hello-world-utf8.el --- utf8 hello world server using Emacs Web Server
(ws-start
- '(((lambda (_) t) .
- (lambda (request)
- (with-slots (process headers) request
- (let ((hellos '("こんにちは"
- "안녕하세요"
- "góðan dag"
- "Grüßgott"
- "hyvää päivää"
- "yá'át'ééh"
- "Γεια σας"
- "Вiтаю"
- "გამარჯობა"
- "नमस्ते"
- "你好")))
- (ws-response-header process 200
- '("Content-type" . "text/plain; charset=utf-8"))
- (process-send-string process
- (concat (nth (random (length hellos)) hellos) " world")))))))
+ (lambda (request)
+ (with-slots (process headers) request
+ (let ((hellos '("こんにちは"
+ "안녕하세요"
+ "góðan dag"
+ "Grüßgott"
+ "hyvää päivää"
+ "yá'át'ééh"
+ "Γεια σας"
+ "Вiтаю"
+ "გამარჯობა"
+ "नमस्ते"
+ "你好")))
+ (ws-response-header process 200
+ '("Content-type" . "text/plain; charset=utf-8"))
+ (process-send-string process
+ (concat (nth (random (length hellos)) hellos) " world")))))
9001)
diff --git a/examples/002-hello-world-html.el b/examples/002-hello-world-html.el
index b73073f..be054c7 100644
--- a/examples/002-hello-world-html.el
+++ b/examples/002-hello-world-html.el
@@ -1,16 +1,14 @@
;;; hello-world-html.el --- html hello world server using Emacs Web Server
(ws-start
- '(((lambda (_) t) .
- (lambda (request)
- (with-slots (process headers) request
- (ws-response-header process 200 '("Content-type" . "text/html"))
- (process-send-string process "<html>
+ (lambda (request)
+ (with-slots (process headers) request
+ (ws-response-header process 200 '("Content-type" . "text/html"))
+ (process-send-string process "<html>
<head>
<title>Hello World</title>
</head>
<body>
<b>hello world</b>
</body>
-</html>
-")))))
+</html>")))
9002)
diff --git a/examples/006-basic-authentication.el
b/examples/006-basic-authentication.el
index beec379..7bc0880 100644
--- a/examples/006-basic-authentication.el
+++ b/examples/006-basic-authentication.el
@@ -2,27 +2,25 @@
(lexical-let ((users '(("foo" . "bar")
("baz" . "qux"))))
(ws-start
- (list
- (cons (lambda (_) t)
- (lambda (request)
- (with-slots (process headers) request
- (let ((auth (cddr (assoc :AUTHORIZATION headers))))
- (cond
- ;; no authentication information provided
- ((not auth)
- (ws-response-header process 401
- '("WWW-Authenticate" . "Basic realm=\"example\"")
- '("Content-type" . "text/plain"))
- (process-send-string process "authenticate"))
- ;; valid authentication information
- ((string= (cdr auth) (cdr (assoc (car auth) users)))
- (ws-response-header process 200
- '("Content-type" . "text/plain"))
- (process-send-string process
- (format "welcome %s" (car auth))))
- ;; invalid authentication information
- (t
- (ws-response-header process 403
- '("Content-type" . "text/plain"))
- (process-send-string process "invalid credentials"))))))))
+ (lambda (request)
+ (with-slots (process headers) request
+ (let ((auth (cddr (assoc :AUTHORIZATION headers))))
+ (cond
+ ;; no authentication information provided
+ ((not auth)
+ (ws-response-header process 401
+ '("WWW-Authenticate" . "Basic realm=\"example\"")
+ '("Content-type" . "text/plain"))
+ (process-send-string process "authenticate"))
+ ;; valid authentication information
+ ((string= (cdr auth) (cdr (assoc (car auth) users)))
+ (ws-response-header process 200
+ '("Content-type" . "text/plain"))
+ (process-send-string process
+ (format "welcome %s" (car auth))))
+ ;; invalid authentication information
+ (t
+ (ws-response-header process 403
+ '("Content-type" . "text/plain"))
+ (process-send-string process "invalid credentials"))))))
9007))
diff --git a/examples/009-web-socket.el b/examples/009-web-socket.el
index 11cb09f..bdcaab2 100644
--- a/examples/009-web-socket.el
+++ b/examples/009-web-socket.el
@@ -42,18 +42,15 @@ function close(){ ws.close(); };
</body>
</html>" web-socket-port)))
(ws-start
- (list
- (cons
- '(:GET . ".*")
- (lambda (request)
- (with-slots (process headers) request
- ;; if a web-socket request, then connect and keep open
- (if (ws-web-socket-connect request
- (lambda (proc string)
- (process-send-string proc
- (ws-web-socket-frame (concat "you said: " string)))))
- (prog1 :keep-alive (setq my-connection process))
- ;; otherwise send the index page
- (ws-response-header process 200 '("Content-type" . "text/html"))
- (process-send-string process web-socket-page))))))
+ (lambda (request)
+ (with-slots (process headers) request
+ ;; if a web-socket request, then connect and keep open
+ (if (ws-web-socket-connect request
+ (lambda (proc string)
+ (process-send-string proc
+ (ws-web-socket-frame (concat "you said: " string)))))
+ (prog1 :keep-alive (setq my-connection process))
+ ;; otherwise send the index page
+ (ws-response-header process 200 '("Content-type" . "text/html"))
+ (process-send-string process web-socket-page))))
web-socket-port))
diff --git a/examples/010-current-buffer.el b/examples/010-current-buffer.el
index 73b75da..d9d8646 100644
--- a/examples/010-current-buffer.el
+++ b/examples/010-current-buffer.el
@@ -2,13 +2,12 @@
(require 'htmlize)
(ws-start
- '(((lambda (_) t) .
- (lambda (request)
- (with-slots (process headers) request
- (ws-response-header process 200
- '("Content-type" . "text/html; charset=utf-8"))
- (process-send-string process
- (let ((html-buffer (htmlize-buffer)))
- (prog1 (with-current-buffer html-buffer (buffer-string))
- (kill-buffer html-buffer))))))))
+ (lambda (request)
+ (with-slots (process headers) request
+ (ws-response-header process 200
+ '("Content-type" . "text/html; charset=utf-8"))
+ (process-send-string process
+ (let ((html-buffer (htmlize-buffer)))
+ (prog1 (with-current-buffer html-buffer (buffer-string))
+ (kill-buffer html-buffer))))))
9010)
diff --git a/examples/011-org-agenda.el b/examples/011-org-agenda.el
index 578f688..2c7467d 100644
--- a/examples/011-org-agenda.el
+++ b/examples/011-org-agenda.el
@@ -2,16 +2,15 @@
(require 'htmlize)
(ws-start
- '(((lambda (_) t) .
- (lambda (request)
- (with-slots (process headers) request
- (ws-response-header process 200
- '("Content-type" . "text/html; charset=utf-8"))
- (org-agenda nil "a")
- (process-send-string process
- (save-window-excursion
- (let ((html-buffer (htmlize-buffer)))
- (prog1 (with-current-buffer html-buffer (buffer-string))
- (kill-buffer html-buffer)
- (org-agenda-quit)))))))))
+ (lambda (request)
+ (with-slots (process headers) request
+ (ws-response-header process 200
+ '("Content-type" . "text/html; charset=utf-8"))
+ (org-agenda nil "a")
+ (process-send-string process
+ (save-window-excursion
+ (let ((html-buffer (htmlize-buffer)))
+ (prog1 (with-current-buffer html-buffer (buffer-string))
+ (kill-buffer html-buffer)
+ (org-agenda-quit)))))))
9011)
diff --git a/examples/012-search-bbdb.el b/examples/012-search-bbdb.el
index 2c1a49c..7ac1a6f 100644
--- a/examples/012-search-bbdb.el
+++ b/examples/012-search-bbdb.el
@@ -1,22 +1,21 @@
;;; search-bbdb.el --- search the Big Brother Data Base for a supplied name
(ws-start
- '(((lambda (_) t) .
- (lambda (request)
- (with-slots (process headers) request
- (let ((name (cdr (assoc "name" headers))))
- (unless name
- (ws-error process "Must specify a name to search."))
- (save-excursion
- (unless (set-buffer (get-buffer "*BBDB*"))
- (ws-error process "no *BBDB* buffer found"))
- (bbdb-search-name name)
- (if (equal (point-min) (point-max))
- (progn
- (ws-response-header process 404
- '("Content-type" . "text/plain"))
- (process-send-string process
- "no matches found"))
- (ws-response-header process 200
- '("Content-type" . "text/plain"))
- (process-send-string process (buffer-string)))))))))
+ (lambda (request)
+ (with-slots (process headers) request
+ (let ((name (cdr (assoc "name" headers))))
+ (unless name
+ (ws-error process "Must specify a name to search."))
+ (save-excursion
+ (unless (set-buffer (get-buffer "*BBDB*"))
+ (ws-error process "no *BBDB* buffer found"))
+ (bbdb-search-name name)
+ (if (equal (point-min) (point-max))
+ (progn
+ (ws-response-header process 404
+ '("Content-type" . "text/plain"))
+ (process-send-string process
+ "no matches found"))
+ (ws-response-header process 200
+ '("Content-type" . "text/plain"))
+ (process-send-string process (buffer-string)))))))
9012)
diff --git a/examples/013-org-export-service.el
b/examples/013-org-export-service.el
index 89c187a..12352da 100644
--- a/examples/013-org-export-service.el
+++ b/examples/013-org-export-service.el
@@ -1,12 +1,13 @@
;;; 013-org-export-service.el --- upload and export Org-mode files
-(defun ws/example-org-export-service (request)
- (with-slots (process headers) request
- (let ((file (cdr (assoc "file" headers)))
- (type (cdr (assoc 'content (cdr (assoc "type" headers))))))
- (if (not (and file type))
- (progn
- (ws-response-header process 200 '("Content-type" . "text/html"))
- (process-send-string process "
+(ws-start
+ (lambda (request)
+ (with-slots (process headers) request
+ (let ((file (cdr (assoc "file" headers)))
+ (type (cdr (assoc 'content (cdr (assoc "type" headers))))))
+ (if (not (and file type))
+ (progn
+ (ws-response-header process 200 '("Content-type" . "text/html"))
+ (process-send-string process "
<html><body><form action=\"\" method=\"post\" enctype=\"multipart/form-data\">
Export file: <input type=\"file\" name=\"file\"> to type
<select name=\"type\">
@@ -16,29 +17,28 @@ Export file: <input type=\"file\" name=\"file\"> to type
</select>
<input type=\"submit\" value=\"submit\">.
</form></body></html>"))
- (let* ((orig (cdr (assoc 'filename file)))
- (base (file-name-nondirectory
- (file-name-sans-extension orig)))
- (backend (case (intern (downcase type))
- (html 'html)
- (tex 'latex)
- (txt 'ascii)
- (t (ws-error process "%S export not supported"
- type))))
- (path (concat base "." type)))
- (let ((default-directory temporary-file-directory))
- (when (or (file-exists-p orig) (file-exists-p path))
- (ws-error process
- "File already exists on the server, try a new file."))
- (with-temp-file orig (insert (cdr (assoc 'content file))))
- (save-window-excursion (find-file orig)
- ;; TODO: Steal personal data and
- ;; ideas from uploaded Org-mode
- ;; text. Web services aren't free!
- (org-export-to-file backend path)
- (kill-buffer))
- (ws-send-file process path)
- (delete-file path)
- (delete-file orig)))))))
-
-(ws-start '(((lambda (_) t) . ws/example-org-export-service)) 9013)
+ (let* ((orig (cdr (assoc 'filename file)))
+ (base (file-name-nondirectory
+ (file-name-sans-extension orig)))
+ (backend (case (intern (downcase type))
+ (html 'html)
+ (tex 'latex)
+ (txt 'ascii)
+ (t (ws-error process "%S export not supported"
+ type))))
+ (path (concat base "." type)))
+ (let ((default-directory temporary-file-directory))
+ (when (or (file-exists-p orig) (file-exists-p path))
+ (ws-error process
+ "File already exists on the server, try a new file."))
+ (with-temp-file orig (insert (cdr (assoc 'content file))))
+ (save-window-excursion (find-file orig)
+ ;; TODO: Steal personal data and
+ ;; ideas from uploaded Org-mode
+ ;; text. Web services aren't free!
+ (org-export-to-file backend path)
+ (kill-buffer))
+ (ws-send-file process path)
+ (delete-file path)
+ (delete-file orig)))))))
+ 9013)
diff --git a/web-server.el b/web-server.el
index 1072371..59511cb 100644
--- a/web-server.el
+++ b/web-server.el
@@ -62,13 +62,16 @@
(defun ws-start (handlers port &optional log-buffer &rest network-args)
"Start a server using HANDLERS and return the server object.
-HANDLERS should be a list of cons of the form (MATCH . ACTION),
-where MATCH is either a function (in which case it is called on
+HANDLERS may be a single function (which is then called on every
+request) or a list of conses of the form (MATCHER . FUNCTION),
+where the FUNCTION associated with the first successful MATCHER
+is called. Handler functions are called with two arguments, the
+process and the request object.
+
+A MATCHER may be either a function (in which case it is called on
the request object) or a cons cell of the form (KEYWORD . STRING)
in which case STRING is matched against the value of the header
-specified by KEYWORD. In either case when MATCH returns non-nil,
-then the function ACTION is called with two arguments, the
-process and the request object.
+specified by KEYWORD.
Any supplied NETWORK-ARGS are assumed to be keyword arguments for
`make-network-process' to which they are passed directly.
@@ -77,11 +80,10 @@ For example, the following starts a simple hello-world
server on
port 8080.
(ws-start
- '(((:GET . \".*\") .
- (lambda (proc request)
- (process-send-string proc
- \"HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\n\r\nhello
world\r\n\")
- t)))
+ (lambda (request)
+ (with-slots (process headers) request
+ (process-send-string proc
+ \"HTTP/1.1 200 OK\\r\\nContent-Type: text/plain\\r\\n\\r\\nhello
world\")))
8080)
Equivalently, the following starts an identical server using a
@@ -272,8 +274,12 @@ Return non-nil only when parsing is complete."
(setf (active request) nil)
nil))
- (defun ws-call-handler (request handlers)
+(defun ws-call-handler (request handlers)
(catch 'matched-handler
+ (when (functionp handlers)
+ (throw 'matched-handler
+ (condition-case e (funcall handlers request)
+ (error (ws-error (process request) "Caught Error: %S" e)))))
(mapc (lambda (handler)
(let ((match (car handler))
(function (cdr handler)))
@@ -286,10 +292,10 @@ Return non-nil only when parsing is complete."
(throw 'matched-handler
(condition-case e (funcall function request)
(error (ws-error (process request)
- "Caught Error: %S" e)))))))
+ "Caught Error: %S" e)))))))
handlers)
(ws-error (process request) "no handler matched request: %S"
- (headers request))))
+ (headers request))))
(defun ws-error (proc msg &rest args)
(let ((buf (plist-get (process-plist proc) :log-buffer))
