Merge branch 'dfsg_clean'

5 files changed, 128 insertions, 54 deletions

diff --git a/src/c/fastcgi.c b/src/c/fastcgi.c
index cda3e1f6..c37debf7 100644
--- a/src/c/fastcgi.c
+++ b/src/c/fastcgi.c
@@ -1,5 +1,7 @@
 #include "config.h"
 
+#include <assert.h>
+#include <stdint.h>
 #include <stdio.h>
 #include <string.h>
 #include <stdlib.h>
@@ -20,6 +22,8 @@
 
 #include "fastcgi.h"
 
+#define THREAD_LOCAL __thread
+
 extern uw_app uw_application;
 
 typedef struct {
@@ -44,6 +48,21 @@ typedef struct {
   int available, used, sock;
 } FCGI_Input;
 
+// The FastCGI request ID corresponding to the request being handled by the
+// current worker thread.  (Each worker thread can only handle one request at a
+// time.)
+static THREAD_LOCAL int current_request_id;
+
+// Reads the FastCGI request ID from a FastCGI record.  The result is guaranteed
+// to be in the range [0, 2^16); this function returns an int to avoid C type
+// promotion insanity.
+static int fastcgi_request_id(const FCGI_Record* const r) {
+  const int requestid = r->requestIdB1 << 8 | r->requestIdB0;
+  assert(requestid >= 0);
+  assert(requestid <= UINT16_MAX);
+  return requestid;
+}
+
 static FCGI_Output *fastcgi_output() {
   FCGI_Output *o = malloc(sizeof(FCGI_Output));
 
@@ -70,7 +89,9 @@ static int fastcgi_send(FCGI_Output *o,
                         unsigned char type,
                         unsigned short contentLength) {
   o->r.type = type;
-  o->r.requestIdB1 = o->r.requestIdB0 = 0;
+  assert(current_request_id <= UINT16_MAX);
+  o->r.requestIdB1 = current_request_id >> 8;
+  o->r.requestIdB0 = current_request_id & 0x000000ff;
   o->r.contentLengthB1 = contentLength >> 8;
   o->r.contentLengthB0 = contentLength & 255;
   return uw_really_send(o->sock, &o->r, sizeof(o->r) - 65535 + contentLength);
@@ -356,6 +377,10 @@ static void *worker(void *data) {
       goto done;
     }
 
+    // Save the FastCGI request ID this worker is handling so that fastcgi_send
+    // can include it in its response.
+    current_request_id = fastcgi_request_id(r);
+
     if (r->type != FCGI_BEGIN_REQUEST) {
       write_stderr(out, "First message is not BEGIN_REQUEST\n");
       goto done;
@@ -373,6 +398,15 @@ static void *worker(void *data) {
         goto done;
       }
 
+      if (fastcgi_request_id(r) != current_request_id) {
+        write_stderr(out,
+                     "Ignoring environment variables for request %d (current"
+                     " request has id %d)\n",
+                     fastcgi_request_id(r),
+                     current_request_id);
+        continue;
+      }
+
       if (r->type != FCGI_PARAMS) {
         write_stderr(out, "Expected FCGI_PARAMS but got %d\n", r->type);
         goto done;
@@ -428,6 +462,15 @@ static void *worker(void *data) {
         goto done;
       }
 
+      if (fastcgi_request_id(r) != current_request_id) {
+        write_stderr(out,
+                     "Ignoring STDIN for request %d (current request has id"
+                     " %d)\n",
+                     fastcgi_request_id(r),
+                     current_request_id);
+        continue;
+      }
+
       if (r->type != FCGI_STDIN) {
         write_stderr(out, "Expected FCGI_STDIN but got %d\n", r->type);
         goto done;
diff --git a/src/c/http.c b/src/c/http.c
index d186e209..1bc58677 100644
--- a/src/c/http.c
+++ b/src/c/http.c
@@ -322,19 +322,28 @@ static void sigint(int signum) {
   exit(0);
 }
 
+union uw_sockaddr {
+  struct sockaddr sa;
+  struct sockaddr_in ipv4;
+  struct sockaddr_in6 ipv6;
+};
+
 int main(int argc, char *argv[]) {
   // The skeleton for this function comes from Beej's sockets tutorial.
   int sockfd;  // listen on sock_fd
-  struct sockaddr_in6 my_addr;
-  struct sockaddr_in6 their_addr; // connector's address information
-  socklen_t sin_size;
-  int yes = 1, no = 0, uw_port = 8080, nthreads = 1, i, *names, opt;
+  union uw_sockaddr my_addr;
+  union uw_sockaddr their_addr; // connector's address information
+  socklen_t my_size = 0, sin_size;
+  int yes = 1, uw_port = 8080, nthreads = 1, i, *names, opt;
   int recv_timeout_sec = 5;
  
   signal(SIGINT, sigint);
   signal(SIGPIPE, SIG_IGN); 
 
-  my_addr.sin6_addr = in6addr_any; // auto-fill with my IP
+  // default if not specified: IPv4 with my IP
+  memset(&my_addr, 0, sizeof my_addr);
+  my_addr.sa.sa_family = AF_INET;
+  my_addr.ipv4.sin_addr.s_addr = INADDR_ANY; // auto-fill with my IP
 
   while ((opt = getopt(argc, argv, "hp:a:A:t:kqT:")) != -1) {
     switch (opt) {
@@ -357,20 +366,17 @@ int main(int argc, char *argv[]) {
       break;
 
     case 'a':
-      {
-        char *buf = alloca(strlen(optarg) + 8);
-        strcpy(buf, "::FFFF:");
-        strcpy(buf + 7, optarg);
-        if (!inet_pton(AF_INET6, buf, &my_addr.sin6_addr)) {
-          fprintf(stderr, "Invalid IPv4 address\n");
-          help(argv[0]);
-          return 1;
-        }
+      my_addr.sa.sa_family = AF_INET;
+      if (!inet_pton(AF_INET, optarg, &my_addr.ipv4.sin_addr)) {
+        fprintf(stderr, "Invalid IPv4 address\n");
+        help(argv[0]);
+        return 1;
       }
       break;
 
     case 'A':
-      if (!inet_pton(AF_INET6, optarg, &my_addr.sin6_addr)) {
+      my_addr.sa.sa_family = AF_INET6;
+      if (!inet_pton(AF_INET6, optarg, &my_addr.ipv6.sin6_addr)) {
         fprintf(stderr, "Invalid IPv6 address\n");
         help(argv[0]);
         return 1;
@@ -413,7 +419,7 @@ int main(int argc, char *argv[]) {
 
   names = calloc(nthreads, sizeof(int));
 
-  sockfd = socket(AF_INET6, SOCK_STREAM, 0); // do some error checking!
+  sockfd = socket(my_addr.sa.sa_family, SOCK_STREAM, 0); // do some error checking!
 
   if (sockfd < 0) {
     fprintf(stderr, "Listener socket creation failed\n");
@@ -425,15 +431,20 @@ int main(int argc, char *argv[]) {
     return 1;
   }
 
-  if (setsockopt(sockfd, IPPROTO_IPV6, IPV6_V6ONLY, &no, sizeof(int)) < 0) {
-    fprintf(stderr, "Listener IPV6_V6ONLY option resetting failed\n");
-    return 1;
+  switch (my_addr.sa.sa_family)
+  {
+  case AF_INET:
+    my_size = sizeof(my_addr.ipv4);
+    my_addr.ipv4.sin_port = htons(uw_port);
+    break;
+
+  case AF_INET6:
+    my_size = sizeof(my_addr.ipv6);
+    my_addr.ipv6.sin6_port = htons(uw_port);
+    break;
   }
 
-  my_addr.sin6_family = AF_INET6;        // host byte order
-  my_addr.sin6_port = htons(uw_port);    // short, network byte order
-
-  if (bind(sockfd, (struct sockaddr *)&my_addr, sizeof my_addr) < 0) {
+  if (bind(sockfd, &my_addr.sa, my_size) < 0) {
     fprintf(stderr, "Listener socket bind failed\n");
     return 1;
   }
@@ -470,7 +481,7 @@ int main(int argc, char *argv[]) {
   }
 
   while (1) {
-    int new_fd = accept(sockfd, (struct sockaddr *)&their_addr, &sin_size);
+    int new_fd = accept(sockfd, &their_addr.sa, &sin_size);
 
     if (new_fd < 0) {
       qfprintf(stderr, "Socket accept failed\n");
diff --git a/src/compiler.sml b/src/compiler.sml
index 4fe2dfd5..481f04b6 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -687,7 +687,7 @@ fun parseUrp' accLibs fname =
                              }
                          in
                              if accLibs then
-                                 foldr (fn (job', job) => merge (job, job')) job (!libs)
+                                 foldl (fn (job', job) => merge (job, job')) job (!libs)
                              else
                                  job
                          end
diff --git a/src/monoize.sml b/src/monoize.sml
index 86f2b4a5..ddf6cd4c 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3657,9 +3657,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             end
 
           | L.EApp (
-            (L.EApp ((L.ECApp (
-                      (L.ECApp ((L.EFfi ("Basis", "form"), _), _), _),
-                      (L.CRecord (_, fields), _)), _),
+            (L.EApp ((L.EApp ((L.ECApp (
+                                    (L.ECApp ((L.EFfi ("Basis", "form"), _), _), _),
+                                    (L.CRecord (_, fields), _)), _),
+                              id), _),
                      class), _),
             xml) =>
             let
@@ -3793,6 +3794,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                  action
 
                 val stt = (L'.TFfi ("Basis", "string"), loc)
+                val (id, fm) = monoExp (env, st, fm) id
                 val (class, fm) = monoExp (env, st, fm) class
                 val action = (L'.EStrcat (action,
                                           (L'.ECase (class,
@@ -3806,8 +3808,17 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                       result = stt}), loc)), loc)
             in
                 ((L'.EStrcat ((L'.EStrcat (strH "<form method=\"post\"",
-                                           (L'.EStrcat (action,
-                                                        strH ">"), loc)), loc),
+                                           (L'.EStrcat ((L'.ECase (id,
+                                                                   [((L'.PNone stt, loc),
+                                                                     strH ""),
+                                                                    ((L'.PSome (stt, (L'.PVar ("id", stt), loc)), loc),
+                                                                     (L'.EStrcat (strH " id=\"",
+                                                                                  (L'.EStrcat ((L'.ERel 0, loc),
+                                                                                               strH "\""), loc)), loc))],
+                                                                   {disc = (L'.TOption stt, loc),
+                                                                    result = stt}), loc),
+                                                        (L'.EStrcat (action,
+                                                                     strH ">"), loc)), loc)), loc),
                               (L'.EStrcat (xml,
                                            strH "</form>"), loc)), loc),
                  fm)
diff --git a/src/urweb.grm b/src/urweb.grm
index 40101056..db5473a6 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -475,10 +475,11 @@ fun patternOut (e : exp) =
  | eterm of exp
  | etuple of exp list
  | rexp of (con * exp) list * bool
+ | rpath of con
  | xml of exp
  | xmlOne of exp
  | xmlOpt of exp
- | tag of (string * exp) * exp option * exp option * exp
+ | tag of (string * exp) * exp option * exp option * exp option * exp
  | tagHead of string * exp
  | bind of pat * con option * exp
  | edecl of edecl
@@ -499,7 +500,7 @@ fun patternOut (e : exp) =
  | rpat of (string * pat) list * bool
  | ptuple of pat list
 
- | attrs of exp option * exp option * exp option * exp option * (string * string * exp) list * (con * exp) list
+ | attrs of exp option * exp option * exp option * exp option * exp option * (string * string * exp) list * (con * exp) list
  | attr of attr
  | attrv of exp
 
@@ -1151,15 +1152,15 @@ ctuple : capps STAR capps               ([capps1, capps2])
        | capps STAR ctuple              (capps :: ctuple)
 
 rcon   :                                ([])
-       | ident EQ cexp                  ([(ident, cexp)])
-       | ident EQ cexp COMMA rcon       ((ident, cexp) :: rcon)
+       | rpath EQ cexp                  ([(rpath, cexp)])
+       | rpath EQ cexp COMMA rcon       ((rpath, cexp) :: rcon)
 
-rconn  : ident                          ([(ident, (CUnit, s (identleft, identright)))])
-       | ident COMMA rconn              ((ident, (CUnit, s (identleft, identright))) :: rconn)
+rconn  : rpath                          ([(rpath, (CUnit, s (rpathleft, rpathright)))])
+       | rpath COMMA rconn              ((rpath, (CUnit, s (rpathleft, rpathright))) :: rconn)
 
 rcone  :                                ([])
-       | ident COLON cexp               ([(ident, cexp)])
-       | ident COLON cexp COMMA rcone   ((ident, cexp) :: rcone)
+       | rpath COLON cexp               ([(rpath, cexp)])
+       | rpath COLON cexp COMMA rcone   ((rpath, cexp) :: rcone)
 
 ident  : CSYMBOL                        (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
        | INT                            (CName (Int64.toString INT), s (INTleft, INTright))
@@ -1567,8 +1568,11 @@ ptuple : pat COMMA pat                  ([pat1, pat2])
        | pat COMMA ptuple               (pat :: ptuple)
 
 rexp   : DOTDOTDOT                      ([], true)
-       | ident EQ eexp                  ([(ident, eexp)], false)
-       | ident EQ eexp COMMA rexp       ((ident, eexp) :: #1 rexp, #2 rexp)
+       | rpath EQ eexp                  ([(rpath, eexp)], false)
+       | rpath EQ eexp COMMA rexp       ((rpath, eexp) :: #1 rexp, #2 rexp)
+
+rpath  : path                           (CVar path, s (pathleft, pathright))
+       | CSYMBOL                        (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
 
 xml    : xmlOne xml                     (let
                                              val pos = s (xmlOneleft, xmlright)
@@ -1606,7 +1610,7 @@ xmlOne : NOTAGS                         (EApp ((EVar (["Basis"], "cdata", Infer)
                                                                 (EPrim (Prim.String (Prim.Html, "")), pos)),
                                                           pos)
                                          in
-                                             (EApp (#4 tag, cdata), pos)
+                                             (EApp (#5 tag, cdata), pos)
                                          end)
          
        | tag GT xmlOpt END_TAG          (let
@@ -1622,6 +1626,9 @@ xmlOne : NOTAGS                         (EApp ((EVar (["Basis"], "cdata", Infer)
                                                  if et = "form" then
                                                      let
                                                          val e = (EVar (["Basis"], "form", Infer), pos)
+                                                         val e = (EApp (e, case #4 tag of
+                                                                               NONE => (EVar (["Basis"], "None", Infer), pos)
+                                                                             | SOME c => (EApp ((EVar (["Basis"], "Some", Infer), pos), c), pos)), pos)
                                                          val e = (EApp (e, case #2 tag of
                                                                                NONE => (EVar (["Basis"], "None", Infer), pos)
                                                                              | SOME (EPrim (Prim.String (_, s)), _) => (EApp ((EVar (["Basis"], "Some", Infer), pos), parseClass s pos), pos)
@@ -1639,7 +1646,7 @@ xmlOne : NOTAGS                         (EApp ((EVar (["Basis"], "cdata", Infer)
                                                      (EApp ((EVar (["Basis"], "entry", Infer), pos),
                                                             xmlOpt), pos)
                                                  else
-                                                     (EApp (#4 tag, xmlOpt), pos)
+                                                     (EApp (#5 tag, xmlOpt), pos)
                                              else
                                                  (if ErrorMsg.anyErrors () then
                                                       ()
@@ -1684,8 +1691,8 @@ tag    : tagHead attrs                  (let
                                                                            e), pos)
                                              val e = (EApp (e, eo), pos)
 
-                                             val atts = case #5 attrs of
-                                                            [] => #6 attrs
+                                             val atts = case #6 attrs of
+                                                            [] => #7 attrs
                                                           | data :: datas =>
                                                             let
                                                                 fun doOne (kind, name, value) =
@@ -1705,14 +1712,14 @@ tag    : tagHead attrs                  (let
                                                                                            (EApp (e, doOne nv), pos)
                                                                                        end) (doOne data) datas
                                                             in
-                                                                ((CName "Data", pos), datas') :: #6 attrs
+                                                                ((CName "Data", pos), datas') :: #7 attrs
                                                             end
 
                                              val e = (EApp (e, (ERecord (atts, false), pos)), pos)
                                              val e = (EApp (e, (EApp (#2 tagHead,
                                                                       (ERecord ([], false), pos)), pos)), pos)
                                          in
-                                             (tagHead, #1 attrs, #2 attrs, e)
+                                             (tagHead, #1 attrs, #2 attrs, #5 attrs, e)
                                          end)
 
 tagHead: BEGIN_TAG                      (let
@@ -1724,7 +1731,7 @@ tagHead: BEGIN_TAG                      (let
                                          end)
        | tagHead LBRACE cexp RBRACE     (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
                                           
-attrs  :                                (NONE, NONE, NONE, NONE, [], [])
+attrs  :                                (NONE, NONE, NONE, NONE, NONE, [], [])
        | attr attrs                     (let
                                              val loc = s (attrleft, attrsright)
                                          in
@@ -1733,26 +1740,28 @@ attrs  :                                (NONE, NONE, NONE, NONE, [], [])
                                                  (case #1 attrs of
                                                       NONE => ()
                                                     | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag";
-                                                  (SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs, #6 attrs))
+                                                  (SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs, #6 attrs, #7 attrs))
                                                | DynClass e =>
                                                  (case #2 attrs of
                                                       NONE => ()
                                                     | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
-                                                  (#1 attrs, SOME e, #3 attrs, #4 attrs, #5 attrs, #6 attrs))
+                                                  (#1 attrs, SOME e, #3 attrs, #4 attrs, #5 attrs, #6 attrs, #7 attrs))
                                                | Style e =>
                                                  (case #3 attrs of
                                                       NONE => ()
                                                     | SOME _ => ErrorMsg.errorAt loc "Multiple styles specified for tag";
-                                                  (#1 attrs, #2 attrs, SOME e, #4 attrs, #5 attrs, #6 attrs))
+                                                  (#1 attrs, #2 attrs, SOME e, #4 attrs, #5 attrs, #6 attrs, #7 attrs))
                                                | DynStyle e =>
                                                  (case #4 attrs of
                                                       NONE => ()
                                                     | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
-                                                  (#1 attrs, #2 attrs, #3 attrs, SOME e, #5 attrs, #6 attrs))
+                                                  (#1 attrs, #2 attrs, #3 attrs, SOME e, #5 attrs, #6 attrs, #7 attrs))
                                                | Data xe =>
-                                                 (#1 attrs, #2 attrs, #3 attrs, #4 attrs, xe :: #5 attrs, #6 attrs)
+                                                 (#1 attrs, #2 attrs, #3 attrs, #4 attrs, #5 attrs, xe :: #6 attrs, #7 attrs)
                                                | Normal xe =>
-                                                 (#1 attrs, #2 attrs, #3 attrs, #4 attrs, #5 attrs, xe :: #6 attrs)
+                                                 (#1 attrs, #2 attrs, #3 attrs, #4 attrs, (case #1 (#1 xe) of
+                                                                                               CName "Id" => SOME (#2 xe)
+                                                                                             | _ => #5 attrs), #6 attrs, xe :: #7 attrs)
                                          end)
 
 attr   : SYMBOL EQ attrv                (case SYMBOL of