Interface for setting memory limits

11 files changed, 77 insertions, 8 deletions

diff --git a/src/cgi.sml b/src/cgi.sml
index 9099d429..d8c7c3ec 100644
--- a/src/cgi.sml
+++ b/src/cgi.sml
@@ -36,7 +36,6 @@ val () = addProtocol {name = "cgi",
                       linkDynamic = "-lurweb_cgi",
                       persistent = false,
                       code = fn () => box [string "void uw_global_custom() {",
-                                           newline,
                                            case getSigFile () of
                                                NONE => box []
                                              | SOME sf => box [string "extern char *uw_sig_file;",
@@ -45,6 +44,8 @@ val () = addProtocol {name = "cgi",
                                                                string sf,
                                                                string "\";",
                                                                newline],
+                                           string "uw_setup_limits();",
+                                           newline,
                                            string "}",
                                            newline]}
 
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index ae347eb2..29f94fe6 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2828,6 +2828,26 @@ fun p_file env (ds, ps) =
              newline,
              newline,
 
+             box [string "static void uw_setup_limits() {",
+                  newline,
+                  box [p_list_sep (box []) (fn (class, num) =>
+                                               let
+                                                   val num = case class of
+                                                                 "page" => Int.max (2048, num)
+                                                               | _ => num
+                                               in
+                                                   box [string ("uw_" ^ class ^ "_max"),
+                                                        space,
+                                                        string "=",
+                                                        space,
+                                                        string (Int.toString num),
+                                                        string ";",
+                                                        newline]
+                                               end) (Settings.limits ())],
+                  string "}",
+                  newline,
+                  newline],
+
              #code (Settings.currentProtocol ()) (),
 
              if hasDb then
@@ -2837,17 +2857,17 @@ fun p_file env (ds, ps) =
                                                   views = !views,
                                                   sequences = !sequences}
              else
-                 box [string "void uw_client_init(void) { };",
+                 box [string "static void uw_client_init(void) { };",
                       newline,
-                      string "void uw_db_init(uw_context ctx) { };",
+                      string "static void uw_db_init(uw_context ctx) { };",
                       newline,
-                      string "int uw_db_begin(uw_context ctx) { return 0; };",
+                      string "static int uw_db_begin(uw_context ctx) { return 0; };",
                       newline,
-                      string "void uw_db_close(uw_context ctx) { };",
+                      string "static void uw_db_close(uw_context ctx) { };",
                       newline,
-                      string "int uw_db_commit(uw_context ctx) { return 0; };",
+                      string "static int uw_db_commit(uw_context ctx) { return 0; };",
                       newline,
-                      string "int uw_db_rollback(uw_context ctx) { return 0; };"],
+                      string "static int uw_db_rollback(uw_context ctx) { return 0; };"],
              newline,
              newline,
 
diff --git a/src/compiler.sml b/src/compiler.sml
index bf9bfbdf..038fa0ff 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -698,6 +698,17 @@ fun parseUrp' accLibs fname =
                                          m1 :: (fs as _ :: _) =>
                                          onError := SOME (m1, List.take (fs, length fs - 1), List.last fs)
                                        | _ => ErrorMsg.error "invalid 'onError' argument")
+                                  | "limit" =>
+                                    (case String.fields Char.isSpace arg of
+                                         [class, num] =>
+                                         (case Int.fromString num of
+                                              NONE => ErrorMsg.error ("invalid limit number '" ^ num ^ "'")
+                                            | SOME n =>
+                                              if n < 0 then
+                                                  ErrorMsg.error ("invalid limit number '" ^ num ^ "'")
+                                              else
+                                                  Settings.addLimit (class, n))
+                                       | _ => ErrorMsg.error "invalid 'limit' arguments")
 
                                   | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
                                 read ()
diff --git a/src/fastcgi.sml b/src/fastcgi.sml
index 31feaee9..5f849856 100644
--- a/src/fastcgi.sml
+++ b/src/fastcgi.sml
@@ -45,6 +45,8 @@ val () = addProtocol {name = "fastcgi",
                                                                string sf,
                                                                string "\";",
                                                                newline],
+                                           string "uw_setup_limits();",
+                                           newline,
                                            string "}",
                                            newline]}
 
diff --git a/src/http.sml b/src/http.sml
index a760e195..5859f077 100644
--- a/src/http.sml
+++ b/src/http.sml
@@ -45,6 +45,8 @@ val () = addProtocol {name = "http",
                                                                string sf,
                                                                string "\";",
                                                                newline],
+                                           string "uw_setup_limits();",
+                                           newline,
                                            string "}",
                                            newline]}
 
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index 09b53c58..a434ef12 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -91,6 +91,15 @@ fun doArgs args =
       | "-noEmacs" :: rest =>
         (Demo.noEmacs := true;
          doArgs rest)
+      | "-limit" :: class :: num :: rest =>
+        (case Int.fromString num of
+             NONE => raise Fail ("Invalid limit number '" ^ num ^ "'")
+           | SOME n =>
+             if n < 0 then
+                 raise Fail ("Invalid limit number '" ^ num ^ "'")
+             else
+                 Settings.addLimit (class, n);
+         doArgs rest)
       | arg :: rest =>
         (if size arg > 0 andalso String.sub (arg, 0) = #"-" then
              raise Fail ("Unknown flag " ^ arg)
diff --git a/src/settings.sig b/src/settings.sig
index 3ebf9300..b72d007b 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2009, Adam Chlipala
+(* Copyright (c) 2008-2010, Adam Chlipala
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
@@ -208,4 +208,7 @@ signature SETTINGS = sig
 
     val setOnError : (string * string list * string) option -> unit
     val getOnError : unit -> (string * string list * string) option
+
+    val addLimit : string * int -> unit
+    val limits : unit -> (string * int) list
 end
diff --git a/src/settings.sml b/src/settings.sml
index 5da1a24e..4512b7d8 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -490,4 +490,16 @@ val onError = ref (NONE : (string * string list * string) option)
 fun setOnError x = onError := x
 fun getOnError () = !onError
 
+val limits = ["messages", "clients", "headers", "page", "heap", "script",
+              "inputs", "subinputs", "cleanup", "deltas", "transactionals",
+              "globals", "database"]
+
+val limitsList = ref ([] : (string * int) list)
+fun addLimit (v as (name, _)) =
+    if List.exists (fn name' => name' = name) limits then
+        limitsList := v :: !limitsList
+    else
+        raise Fail ("Unknown limit category '" ^ name ^ "'")
+fun limits () = !limitsList
+
 end
diff --git a/tests/hog.ur b/tests/hog.ur
new file mode 100644
index 00000000..419d202d
--- /dev/null
+++ b/tests/hog.ur
@@ -0,0 +1,7 @@
+fun more n =
+    if n <= 0 then
+        "!"
+    else
+        more (n-1) ^ more (n-1)
+
+fun main n = return <xml>{[more n]}</xml>
diff --git a/tests/hog.urp b/tests/hog.urp
new file mode 100644
index 00000000..615fb529
--- /dev/null
+++ b/tests/hog.urp
@@ -0,0 +1 @@
+hog
diff --git a/tests/hog.urs b/tests/hog.urs
new file mode 100644
index 00000000..38b757ea
--- /dev/null
+++ b/tests/hog.urs
@@ -0,0 +1 @@
+val main : int -> transaction page