eschulte pushed a commit to branch master
in repository elpa.
commit 949208c6035e5ace43b2c91a21bd03f896735de1
Author: Eric Schulte <schulte.e...@gmail.com>
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
+@anchor{ws-with-authentication}
+@defun ws-with-authentication handler credentials &optional realm unauth
invalid
+Return a version of @code{handler} which is protected by
+@code{credentials}. 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,
+
+@example
+(list (cons '(:GET . ".*") 'view-handler)
+ (cons '(:POST . ".*") 'edit-handler))
+@end example
+
+could have authorization added by changing the handlers to the
+following.
+
+@example
+(list (cons '(:GET . ".*") view-handler)
+ (cons '(:POST . ".*") (ws-with-authentication
+ 'org-ehtml-edit-handler
+ '(("admin" . "password")))))
+@end example
+
+@end 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)))
