[elpa] 88/119: accept single-function handlers

[Eric Schulte]

eschulte pushed a commit to branch master
in repository elpa.

commit 5cb2812c321c4d6b2f7935f0cab5df0fc18aff73
Author: Eric Schulte <address@hidden>
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
address@hidden and @code{port}.  It starts a server listening on
address@hidden 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))