[elpa] 89/119: authorization helper

[Eric Schulte]

eschulte pushed a commit to branch master
in repository elpa.

commit 949208c6035e5ace43b2c91a21bd03f896735de1
Author: Eric Schulte <address@hidden>
Date:   Fri Jan 10 00:00:49 2014 -0700

    authorization helper
---
 doc/web-server.texi                  |   26 ++++++++++++++++++++++
 examples/006-basic-authentication.el |   30 ++++++------------------
 web-server.el                        |   40 ++++++++++++++++++++++++++++++++++
 3 files changed, 74 insertions(+), 22 deletions(-)

diff --git a/doc/web-server.texi b/doc/web-server.texi
index f75805a..06f2982 100644
--- a/doc/web-server.texi
+++ b/doc/web-server.texi
@@ -458,6 +458,32 @@ Check if @code{path} is under the @code{parent} directory.
 @end example
 @end defun
 
address@hidden
address@hidden ws-with-authentication handler credentials &optional realm 
unauth invalid
+Return a version of @code{handler} which is protected by
address@hidden  Handler should be a normal handler function
+(@pxref{Handlers}) and @code{credentials} should be an association
+list of usernames and passwords.
+
+For example, a server running the following handlers,
+
address@hidden
+(list (cons '(:GET  . ".*") 'view-handler)
+      (cons '(:POST . ".*") 'edit-handler))
address@hidden example
+
+could have authorization added by changing the handlers to the
+following.
+
address@hidden
+(list (cons '(:GET  . ".*") view-handler)
+      (cons '(:POST . ".*") (ws-with-authentication
+                             'org-ehtml-edit-handler
+                             '(("admin" . "password")))))
address@hidden example
+
address@hidden defun
+
 @anchor{ws-web-socket-connect}
 @defun ws-web-socket-connect request handler
 If @code{request} is a web socket upgrade request (indicated by the
diff --git a/examples/006-basic-authentication.el 
b/examples/006-basic-authentication.el
index 7bc0880..61d1d4b 100644
--- a/examples/006-basic-authentication.el
+++ b/examples/006-basic-authentication.el
@@ -2,25 +2,11 @@
 (lexical-let ((users '(("foo" . "bar")
                        ("baz" . "qux"))))
   (ws-start
-   (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))
+   (ws-with-authentication
+    (lambda (request)
+      (with-slots (process headers) request
+        (let ((user (caddr (assoc :AUTHORIZATION headers))))
+          (ws-response-header process 200 '("Content-type" . "text/plain"))
+          (process-send-string process (format "welcome %s" user)))))
+    users)
+   9006))
diff --git a/web-server.el b/web-server.el
index 59511cb..f9187ae 100644
--- a/web-server.el
+++ b/web-server.el
@@ -556,6 +556,46 @@ If so return PATH, if not return nil."
          (string= parent (substring expanded 0 (length parent)))
          expanded)))
 
+(defun ws-with-authentication (handler credentials
+                                       &optional realm unauth invalid)
+  "Return a version of HANDLER protected by CREDENTIALS.
+HANDLER should be a function as passed to `ws-start', and
+CREDENTIALS should be an alist of elements of the form (USERNAME
+. PASSWORD).
+
+Optional argument REALM sets the realm in the authentication
+challenge.  Optional arguments UNAUTH and INVALID should be
+functions which are called on the request when no authentication
+information, or invalid authentication information are provided
+respectively."
+  (lexical-let ((handler handler)
+                (credentials credentials)
+                (realm realm)
+                (unauth unauth)
+                (invalid invalid))
+    (lambda (request)
+      (with-slots (process headers) request
+        (let ((auth (cddr (assoc :AUTHORIZATION headers))))
+          (cond
+           ;; no authentication information provided
+           ((not auth)
+            (if unauth
+                (funcall unauth request)
+              (ws-response-header process 401
+                (cons "WWW-Authenticate"
+                      (format "Basic realm=%S" (or realm "restricted")))
+                '("Content-type" . "text/plain"))
+              (process-send-string process "authentication required")))
+           ;; valid authentication information
+           ((string= (cdr auth) (cdr (assoc (car auth) credentials)))
+            (funcall handler request))
+           ;; invalid authentication information
+           (t
+            (if invalid
+                (funcall invalid request)
+              (ws-response-header process 403 '("Content-type" . "text/plain"))
+              (process-send-string process "invalid credentials")))))))))
+
 (defun ws-web-socket-handshake (key)
   "Perform the handshake defined in RFC6455."
   (base64-encode-string (sha1 (concat (ws-trim key) ws-guid) nil nil 'binary)))