compsci-industry
/
TechEmpower.FrameworkBenchmarks
cermin dari https://github.com/TechEmpower/FrameworkBenchmarks.git


			
							123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140
							(** 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" string parameter to a few of
  * the benchmarks.  The URL representation is mandated by the spec, so we need
  * to do some manual parsing to handle malformed inputs. :-( *)
fun parseQueries s =
    case read s of
        None => 1
      | Some n => if n > 500 then 500
                  else if n < 1 then 1
                  else n

(** 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 s =
  rows <- List.tabulateM (fn _ => n <- random_id; world_find n) (parseQueries s);
  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 s =
  rows <- List.tabulateM (fn _ => n <- random_id; world_find n)
                         (parseQueries s);
  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!"