Add support for content-disposition

* module/web/http.scm ("Content-Disposition"): Add a parser and
  serializer.  Defined in RFC2616 section 19.5.1.

* test-suite/tests/web-http.test ("entity headers"): New test case.

2 files changed, 28 insertions, 2 deletions

diff --git a/module/web/http.scm b/module/web/http.scm
index 6c9ab9523..d22c70c6e 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -1,6 +1,6 @@
 ;;; HTTP messages
 
-;; Copyright (C)  2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;; Copyright (C)  2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
 
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -1483,6 +1483,30 @@ treated specially, and is just returned as a plain string."
 ;;
 (declare-symbol-list-header! "Allow")
 
+;; Content-Disposition = disposition-type *( ";" disposition-parm )
+;; disposition-type = "attachment" | disp-extension-token
+;; disposition-parm = filename-parm | disp-extension-parm
+;; filename-parm = "filename" "=" quoted-string
+;; disp-extension-token = token
+;; disp-extension-parm = token "=" ( token | quoted-string )
+;;
+(declare-header! "Content-Disposition"
+  (lambda (str)
+    (let ((disposition (parse-param-list str default-val-parser)))
+      ;; Lazily reuse the param list parser.
+      (unless (and (pair? disposition)
+                   (null? (cdr disposition)))
+        (bad-header-component 'content-disposition str))
+      (car disposition)))
+  (lambda (val)
+    (and (pair? val)
+         (symbol? (car val))
+         (list-of? (cdr val)
+                   (lambda (x)
+                     (and (pair? x) (symbol? (car x)) (string? (cdr x)))))))
+  (lambda (val port)
+    (write-param-list (list val) port)))
+
 ;; Content-Encoding = 1#content-coding
 ;;
 (declare-symbol-list-header! "Content-Encoding")
diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
index e24a268ec..aa607afad 100644
--- a/test-suite/tests/web-http.test
+++ b/test-suite/tests/web-http.test
@@ -1,6 +1,6 @@
 ;;;; web-uri.test --- URI library          -*- mode: scheme; coding: utf-8; -*-
 ;;;;
-;;;; 	Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2010, 2011, 2014 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -252,6 +252,8 @@
 
 (with-test-prefix "entity headers"
   (pass-if-parse allow "foo, bar" '(foo bar))
+  (pass-if-parse content-disposition "form-data; name=\"file\"; filename=\"q.go\""
+                 '(form-data (name . "file") (filename . "q.go")))
   (pass-if-parse content-encoding "qux, baz" '(qux baz))
   (pass-if-parse content-language "qux, baz" '("qux" "baz"))
   (pass-if-parse content-length "100" 100)