11 years ago · 8b417b2bdc
--- a/UrWeb/bench.exe
+++ b/UrWeb/bench.exe
--- a/UrWeb/bench.ur
+++ b/UrWeb/bench.ur
@@ -1,81 +0,0 @@
 
				-open Json
			
 
				-
			
 
				-fun addHeaders () =
			
 
				-  n <- now;
			
 
				-  setHeader (blessResponseHeader "Date") (timef "%a, %d %b %Y %H:%M:%S GMT" n);
			
 
				-  setHeader (blessResponseHeader "Server") "Ur/Web"
			
 
				-fun clamp n =
			
 
				-  (n % 10000) + 1
			
 
				-fun parseQueries oqs : int =
			
 
				-  let
			
 
				-    val qt = case oqs of
			
 
				-        None => Some ("queries", "1")
			
 
				-      | Some qs => String.split (show qs) #"="
			
 
				-    val on = case qt of
			
 
				-        Some ("queries", x) => read x
			
 
				-      | _ => Some 1
			
 
				-  in
			
 
				-    case on of
			
 
				-      None => 1
			
 
				-    | Some x => if x > 500 then 500
			
 
				-                else if x < 1 then 1
			
 
				-                else x
			
 
				-  end
			
 
				-fun returnJson [a] (_ : json a) (j : a) : transaction page =
			
 
				-  addHeaders ();
			
 
				-  returnBlob (textBlob (toJson j)) (blessMime "application/json")
			
 
				-fun returnText (t : string) : transaction page =
			
 
				-  addHeaders ();
			
 
				-  returnBlob (textBlob t) (blessMime "text/plain")
			
 
				-
			
 
				-val hello = "Hello, World!"
			
 
				-fun plaintext () =
			
 
				-  returnText hello
			
 
				-
			
 
				-type json_t = {Message : string}
			
 
				-val json_conversion : json json_t = json_record {Message = "message"}
			
 
				-val hello_json = {Message = hello}
			
 
				-fun json () =
			
 
				-    returnJson hello_json
			
 
				-
			
 
				-table world : {Id : int, RandomNumber : int} PRIMARY KEY Id
			
 
				-type world_t = {Id : int, RandomNumber : int}
			
 
				-val world_conversion : json world_t = json_record {Id = "id", RandomNumber = "randomNumber"}
			
 
				-fun world_find n =
			
 
				-  oneRow1 (SELECT World.Id, World.RandomNumber FROM world WHERE World.Id = {[n]})
			
 
				-
			
 
				-fun db () =
			
 
				-  n <- rand;
			
 
				-  row <- world_find (clamp n);
			
 
				-  returnJson row
			
 
				-
			
 
				-fun queries oqs =
			
 
				-  rows <- List.tabulateM (fn _ => n <- rand; world_find (clamp n)) (parseQueries oqs);
			
 
				-  returnJson rows
			
 
				-
			
 
				-fun updates oqs =
			
 
				-  rows <- List.tabulateM (fn _ => n <- rand; world_find (clamp n)) (parseQueries oqs);
			
 
				-  rows' <- List.mapM (fn r => n <- rand; return (r -- #RandomNumber ++ {RandomNumber = clamp n})) rows;
			
 
				-  List.app (fn r => dml (UPDATE world SET RandomNumber = {[r.RandomNumber]} WHERE Id = {[r.Id]})) rows';
			
 
				-  returnJson rows'
			
 
				-
			
 
				-table fortune : {Id : int, Message : string} PRIMARY KEY Id
			
 
				-type fortune_t = {Id : int, Message : string}
			
 
				-val fortune_conversion : json fortune_t = json_record {Id = "id", Message = "message"}
			
 
				-val new_fortune : fortune_t = {Id = 0, Message = "Additional fortune added at request time"}
			
 
				-fun fortunes () =
			
 
				-  fs <- queryL1 (SELECT Fortune.Id, Fortune.Message FROM fortune);
			
 
				-  let
			
 
				-    val fs' = List.sort (fn x y => x.Message > y.Message ) (new_fortune :: fs)
			
 
				-  in
			
 
				-    addHeaders ();
			
 
				-    return <xml>
			
 
				-             <head><title>Fortunes</title></head>
			
 
				-             <body><table>
			
 
				-               <tr><th>id</th><th>message</th></tr>
			
 
				-               {List.mapX (fn f => <xml><tr>
			
 
				-                 <td>{[f.Id]}</td><td>{[f.Message]}</td>
			
 
				-               </tr></xml>) fs'}
			
 
				-             </table></body>
			
 
				-           </xml>
			
 
				-  end
			
--- a/UrWeb/source_code
+++ b/UrWeb/source_code
@@ -1 +0,0 @@
 
				-./UrWeb/bench.ur
			
--- a/config/postgresql.conf
+++ b/config/postgresql.conf
@@ -517,7 +517,7 @@ default_text_search_config = 'pg_catalog.english'
 
				 # Note:  Each lock table slot uses ~270 bytes of shared memory, and there are
			
 
				 # max_locks_per_transaction * (max_connections + max_prepared_transactions)
			
 
				 # lock table slots.
			
 
				-#max_pred_locks_per_transaction = 64	# min 10
			
 
				+max_pred_locks_per_transaction = 256	# min 10
			
 
				 					# (change requires restart)
			
 
				 
			
 
				 #------------------------------------------------------------------------------
			
--- a/toolset/setup/linux/installer.py
+++ b/toolset/setup/linux/installer.py
@@ -200,7 +200,7 @@ class Installer:
 
				 
			
 
				     #
			
 
				     # Ur/Web
			
 
				-    #
			
 
				+    # Min version: ac1be85e91ad --- HTML5 directive
			
 
				 
			
 
				     self.__run_command("hg clone http://hg.impredicative.com/urweb/")
			
 
				     self.__run_command("./autogen.sh", cwd="urweb")
			
--- a/urweb/README.md
+++ b/urweb/README.md
--- a/urweb/__init__.py
+++ b/urweb/__init__.py
--- a/urweb/bench.exe
+++ b/urweb/bench.exe
--- a/urweb/bench.ur
+++ b/urweb/bench.ur
@@ -0,0 +1,150 @@
 
				+(** An Ur/Web solution to the TechEmpower web framework benchmarks.
			
 
				+  * For more information:
			
 
				+  * Benchmark specs: http://www.techempower.com/benchmarks/#section=code
			
 
				+  * Ur/Web: http://www.impredicative.com/ur/
			
 
				+  *)
			
 
				+
			
 
				+open Json
			
 
				+
			
 
				+
			
 
				+(** * Utility functions *)
			
 
				+
			
 
				+(** The spec requires including particular HTTP response headers that the
			
 
				+  * minimal Ur/Web HTTP servers don't return, so this function is responsible
			
 
				+  * for adding them. *)
			
 
				+fun addHeaders () =
			
 
				+  n <- now;
			
 
				+  setHeader (blessResponseHeader "Date") (timef "%a, %d %b %Y %H:%M:%S GMT" n);
			
 
				+  setHeader (blessResponseHeader "Server") "Ur/Web"
			
 
				+
			
 
				+(** This function handles processing of a "queries" query string parameter to a
			
 
				+  * few of the benchmarks.  The URL representation is mandated by the spec, so
			
 
				+  * we don't get to use Ur/Web's standard handling of parameters.  Instead,
			
 
				+  * there's some manual parsing. :-( *)
			
 
				+fun parseQueries oqs : int =
			
 
				+  let
			
 
				+    val qt = case oqs of
			
 
				+        None => Some ("queries", "1")
			
 
				+      | Some qs => String.split (show qs) #"="
			
 
				+    val on = case qt of
			
 
				+        Some ("queries", x) => read x
			
 
				+      | _ => Some 1
			
 
				+  in
			
 
				+    case on of
			
 
				+      None => 1
			
 
				+    | Some x => if x > 500 then 500
			
 
				+                else if x < 1 then 1
			
 
				+                else x
			
 
				+  end
			
 
				+
			
 
				+(** Most of the benchmarks return results as JSON.
			
 
				+  * Here's a handy function to automate wrapping an arbitrary JSONable value as
			
 
				+  * a response. *)
			
 
				+fun returnJson [a] (_ : json a) (j : a) : transaction page =
			
 
				+  addHeaders ();
			
 
				+  returnBlob (textBlob (toJson j)) (blessMime "application/json")
			
 
				+
			
 
				+(** Here's a similar, simpler function for returning plain text. *)
			
 
				+fun returnText (t : string) : transaction page =
			
 
				+  addHeaders ();
			
 
				+  returnBlob (textBlob t) (blessMime "text/plain")
			
 
				+
			
 
				+(** Finally, an analogous wrapper for HTML *)
			
 
				+fun returnHtml (p : page) : transaction page =
			
 
				+  addHeaders ();
			
 
				+  return p
			
 
				+
			
 
				+
			
 
				+(** * Test type 1: JSON serialization *)
			
 
				+
			
 
				+(** Let's teach the JSON library about a new record type. *)
			
 
				+type json_t = {Message : string}
			
 
				+val json_conversion : json json_t = json_record {Message = "message"}
			
 
				+
			
 
				+fun json () =
			
 
				+    returnJson {Message = "Hello, World!"}
			
 
				+
			
 
				+
			
 
				+(** * Test type 2: Single database query *)
			
 
				+
			
 
				+(** This test introduces a database table that a few other tests also use. *)
			
 
				+table world : {Id : int, RandomNumber : int} PRIMARY KEY Id
			
 
				+
			
 
				+(** Let's tell the JSON library which record field names to use in
			
 
				+  * serialization. *)
			
 
				+type world_t = {Id : int, RandomNumber : int}
			
 
				+val world_conversion : json world_t =
			
 
				+    json_record {Id = "id", RandomNumber = "randomNumber"}
			
 
				+
			
 
				+(** Helper function to look up the entry associated with an ID *)
			
 
				+fun world_find n =
			
 
				+  oneRow1 (SELECT World.Id, World.RandomNumber FROM world
			
 
				+           WHERE World.Id = {[n]})
			
 
				+
			
 
				+(** In various tests, we'll be generating random IDs for this table.
			
 
				+  * Here's a quick way to do it, limiting the legal ID range. *)
			
 
				+val random_id =
			
 
				+  n <- rand;
			
 
				+  return ((n % 10000) + 1)
			
 
				+
			
 
				+(** Finally, test 2 itself! *)
			
 
				+fun db () =
			
 
				+  n <- random_id;
			
 
				+  row <- world_find n;
			
 
				+  returnJson row
			
 
				+
			
 
				+
			
 
				+(** * Test type 3: Multiple database queries *)
			
 
				+
			
 
				+fun queries oqs =
			
 
				+  rows <- List.tabulateM (fn _ => n <- random_id; world_find n) (parseQueries oqs);
			
 
				+  returnJson rows
			
 
				+
			
 
				+
			
 
				+(** * Test type 4: Fortunes *)
			
 
				+
			
 
				+(** A new table, specific to this test *)
			
 
				+table fortune : {Id : int, Message : string} PRIMARY KEY Id
			
 
				+
			
 
				+(** Teach the JSON library about good string names for the columns. *)
			
 
				+type fortune_t = {Id : int, Message : string}
			
 
				+val fortune_conversion : json fortune_t =
			
 
				+    json_record {Id = "id", Message = "message"}
			
 
				+
			
 
				+(** Here's the additional fortune mandated by the spec. *)
			
 
				+val new_fortune : fortune_t =
			
 
				+    {Id = 0, Message = "Additional fortune added at request time"}
			
 
				+
			
 
				+(** Actual page handler *)
			
 
				+fun fortunes () =
			
 
				+  fs <- queryL1 (SELECT Fortune.Id, Fortune.Message FROM fortune);
			
 
				+  fs' <- return (List.sort (fn x y => x.Message > y.Message)
			
 
				+                           (new_fortune :: fs));
			
 
				+  returnHtml <xml>
			
 
				+    <head><title>Fortunes</title></head>
			
 
				+    <body><table>
			
 
				+      <tr><th>id</th><th>message</th></tr>
			
 
				+      {List.mapX (fn f => <xml><tr>
			
 
				+        <td>{[f.Id]}</td><td>{[f.Message]}</td>
			
 
				+      </tr></xml>) fs'}
			
 
				+    </table></body>
			
 
				+  </xml>
			
 
				+
			
 
				+
			
 
				+(** * Test type 5: Database updates *)
			
 
				+
			
 
				+fun updates oqs =
			
 
				+  rows <- List.tabulateM (fn _ => n <- random_id; world_find n)
			
 
				+                         (parseQueries oqs);
			
 
				+  rows' <- List.mapM (fn r => n <- random_id;
			
 
				+                         return (r -- #RandomNumber ++ {RandomNumber = n}))
			
 
				+                     rows;
			
 
				+  List.app (fn r => dml (UPDATE world SET RandomNumber = {[r.RandomNumber]}
			
 
				+                         WHERE Id = {[r.Id]})) rows';
			
 
				+  returnJson rows'
			
 
				+
			
 
				+
			
 
				+(** * Test type 6: Plaintext *)
			
 
				+
			
 
				+fun plaintext () =
			
 
				+  returnText "Hello, World!"
			
--- a/urweb/bench.urp
+++ b/urweb/bench.urp
@@ -1,6 +1,5 @@
 
				 library meta
			
 
				 database dbname=hello_world user=benchmarkdbuser password=benchmarkdbpass host=localhost
			
 
				-minHeap 16384
			
 
				 rewrite url Bench/*
			
 
				 allow responseHeader Date
			
 
				 allow responseHeader Server
			
@@ -10,4 +9,4 @@ safeGet updates
 
				 
			
 
				 $/list
			
 
				 $/string
			
 
				-bench
			
 
				+bench
			
--- a/urweb/bench.urs
+++ b/urweb/bench.urs
--- a/urweb/benchmark_config
+++ b/urweb/benchmark_config
--- a/urweb/create-postgres.sql
+++ b/urweb/create-postgres.sql
--- a/urweb/fortune.sql
+++ b/urweb/fortune.sql
--- a/urweb/meta/LICENSE
+++ b/urweb/meta/LICENSE
--- a/urweb/meta/eq.ur
+++ b/urweb/meta/eq.ur
--- a/urweb/meta/eq.urs
+++ b/urweb/meta/eq.urs
--- a/urweb/meta/html.ur
+++ b/urweb/meta/html.ur
--- a/urweb/meta/html.urs
+++ b/urweb/meta/html.urs
--- a/urweb/meta/incl.ur
+++ b/urweb/meta/incl.ur
--- a/urweb/meta/incl.urs
+++ b/urweb/meta/incl.urs
--- a/urweb/meta/json.ur
+++ b/urweb/meta/json.ur
--- a/urweb/meta/json.urs
+++ b/urweb/meta/json.urs
--- a/urweb/meta/lib.urp
+++ b/urweb/meta/lib.urp
--- a/urweb/meta/mem.ur
+++ b/urweb/meta/mem.ur
--- a/urweb/meta/mem.urs
+++ b/urweb/meta/mem.urs
--- a/urweb/meta/parse.ur
+++ b/urweb/meta/parse.ur
--- a/urweb/meta/record.ur
+++ b/urweb/meta/record.ur
--- a/urweb/meta/record.urs
+++ b/urweb/meta/record.urs
--- a/urweb/meta/sql.ur
+++ b/urweb/meta/sql.ur
--- a/urweb/meta/sql.urs
+++ b/urweb/meta/sql.urs
--- a/urweb/meta/variant.ur
+++ b/urweb/meta/variant.ur
--- a/urweb/meta/variant.urs
+++ b/urweb/meta/variant.urs
--- a/urweb/setup.py
+++ b/urweb/setup.py
@@ -2,7 +2,7 @@ import subprocess
 
				 import os
			
 
				 
			
 
				 def start(args, logfile, errfile):
			
 
				-  subprocess.check_call("urweb bench", shell=True, cwd="UrWeb", stderr=errfile, stdout=logfile)
			
 
				+  subprocess.check_call("urweb bench", shell=True, cwd="urweb", stderr=errfile, stdout=logfile)
			
 
				 
			
 
				   threads = str(args.max_threads)
			
 
				   conn_string = ('dbname=hello_world '
			
@@ -10,8 +10,8 @@ def start(args, logfile, errfile):
 
				                 'password=benchmarkdbpass '
			
 
				                 'host=' + args.database_host)
			
 
				   env = {'URWEB_PQ_CON': conn_string}
			
 
				-  subprocess.Popen("./bench.exe -k -t " + threads,
			
 
				-                   env=env, shell=True, cwd="UrWeb", stderr=errfile, stdout=logfile)
			
 
				+  subprocess.Popen("./bench.exe -q -k -t " + threads,
			
 
				+                   env=env, shell=True, cwd="urweb", stderr=errfile, stdout=logfile)
			
 
				   return 0
			
 
				 
			
 
				 def stop(logfile, errfile):
			
--- a/urweb/source_code
+++ b/urweb/source_code
@@ -0,0 +1,3 @@
 
				+./urweb/bench.ur
			
 
				+./urweb/bench.urs
			
 
				+./urweb/bench.urp
			
--- a/urweb/world.sql
+++ b/urweb/world.sql