[Gd-chatter] r10908 - in trunk/libraries: koala/sources/koala web-framework

[turbo24prg at gwydiondylan.org]

Author: turbo24prg
Date: Sun Sep 10 19:37:43 2006
New Revision: 10908

Modified:
   trunk/libraries/koala/sources/koala/server.dylan
   trunk/libraries/web-framework/changes.dylan
   trunk/libraries/web-framework/library.dylan
Log:
Job: koala

* upload hack



Modified: trunk/libraries/koala/sources/koala/server.dylan
==============================================================================
--- trunk/libraries/koala/sources/koala/server.dylan	(original)
+++ trunk/libraries/koala/sources/koala/server.dylan	Sun Sep 10 19:37:43 2006
@@ -512,7 +512,7 @@
   slot request-responder :: false-or(<function>) = #f;
 
   // For directory responders, this contains the part of the URL after
-  // the matched directory prefix and before the & (if any).
+  // the matched directory prefix and before the ? (if any).
   slot request-url-tail :: <string> = "";
 
 end class <request>;
@@ -736,9 +736,10 @@
 define function process-request-content
     (request :: <request>, buffer :: <byte-string>, content-length :: <integer>)
  => (content :: <string>)
-  let content-type = get-header(request, "content-type");
-  if (instance?(content-type, <string>)
-      & string-equal?("application/x-www-form-urlencoded", content-type))
+  let header-content-type = split(get-header(request, "content-type"), separator: ";");
+  let content-type = first(header-content-type);
+  if (instance?(content-type, <string>) &
+      string-equal?("application/x-www-form-urlencoded", content-type))
     log-debug("Form query string = %=",
               copy-sequence(buffer, end: content-length));
     // Replace '+' with Space.  See RFC 1866 (HTML) section 8.2.
@@ -757,6 +758,20 @@
   elseif (member?(content-type, #["text/xml", "text/html", "text/plain"],
                   test: string-equal?))
     request-content(request) := buffer
+  elseif (instance?(content-type, <string>) & 
+          element(header-content-type, 1, default: #f) &
+          string-equal?("multipart/form-data", content-type))
+    let boundary = split(second(header-content-type), separator: "=");
+    if (element(boundary, 1, default: #f))
+      let boundary-value = second(boundary);
+      log-debug("boundary: %=", boundary-value);
+      extract-form-data(buffer, boundary-value, request);
+      // ???
+      request-content(request) := buffer
+    else
+      log-error("%=", "content-type is missing the boundary parameter");
+      unsupported-media-type-error();
+    end if
   else
     unsupported-media-type-error();
   end if;
@@ -1004,6 +1019,44 @@
   end;
 end extract-request-version;
 
+define method extract-form-data
+ (buffer :: <string>, boundary :: <string>, request :: <request>)
+  // strip everything after end-boundary
+  let buffer = first(split(buffer, separator: concatenate("--", boundary, "--")));
+  let parts = split(buffer, separator: concatenate("--", boundary));
+  for (part in parts) 
+    let part = split(part, separator: "\r\n\r\n");
+    let header = first(part);
+    let header-entries = split(header, separator: "\r\n");
+    let disposition = #f;
+    let name = #f;
+    let type = #f;
+    let filename = #f;
+    for (header-entry in header-entries)
+      let header-entry-parts = split(header-entry, separator: ";");
+      for (header-entry-part in header-entry-parts)
+        let eq-pos = char-position('=', header-entry-part, 0, size(header-entry-part));
+        let p-pos = char-position(':', header-entry-part, 0, size(header-entry-part));
+        if (p-pos & (substring(header-entry-part, 0, p-pos) = "Content-Disposition"))
+          disposition := substring(header-entry-part, p-pos + 2, size(header-entry-part));
+        elseif (p-pos & (substring(header-entry-part, 0, p-pos) = "Content-Type"))
+          type := substring(header-entry-part, p-pos + 2, size(header-entry-part));
+        elseif (eq-pos & (substring(header-entry-part, 0, eq-pos) = "name"))
+          // name unquoted
+          name := substring(header-entry-part, eq-pos + 2, size(header-entry-part) - 1);
+        elseif (eq-pos & (substring(header-entry-part, 0, eq-pos) = "filename"))
+          // filename unquoted
+          filename := substring(header-entry-part, eq-pos + 2, size(header-entry-part) - 1);
+        end if;
+      end for;
+    end for;
+    if (part.size > 1)
+      request.request-query-values[name] := substring(second(part), 0, size(second(part)) - 1);
+    end if;
+    log-debug("multipart/form-data for %=: %=, %=, %=", name, disposition, type, filename);
+  end for;
+end method extract-form-data;
+
 // Turn a string like "foo=8&bar=&baz=zzz" into a <string-table> with the "obvious" keys/vals.
 // Note that in the above example string "bar" maps to "", not #f.
 //---TODO: Find out if the query keys are case-sensitive in the HTTP spec and make sure this

Modified: trunk/libraries/web-framework/changes.dylan
==============================================================================
--- trunk/libraries/web-framework/changes.dylan	(original)
+++ trunk/libraries/web-framework/changes.dylan	Sun Sep 10 19:37:43 2006
@@ -40,19 +40,22 @@
 
 define open class <entry> (<object>)
   /* slot CommonAttributes */
-  slot authors :: <list> = #(),
+  slot authors :: <stretchy-vector> = 
+    make(<stretchy-vector>, size: 0),
     init-keyword: authors:;
-  slot categories :: <list> = #(),
+  slot categories :: <stretchy-vector> =
+    make(<stretchy-vector>, size: 0),
     init-keyword: categories:;
   slot content :: false-or(<content>) = #f,
     init-keyword: content:;
-  slot contributors :: <list> = #(),
+  slot contributors :: <stretchy-vector> = 
+    make(<stretchy-vector>, size: 0),
     init-keyword: contributors:;
   slot identifier :: <uri>,
     init-keyword: identifier:;
   slot links :: <list> = #(),
     init-keyword: links:;
-  slot published :: <date>,
+  slot published :: <date> = current-date(),
     init-keyword: published:;
   slot rights :: false-or(<text>) = #f,
     init-keyword: rights:;
@@ -69,6 +72,15 @@
   /* repeated slot extensionElement */
 end;
 
+define class <comment> (<object>)
+  slot commenter :: <string>,
+    init-keyword: commenter:;
+  slot email :: <email>,
+    init-keyword: email:;
+  slot content :: <content>,
+    init-keyword: content:;
+end;
+
 define abstract class <content> (<object>)
   /* slot CommonAttributes */
   slot type :: <string>, init-keyword: type:;
@@ -77,7 +89,15 @@
 
 define class <raw-content> (<content>)
   inherited slot type :: <string> = "raw";
-end class <raw-content>;
+end;
+
+define class <textile-content> (<content>)
+  inherited slot type :: <string> = "textile";
+end;
+
+define class <xhtml-content> (<content>)
+  inherited slot type :: <string> = "xhtml";
+end;
 
 /*
 define class <inline-text-content> (<content>)

Modified: trunk/libraries/web-framework/library.dylan
==============================================================================
--- trunk/libraries/web-framework/library.dylan	(original)
+++ trunk/libraries/web-framework/library.dylan	Sun Sep 10 19:37:43 2006
@@ -176,12 +176,16 @@
     text, text-setter;
     
   export <content>,
-    <raw-content>;
+    <raw-content>,
+    <textile-content>,
+    <xhtml-content>;
     
   //commands
   export <add-command>,
     <remove-command>,
     <edit-command>;
+
+  export <comment>;
 end;