[elpa] 57/119: BASIC HTTP authentication

[Eric Schulte]

eschulte pushed a commit to branch master
in repository elpa.

commit 532edd1f9f8a13604bb9cb834deb0b903d04c045
Author: Eric Schulte <address@hidden>
Date:   Thu Jan 2 20:44:59 2014 -0700

    BASIC HTTP authentication
---
 NOTES                              |    9 ++++++++-
 doc/web-server.texi                |   21 ++++++++++++++++++++-
 examples/6-basic-authentication.el |   28 ++++++++++++++++++++++++++++
 web-server-test.el                 |   18 ++++++++++++++++++
 web-server.el                      |   23 +++++++++++++++++++++--
 5 files changed, 95 insertions(+), 4 deletions(-)

diff --git a/NOTES b/NOTES
index 2d1a8a2..f87e76c 100644
--- a/NOTES
+++ b/NOTES
@@ -1,7 +1,14 @@
                                                            -*- org -*-
 
 * Notes
-* Tasks [8/10]
+* Tasks [9/13]
+** TODO authentication [1/2]
+*** DONE Basic
+http://en.wikipedia.org/wiki/Basic_access_authentication
+
+*** TODO Digest
+http://en.wikipedia.org/wiki/Digest_access_authentication
+
 ** TODO documentation for running in a chroot jail
 see https://wiki.archlinux.org/index.php/nginx#Installation_in_a_chroot
 
diff --git a/doc/web-server.texi b/doc/web-server.texi
index 82ea63b..f74a63a 100644
--- a/doc/web-server.texi
+++ b/doc/web-server.texi
@@ -158,6 +158,7 @@ These examples demonstrate usage.
 * File Server::                 Serve files from a document root
 * URL Parameter Echo::          Echo Parameters from a URL query string
 * POST Echo::                   Echo POST parameters back
+* Basic Authentication::        BASIC HTTP Authentication
 @end menu
 
 @node Hello World, Hello World UTF8, Usage Examples, Usage Examples
@@ -218,7 +219,7 @@ the following HTML table.
 
 @verbatiminclude ../examples/4-url-param-echo.el
 
address@hidden POST Echo, Function Index, URL Parameter Echo, Usage Examples
address@hidden POST Echo, Basic Authentication, URL Parameter Echo, Usage 
Examples
 @section POST Echo
 
 The following example echos back the content of the ``message'' field
@@ -226,6 +227,24 @@ in a @code{POST} request.
 
 @verbatiminclude ../examples/5-post-echo.el
 
address@hidden Basic Authentication, Function Index, POST Echo, Usage Examples
+
+The following example demonstrates BASIC HTTP authentication.  The
+handler prompts an unauthenticated client for authentication by
+sending a ``WWW-Authenticate'' header.
+
address@hidden
+(ws-response-header process 401
+  '("WWW-Authenticate" . "Basic realm=\"example\"")
+  '("Content-type" . "text/plain"))
address@hidden example
+
+The client replies by setting the ``Authorization'' HTTP header which
+is parsed into a list of the form @code{(PROTOCOL USERNAME
+. PASSWORD)}.  Currently only BASIC HTTP authentication is supported.
+
address@hidden ../examples/6-basic-authentication.el
+
 @node Function Index, Copying, Usage Examples, Top
 @chapter Function Index
 @cindex function index
diff --git a/examples/6-basic-authentication.el 
b/examples/6-basic-authentication.el
new file mode 100644
index 0000000..beec379
--- /dev/null
+++ b/examples/6-basic-authentication.el
@@ -0,0 +1,28 @@
+;;; basic-authentication.el --- basic authentication
+(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"))))))))
+   9007))
diff --git a/web-server-test.el b/web-server-test.el
index 5dd4082..b371e7d 100644
--- a/web-server-test.el
+++ b/web-server-test.el
@@ -190,4 +190,22 @@ 
org=-+one%0A-+two%0A-+three%0A-+four%0A%0A&beg=646&end=667&path=%2Fcomplex.org")
   (should     (ws-in-directory-p "/tmp/" "pics"))
   (should-not (ws-in-directory-p "/tmp/" "..")))
 
+(ert-deftest ws/parse-basic-authorization ()
+  "Test that a number of headers parse successfully."
+  (let* ((server (ws-start nil ws-test-port))
+         (request (make-instance 'ws-request))
+         (username "foo") (password "bar")
+         (header-string (format "GET / HTTP/1.1
+Authorization: Basic %s
+Connection: keep-alive
+
+" (base64-encode-string (concat username ":" password)))))
+    (unwind-protect
+        (progn
+          (ws-parse-request request header-string)
+          (with-slots (headers) request
+            (cl-tree-equal (cdr (assoc :AUTHORIZATION headers))
+                           (cons :BASIC (cons username password)))))
+      (ws-stop server))))
+
 (provide 'web-server-test)
diff --git a/web-server.el b/web-server.el
index ac02cdf..efed1a6 100644
--- a/web-server.el
+++ b/web-server.el
@@ -136,8 +136,10 @@ function.
           (url-parse-query-string string nil 'allow-newlines)))
 
 (defun ws-parse (proc string)
-  (cl-flet ((to-keyword (s) (intern (concat ":" (upcase (match-string 1 s))))))
+  "Parse HTTP headers in STRING reporting errors to PROC."
+  (cl-flet ((to-keyword (s) (intern (concat ":" (upcase s)))))
     (cond
+     ;; Method
      ((string-match ws-http-method-rx string)
       (let ((method (to-keyword (match-string 1 string)))
             (url (match-string 2 string)))
@@ -146,8 +148,25 @@ function.
                   (ws-parse-query-string
                    (url-unhex-string (substring url (match-end 0)))))
           (list (cons method url)))))
+     ;; Authorization
+     ((string-match "^AUTHORIZATION: \\([^[:space:]]+\\) \\(.*\\)$" string)
+      (let ((protocol (to-keyword (match-string 1 string)))
+            (credentials (match-string 2 string)))
+        (list (cons :AUTHORIZATION
+                    (cons protocol
+                          (case protocol
+                            (:BASIC
+                             (let ((cred (base64-decode-string credentials)))
+                               (if (string-match ":" cred)
+                                   (cons (substring cred 0 (match-beginning 0))
+                                         (substring cred (match-end 0)))
+                                 (ws-error proc "bad credentials: %S" cred))))
+                            (t (ws-error proc "un-support protocol: %s"
+                                         protocol))))))))
+     ;; All other headers
      ((string-match "^\\([^[:space:]]+\\): \\(.*\\)$" string)
-      (list (cons (to-keyword string) (match-string 2 string))))
+      (list (cons (to-keyword (match-string 1 string))
+                  (match-string 2 string))))
      (:otherwise (ws-error proc "bad header: %S" string) nil))))
 
 (defun ws-trim (string)