Skip to content

Commit e44c874

Browse files
sa1sa1
committed
Add urweb benchmark
1 parent 16a9c52 commit e44c874

23 files changed

+1263
-0
lines changed

‎urweb/README.md

+20
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,20 @@
1+
# Setup
2+
3+
Install urweb
4+
```
5+
brew install urweb
6+
brew install libpqxx
7+
```
8+
9+
## Building
10+
```
11+
export C_INCLUDE_PATH="/usr/local/include/"
12+
urweb bench
13+
```
14+
15+
## Running
16+
```
17+
./bench.exe -q -k -t 8
18+
```
19+
20+
It will run on port 8080

‎urweb/bench.ur

+30
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,30 @@
1+
open Json
2+
3+
fun returnJson [a] (_ : json a) (j : a) : transaction page =
4+
returnBlob (textBlob (toJson j)) (blessMime "application/json")
5+
6+
fun returnText (t : string) : transaction page =
7+
returnBlob (textBlob t) (blessMime "text/plain")
8+
9+
table fortunes : {Id : int, Message : string} PRIMARY KEY Id
10+
11+
fun fortuneshtml () =
12+
fs <- queryL1 (SELECT Fortunes.Id, Fortunes.Message FROM fortunes);
13+
return <xml>
14+
<head><title>Fortunes</title></head>
15+
<body><table>
16+
{List.mapX (fn f => <xml><tr>
17+
<td>{[f.Id]}</td><td>{[f.Message]}</td>
18+
</tr></xml>) fs}
19+
</table></body>
20+
</xml>
21+
22+
type json_t = {Id: int, Message : string}
23+
val json_conversion : json json_t = json_record {Id = "id", Message = "message"}
24+
25+
fun fortunesjson () =
26+
fs <- queryL1 (SELECT Fortunes.Id, Fortunes.Message FROM fortunes);
27+
returnJson fs
28+
29+
fun hello () =
30+
returnText "Hello, World!"

‎urweb/bench.urp

+10
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
library meta
2+
database dbname=server_benchmarks user=postgres host=localhost
3+
rewrite all Bench/*
4+
allow mime application/json
5+
allow mime text/plain
6+
noMangleSql
7+
html5
8+
9+
$/list
10+
bench

‎urweb/bench.urs

+3
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
val fortuneshtml : unit -> transaction page
2+
val fortunesjson : unit -> transaction page
3+
val hello : unit -> transaction page

‎urweb/meta/LICENSE

+25
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,25 @@
1+
Copyright (c) 2009-2010, Adam Chlipala
2+
All rights reserved.
3+
4+
Redistribution and use in source and binary forms, with or without
5+
modification, are permitted provided that the following conditions are met:
6+
7+
- Redistributions of source code must retain the above copyright notice,
8+
this list of conditions and the following disclaimer.
9+
- Redistributions in binary form must reproduce the above copyright notice,
10+
this list of conditions and the following disclaimer in the documentation
11+
and/or other materials provided with the distribution.
12+
- The names of contributors may not be used to endorse or promote products
13+
derived from this software without specific prior written permission.
14+
15+
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
16+
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
17+
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
18+
ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
19+
LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20+
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
21+
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
22+
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
23+
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
24+
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25+
POSSIBILITY OF SUCH DAMAGE.

‎urweb/meta/eq.ur

+76
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,76 @@
1+
con eq = K ==> fn (t1 :: K) (t2 :: K) => f :: (K -> Type) -> f t1 -> f t2
2+
3+
val refl [K] [t ::: K] : eq t t = fn [f :: (K -> Type)] x => x
4+
5+
fun sym [K] [t1 ::: K] [t2 ::: K] (e : eq t1 t2) : eq t2 t1 =
6+
e [fn t => eq t t1] refl
7+
8+
fun trans [K] [t1 ::: K] [t2 ::: K] [t3 ::: K] (e1 : eq t1 t2) (e2 : eq t2 t3) : eq t1 t3 =
9+
(sym e1) [fn t => eq t t3] e2
10+
11+
fun cast [K] [t1 ::: K] [t2 ::: K] (e : eq t1 t2) = e
12+
13+
fun fold [K] [tf :: {K} -> Type] [r ::: {K}]
14+
(f : pre :: {K} -> nm :: Name -> v :: K -> post :: {K} -> [pre ~ post] => [[nm] ~ pre ++ post] =>
15+
eq r (pre ++ [nm = v] ++ post) -> tf post -> tf ([nm = v] ++ post))
16+
(i : tf []) (fl : folder r) : tf r =
17+
@@Top.fold [fn post => pre :: {K} -> [pre ~ post] => eq r (pre ++ post) -> tf post]
18+
(fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest]
19+
(acc : pre :: {K} -> [pre ~ rest] => eq r (pre ++ rest) -> tf rest)
20+
[pre :: {K}] [pre ~ [nm = t] ++ rest] pf =>
21+
f [pre] [nm] [t] [rest] pf (acc [[nm = t] ++ pre] pf))
22+
(fn [pre :: {K}] [pre ~ []] _ => i) [r] fl [[]] ! refl
23+
24+
fun foldUR [tr :: Type] [tf :: {Unit} -> Type] [r ::: {Unit}]
25+
(f : pre :: {Unit} -> nm :: Name -> post :: {Unit} -> [pre ~ post] => [[nm] ~ pre ++ post] =>
26+
eq r (pre ++ [nm] ++ post) -> tr -> tf post -> tf ([nm] ++ post))
27+
(i : tf []) (fl : folder r) (r : $(mapU tr r)) : tf r =
28+
@@fold [fn r' => $(mapU tr r') -> tf r'] [r]
29+
(fn [pre :: {Unit}] [nm :: Name] [u :: Unit] [post :: {Unit}] [pre ~ post] [[nm] ~ pre ++ post] pf acc r =>
30+
f [pre] [nm] [post] pf r.nm (acc (r -- nm)))
31+
(fn _ => i) fl r
32+
33+
fun foldR [K] [tr :: K -> Type] [tf :: {K} -> Type] [r ::: {K}]
34+
(f : pre :: {K} -> nm :: Name -> t :: K -> post :: {K} -> [pre ~ post] => [[nm] ~ pre ++ post] =>
35+
eq r (pre ++ [nm = t] ++ post) -> tr t -> tf post -> tf ([nm = t] ++ post))
36+
(i : tf []) (fl : folder r) (r : $(map tr r)) : tf r =
37+
@@fold [fn r' => $(map tr r') -> tf r'] [r]
38+
(fn [pre :: {K}] [nm :: Name] [t :: K] [post :: {K}] [pre ~ post] [[nm] ~ pre ++ post] pf acc r =>
39+
f [pre] [nm] [t] [post] pf r.nm (acc (r -- nm)))
40+
(fn _ => i) fl r
41+
42+
fun foldR2 [K] [tr1 :: K -> Type] [tr2 :: K -> Type] [tf :: {K} -> Type] [r ::: {K}]
43+
(f : pre :: {K} -> nm :: Name -> t :: K -> post :: {K} -> [pre ~ post] => [[nm] ~ pre ++ post] =>
44+
eq r (pre ++ [nm = t] ++ post) -> tr1 t -> tr2 t -> tf post -> tf ([nm = t] ++ post))
45+
(i : tf []) (fl : folder r) (r1 : $(map tr1 r)) (r2 : $(map tr2 r)) : tf r =
46+
@@fold [fn r' => $(map tr1 r') -> $(map tr2 r') -> tf r'] [r]
47+
(fn [pre :: {K}] [nm :: Name] [t :: K] [post :: {K}] [pre ~ post] [[nm] ~ pre ++ post] pf acc r1 r2 =>
48+
f [pre] [nm] [t] [post] pf r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
49+
(fn _ _ => i) fl r1 r2
50+
51+
fun foldR3 [K] [tr1 :: K -> Type] [tr2 :: K -> Type] [tr3 :: K -> Type] [tf :: {K} -> Type] [r ::: {K}]
52+
(f : pre :: {K} -> nm :: Name -> t :: K -> post :: {K} -> [pre ~ post] => [[nm] ~ pre ++ post] =>
53+
eq r (pre ++ [nm = t] ++ post) -> tr1 t -> tr2 t -> tr3 t -> tf post -> tf ([nm = t] ++ post))
54+
(i : tf []) (fl : folder r) (r1 : $(map tr1 r)) (r2 : $(map tr2 r)) (r3 : $(map tr3 r)) : tf r =
55+
@@fold [fn r' => $(map tr1 r') -> $(map tr2 r') -> $(map tr3 r') -> tf r'] [r]
56+
(fn [pre :: {K}] [nm :: Name] [t :: K] [post :: {K}] [pre ~ post] [[nm] ~ pre ++ post] pf acc r1 r2 r3 =>
57+
f [pre] [nm] [t] [post] pf r1.nm r2.nm r3.nm (acc (r1 -- nm) (r2 -- nm) (r3 -- nm)))
58+
(fn _ _ _ => i) fl r1 r2 r3
59+
60+
fun foldR4 [K] [tr1 :: K -> Type] [tr2 :: K -> Type] [tr3 :: K -> Type] [tr4 :: K -> Type] [tf :: {K} -> Type] [r ::: {K}]
61+
(f : pre :: {K} -> nm :: Name -> t :: K -> post :: {K} -> [pre ~ post] => [[nm] ~ pre ++ post] =>
62+
eq r (pre ++ [nm = t] ++ post) -> tr1 t -> tr2 t -> tr3 t -> tr4 t -> tf post -> tf ([nm = t] ++ post))
63+
(i : tf []) (fl : folder r) (r1 : $(map tr1 r)) (r2 : $(map tr2 r)) (r3 : $(map tr3 r)) (r4 : $(map tr4 r)) : tf r =
64+
@@fold [fn r' => $(map tr1 r') -> $(map tr2 r') -> $(map tr3 r') -> $(map tr4 r') -> tf r'] [r]
65+
(fn [pre :: {K}] [nm :: Name] [t :: K] [post :: {K}] [pre ~ post] [[nm] ~ pre ++ post] pf acc r1 r2 r3 r4 =>
66+
f [pre] [nm] [t] [post] pf r1.nm r2.nm r3.nm r4.nm (acc (r1 -- nm) (r2 -- nm) (r3 -- nm) (r4 -- nm)))
67+
(fn _ _ _ _ => i) fl r1 r2 r3 r4
68+
69+
fun mp [K] [tr :: K -> Type] [tf :: K -> Type] [r ::: {K}]
70+
(f : nm :: Name -> t :: K -> rest :: {K} -> [[nm] ~ rest] =>
71+
eq r ([nm = t] ++ rest) -> tr t -> tf t)
72+
(fl : folder r) (r : $(map tr r)) : $(map tf r) =
73+
@@foldR [tr] [fn r => $(map tf r)] [r]
74+
(fn [pre :: {K}] [nm :: Name] [t :: K] [post :: {K}] [pre ~ post] [[nm] ~ pre ++ post] pf r acc =>
75+
{nm = f [nm] [t] [pre ++ post] pf r} ++ acc)
76+
{} fl r

‎urweb/meta/eq.urs

+44
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,44 @@
1+
(** A constructor equality predicate *)
2+
3+
con eq :: K --> K -> K -> Type
4+
5+
val refl : K --> t ::: K -> eq t t
6+
val sym : K --> t1 ::: K -> t2 ::: K -> eq t1 t2 -> eq t2 t1
7+
val trans : K --> t1 ::: K -> t2 ::: K -> t3 ::: K -> eq t1 t2 -> eq t2 t3 -> eq t1 t3
8+
9+
val cast : K --> t1 ::: K -> t2 ::: K -> eq t1 t2 -> f :: (K -> Type) -> f t1 -> f t2
10+
11+
val fold : K --> tf :: ({K} -> Type) -> r ::: {K}
12+
-> (pre :: {K} -> nm :: Name -> v :: K -> post :: {K} -> [pre ~ post] => [[nm] ~ pre ++ post] =>
13+
eq r (pre ++ [nm = v] ++ post) -> tf post -> tf ([nm = v] ++ post))
14+
-> tf [] -> folder r -> tf r
15+
16+
val foldUR : tr :: Type -> tf :: ({Unit} -> Type) -> r ::: {Unit}
17+
-> (pre :: {Unit} -> nm :: Name -> post :: {Unit} -> [pre ~ post] => [[nm] ~ pre ++ post] =>
18+
eq r (pre ++ [nm] ++ post) -> tr -> tf post -> tf ([nm] ++ post))
19+
-> tf [] -> folder r -> $(mapU tr r) -> tf r
20+
21+
val foldR : K --> tr :: (K -> Type) -> tf :: ({K} -> Type) -> r ::: {K}
22+
-> (pre :: {K} -> nm :: Name -> t :: K -> post :: {K} -> [pre ~ post] => [[nm] ~ pre ++ post] =>
23+
eq r (pre ++ [nm = t] ++ post) -> tr t -> tf post -> tf ([nm = t] ++ post))
24+
-> tf [] -> folder r -> $(map tr r) -> tf r
25+
26+
val foldR2 : K --> tr1 :: (K -> Type) -> tr2 :: (K -> Type) -> tf :: ({K} -> Type) -> r ::: {K}
27+
-> (pre :: {K} -> nm :: Name -> t :: K -> post :: {K} -> [pre ~ post] => [[nm] ~ pre ++ post] =>
28+
eq r (pre ++ [nm = t] ++ post) -> tr1 t -> tr2 t -> tf post -> tf ([nm = t] ++ post))
29+
-> tf [] -> folder r -> $(map tr1 r) -> $(map tr2 r) -> tf r
30+
31+
val foldR3 : K --> tr1 :: (K -> Type) -> tr2 :: (K -> Type) -> tr3 :: (K -> Type) -> tf :: ({K} -> Type) -> r ::: {K}
32+
-> (pre :: {K} -> nm :: Name -> t :: K -> post :: {K} -> [pre ~ post] => [[nm] ~ pre ++ post] =>
33+
eq r (pre ++ [nm = t] ++ post) -> tr1 t -> tr2 t -> tr3 t -> tf post -> tf ([nm = t] ++ post))
34+
-> tf [] -> folder r -> $(map tr1 r) -> $(map tr2 r) -> $(map tr3 r) -> tf r
35+
36+
val foldR4 : K --> tr1 :: (K -> Type) -> tr2 :: (K -> Type) -> tr3 :: (K -> Type) -> tr4 :: (K -> Type) -> tf :: ({K} -> Type) -> r ::: {K}
37+
-> (pre :: {K} -> nm :: Name -> t :: K -> post :: {K} -> [pre ~ post] => [[nm] ~ pre ++ post] =>
38+
eq r (pre ++ [nm = t] ++ post) -> tr1 t -> tr2 t -> tr3 t -> tr4 t -> tf post -> tf ([nm = t] ++ post))
39+
-> tf [] -> folder r -> $(map tr1 r) -> $(map tr2 r) -> $(map tr3 r) -> $(map tr4 r) -> tf r
40+
41+
val mp : K --> tr :: (K -> Type) -> tf :: (K -> Type) -> r ::: {K}
42+
-> (nm :: Name -> t :: K -> rest :: {K} -> [[nm] ~ rest] =>
43+
eq r ([nm = t] ++ rest) -> tr t -> tf t)
44+
-> folder r -> $(map tr r) -> $(map tf r)

‎urweb/meta/html.ur

+144
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,144 @@
1+
open Parse
2+
3+
con attribute = fn t => {Nam : string,
4+
Parse : string -> option t}
5+
6+
con tag = fn ts => {Nam : string,
7+
Attributes : $(map attribute ts),
8+
Folder : folder ts,
9+
Construct : ctx ::: {Unit} -> [[Body] ~ ctx] => $ts
10+
-> xml ([Body] ++ ctx) [] [] -> xml ([Body] ++ ctx) [] []}
11+
12+
fun tag [use] [ignore] [use ~ ignore] (fl : folder use) (name : string) (attrs : $(map attribute use))
13+
(construct : ctx ::: {Unit} -> [[Body] ~ ctx] => Basis.tag (use ++ ignore) ([Body] ++ ctx) ([Body] ++ ctx) [] []) =
14+
{Nam = name,
15+
Attributes = attrs,
16+
Folder = fl,
17+
Construct = fn [ctx] [[Body] ~ ctx] (ats : $use) (inner : xml ([Body] ++ ctx) [] []) =>
18+
Basis.tag null None noStyle None ats construct inner}
19+
20+
fun simpleTag [ignore] name (bt : bodyTag ignore) : tag [] =
21+
@@tag [[]] [ignore] ! _ name {} (fn [ctx] [[Body] ~ ctx] => bt ())
22+
23+
fun simpleTag' [use] [ignore] [use ~ ignore] (fl : folder use)
24+
name (bt : bodyTag (use ++ ignore)) (ats : $(map attribute use)) : tag use =
25+
@@tag [use] [ignore] ! fl name ats (fn [ctx] [[Body] ~ ctx] => bt ())
26+
27+
fun url name = {Nam = name,
28+
Parse = checkUrl}
29+
30+
datatype error a =
31+
Good of a
32+
| Bad of string
33+
34+
fun format [tags] (fl : folder tags) (tags : $(map tag tags)) [ctx] [[Body] ~ ctx] s =
35+
let
36+
fun loop s : error (xml ([Body] ++ ctx) [] [] * string) =
37+
case String.msplit {Haystack = s, Needle = "&<"} of
38+
None => Good (cdata s, "")
39+
| Some (pre, ch, post) =>
40+
case ch of
41+
#"&" =>
42+
(case String.split post #";" of
43+
None => Bad "No ';' after '&'"
44+
| Some (code, post) =>
45+
let
46+
val xml =
47+
case code of
48+
"lt" => <xml>&lt;</xml>
49+
| "gt" => <xml>&gt;</xml>
50+
| "amp" => <xml>&amp;</xml>
51+
| _ => <xml/>
52+
in
53+
case loop post of
54+
Good (after, post) => Good (<xml>{[pre]}{xml}{after}</xml>, post)
55+
| x => x
56+
end)
57+
| _ =>
58+
if String.length post > 0 && String.sub post 0 = #"/" then
59+
case String.split post #"\x3E" of
60+
None => Bad "No '>' after '</'"
61+
| Some (_, post) => Good (<xml>{[pre]}</xml>, post)
62+
else
63+
case String.msplit {Haystack = post, Needle = " >"} of
64+
None => Bad "No '>' after '<'"
65+
| Some (tname, ch, post) =>
66+
@foldR [tag] [fn _ => unit -> error (xml ([Body] ++ ctx) [] [] * string)]
67+
(fn [nm :: Name] [ts :: {Type}] [r :: {{Type}}] [[nm] ~ r] (meta : tag ts) acc () =>
68+
if meta.Nam = tname then
69+
let
70+
fun doAttrs (ch, post, ats : $(map option ts)) =
71+
if String.length post > 0 && Char.isSpace (String.sub post 0) then
72+
doAttrs (ch, String.substring post {Start = 1,
73+
Len = String.length post - 1},
74+
ats)
75+
else
76+
case ch of
77+
#"\x3E" => Good (ats, post)
78+
| _ =>
79+
case String.split post #"=" of
80+
None =>
81+
(case String.split post #"\x3E" of
82+
None => Bad "No tag ender '\x3E'"
83+
| Some (_, post) => Good (ats, post))
84+
| Some (aname, post) =>
85+
if String.length post >= 1 && String.sub post 0 = #"\"" then
86+
case String.split (String.substring post
87+
{Start = 1,
88+
Len = String.length post
89+
- 1})
90+
#"\"" of
91+
None => Bad "No '\"' to end attribute value"
92+
| Some (aval, post) =>
93+
let
94+
val ats =
95+
@map2 [attribute] [option] [option]
96+
(fn [t] meta v =>
97+
if aname = meta.Nam then
98+
meta.Parse aval
99+
else
100+
v)
101+
meta.Folder meta.Attributes ats
102+
in
103+
doAttrs (#" ", post, ats)
104+
end
105+
else
106+
Bad "Attribute value doesn't begin with quote"
107+
in
108+
case doAttrs (ch, post, @map0 [option] (fn [t :: Type] => None)
109+
meta.Folder) of
110+
Good (ats, post) =>
111+
let
112+
val ats =
113+
@map2 [attribute] [option] [ident]
114+
(fn [t] meta v =>
115+
case v of
116+
None => error <xml>Missing attribute {[meta.Nam]}
117+
for {[tname]}</xml>
118+
| Some v => v)
119+
meta.Folder meta.Attributes ats
120+
in
121+
case loop post of
122+
Good (inner, post) =>
123+
(case loop post of
124+
Good (after, post) =>
125+
Good (<xml>{[pre]}{meta.Construct [ctx] !
126+
ats inner}{after}</xml>, post)
127+
| x => x)
128+
| x => x
129+
end
130+
| Bad s => Bad s
131+
end
132+
else
133+
acc ())
134+
(fn () => Bad ("Unknown HTML tag " ^ tname)) fl tags ()
135+
in
136+
case loop s of
137+
Bad msg => Failure msg
138+
| Good (xml, _) => Success xml
139+
end
140+
141+
val b = simpleTag "b" @@b
142+
val i = simpleTag "i" @@i
143+
val a = simpleTag' "a" @@a {Href = url "href"}
144+

0 commit comments

Comments
 (0)