summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-10-06 17:36:45 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-10-06 17:36:45 -0400
commitf0999e0e7b8ae0f3e0ac622d4d70e8a1da61f47e (patch)
treeb83f18305aa8814ca95cf3a7e6a8829f789d8380
parent82ed38468f5da48ce6e9f6ec336cf5b11ca4bb4d (diff)
Versioned1 demo working
-rw-r--r--demo/more/prose4
-rw-r--r--demo/more/versioned.ur60
-rw-r--r--demo/more/versioned.urs7
-rw-r--r--demo/more/versioned1.ur18
-rw-r--r--lib/ur/list.ur7
-rw-r--r--src/c/urweb.c15
-rw-r--r--src/cjr_print.sml17
-rw-r--r--src/mono_reduce.sml4
8 files changed, 83 insertions, 49 deletions
diff --git a/demo/more/prose b/demo/more/prose
index a2765778..9c267ca0 100644
--- a/demo/more/prose
+++ b/demo/more/prose
@@ -9,3 +9,7 @@ grid1.urp
orm1.urp
<p>Many varieties of "object-relational mapping" (ORM) can be implemented as libraries in Ur/Web, as this demo shows.</p>
+
+versioned1.urp
+
+<p>We can also build a data store abstraction that makes it possible to view old versions of records.</p>
diff --git a/demo/more/versioned.ur b/demo/more/versioned.ur
index cb93ef6c..bc9911e3 100644
--- a/demo/more/versioned.ur
+++ b/demo/more/versioned.ur
@@ -2,7 +2,7 @@ functor Make(M : sig
con key :: {Type}
con data :: {Type}
constraint key ~ data
- constraint [When] ~ (key ++ data)
+ constraint [When, Version] ~ (key ++ data)
val key : $(map sql_injectable key)
val data : $(map (fn t => {Inj : sql_injectable_prim t,
@@ -11,10 +11,14 @@ functor Make(M : sig
val keyFolder : folder key
val dataFolder : folder data
end) = struct
- con all = [When = time] ++ M.key ++ map option M.data
+ type version = int
+ con all = [When = time, Version = version] ++ M.key ++ map option M.data
+ sequence s
table t : all
val keys = List.mapQuery (SELECT DISTINCT t.{{M.key}} FROM t) (fn r => r.T)
+ fun keysAt vr = List.mapQuery (SELECT DISTINCT t.{{M.key}} FROM t
+ WHERE t.Version <= {[vr]}) (fn r => r.T)
con dmeta = fn t => {Inj : sql_injectable_prim t,
Eq : eq t}
@@ -24,14 +28,16 @@ functor Make(M : sig
(fn [t] => @sql_inject)
[_] M.keyFolder M.key (r --- M.data)
- fun insert r = dml (Basis.insert t
- ({When = (SQL CURRENT_TIMESTAMP)}
- ++ keyRecd r
- ++ map2 [dmeta] [id]
- [fn t => sql_exp [] [] [] (option t)]
- (fn [t] x v => @sql_inject (@sql_option_prim x.Inj)
- (Some v))
- [_] M.dataFolder M.data (r --- M.key)))
+ fun insert r =
+ vr <- nextval s;
+ dml (Basis.insert t
+ ({Version = (SQL {[vr]}), When = (SQL CURRENT_TIMESTAMP)}
+ ++ keyRecd r
+ ++ map2 [dmeta] [id]
+ [fn t => sql_exp [] [] [] (option t)]
+ (fn [t] x v => @sql_inject (@sql_option_prim x.Inj)
+ (Some v))
+ [_] M.dataFolder M.data (r --- M.key)))
fun keyExp (r : $M.key) : sql_exp [T = all] [] [] bool =
foldR2 [sql_injectable] [id] [fn before => after :: {Type} -> [before ~ after]
@@ -46,9 +52,14 @@ functor Make(M : sig
[_] M.keyFolder M.key r
[_] !
- fun current k =
+ datatype bound =
+ NoBound
+ | Lt of int
+ | Le of int
+
+ fun seek vro k =
let
- fun current' timeOpt r =
+ fun current' vro r =
let
val complete = foldR [option] [fn ts => option $ts]
(fn [nm :: Name] [v :: Type] [r :: {Type}] [[nm] ~ r]
@@ -62,11 +73,12 @@ functor Make(M : sig
Some r => return (Some r)
| None =>
let
- val filter = case timeOpt of
- None => (WHERE TRUE)
- | Some time => (WHERE t.When < {[time]})
+ val filter = case vro of
+ NoBound => (WHERE TRUE)
+ | Lt vr => (WHERE t.Version < {[vr]})
+ | Le vr => (WHERE t.Version <= {[vr]})
in
- ro <- oneOrNoRows (SELECT t.When, t.{{map option M.data}}
+ ro <- oneOrNoRows (SELECT t.Version, t.{{map option M.data}}
FROM t
WHERE {filter}
AND {keyExp k}
@@ -81,21 +93,25 @@ functor Make(M : sig
case old of
None => new
| Some _ => old)
- [_] M.dataFolder r (r'.T -- #When)
+ [_] M.dataFolder r (r'.T -- #Version)
in
- current' (Some r'.T.When) r
+ current' (Lt r'.T.Version) r
end
end
end
in
- current' None (map0 [option] (fn [t :: Type] => None : option t) [_] M.dataFolder)
+ current' vro (map0 [option] (fn [t :: Type] => None : option t) [_] M.dataFolder)
end
+ val current = seek NoBound
+ fun archive vr = seek (Le vr)
+
fun update r =
cur <- current (r --- M.data);
case cur of
None => error <xml>Tried to update nonexistent key</xml>
| Some cur =>
+ vr <- nextval s;
let
val r' = map3 [dmeta] [id] [id] [fn t => sql_exp [] [] [] (option t)]
(fn [t] (meta : dmeta t) old new =>
@@ -105,10 +121,14 @@ functor Make(M : sig
else
Some new))
[_] M.dataFolder M.data cur (r --- M.key)
- val r' = {When = (SQL CURRENT_TIMESTAMP)}
+ val r' = {Version = (SQL {[vr]}), When = (SQL CURRENT_TIMESTAMP)}
++ keyRecd r
++ r'
in
dml (Basis.insert t r')
end
+
+ val updateTimes = List.mapQuery (SELECT t.Version, t.When
+ FROM t
+ ORDER BY t.When) (fn r => (r.T.Version, r.T.When))
end
diff --git a/demo/more/versioned.urs b/demo/more/versioned.urs
index eb0a485e..47f2e524 100644
--- a/demo/more/versioned.urs
+++ b/demo/more/versioned.urs
@@ -2,7 +2,7 @@ functor Make(M : sig
con key :: {Type}
con data :: {Type}
constraint key ~ data
- constraint [When] ~ (key ++ data)
+ constraint [When, Version] ~ (key ++ data)
val key : $(map sql_injectable key)
val data : $(map (fn t => {Inj : sql_injectable_prim t,
@@ -16,4 +16,9 @@ functor Make(M : sig
val keys : transaction (list $M.key)
val current : $M.key -> transaction (option $M.data)
+
+ type version
+ val keysAt : version -> transaction (list $M.key)
+ val archive : version -> $M.key -> transaction (option $M.data)
+ val updateTimes : transaction (list (version * time))
end
diff --git a/demo/more/versioned1.ur b/demo/more/versioned1.ur
index 506d2778..592af3cf 100644
--- a/demo/more/versioned1.ur
+++ b/demo/more/versioned1.ur
@@ -9,6 +9,18 @@ open Versioned.Make(struct
Eq = _}}
end)
+fun retro vr =
+ ks <- keysAt vr;
+ ks <- List.mapM (fn r => fso <- archive vr r; return (r.Id, fso)) ks;
+
+ return <xml><body>
+ {List.mapX (fn (k, r) => <xml><li>
+ {[k]}: {case r of
+ None => <xml>Whoa!</xml>
+ | Some r => <xml>{[r.Nam]}, {[r.ShoeSize]}</xml>}
+ </li></xml>) ks}
+ </body></xml>
+
fun expandKey k =
name <- source "";
shoeSize <- source "";
@@ -23,6 +35,8 @@ fun main () =
name <- source "";
shoeSize <- source "";
+ times <- updateTimes;
+
return <xml><body>
<dyn signal={ks <- signal ks;
return (List.mapX (fn kr => <xml><div>
@@ -59,4 +73,8 @@ fun main () =
kr <- expandKey (readError id);
set ks (kr :: cur)}/></th></tr>
</table>
+
+ <h2>Archive</h2>
+
+ {List.mapX (fn (vr, tm) => <xml><li><a link={retro vr}>{[tm]}</a></li></xml>) times}
</body></xml>
diff --git a/lib/ur/list.ur b/lib/ur/list.ur
index 9e2550ca..58f9e23e 100644
--- a/lib/ur/list.ur
+++ b/lib/ur/list.ur
@@ -230,9 +230,10 @@ fun app [m] (_ : monad m) [a] f =
fun mapQuery [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type]
[tables ~ exps] (q : sql_query tables exps)
(f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> t) =
- query q
- (fn fs acc => return (f fs :: acc))
- []
+ ls <- query q
+ (fn fs acc => return (f fs :: acc))
+ [];
+ return (rev ls)
fun assoc [a] [b] (_ : eq a) (x : a) =
let
diff --git a/src/c/urweb.c b/src/c/urweb.c
index e49de568..d9ac4c5f 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -2160,6 +2160,7 @@ char *uw_Basis_sqlifyTime(uw_context ctx, uw_Basis_time t) {
if (localtime_r(&t, &stm)) {
s = uw_malloc(ctx, TIMES_MAX);
+ --stm.tm_hour;
len = strftime(s, TIMES_MAX, TIME_FMT, &stm);
r = uw_malloc(ctx, len + 14);
sprintf(r, "'%s'::timestamp", s);
@@ -2176,7 +2177,6 @@ char *uw_Basis_attrifyTime(uw_context ctx, uw_Basis_time t) {
if (localtime_r(&t, &stm)) {
uw_check_heap(ctx, TIMES_MAX);
r = ctx->heap.front;
- --stm.tm_hour;
len = strftime(r, TIMES_MAX, TIME_FMT, &stm);
ctx->heap.front += len+1;
return r;
@@ -2429,7 +2429,6 @@ uw_Basis_time uw_Basis_unsqlTime(uw_context ctx, uw_Basis_string s) {
*dot = 0;
if (strptime(s, TIME_FMT_PG, &stm)) {
*dot = '.';
- --stm.tm_hour;
return mktime(&stm);
}
else {
@@ -2439,10 +2438,8 @@ uw_Basis_time uw_Basis_unsqlTime(uw_context ctx, uw_Basis_string s) {
}
else {
if (strptime(s, TIME_FMT_PG, &stm) == end) {
- --stm.tm_hour;
return mktime(&stm);
} else if (strptime(s, TIME_FMT, &stm) == end) {
- --stm.tm_hour;
return mktime(&stm);
} else
uw_error(ctx, FATAL, "Can't parse time: %s", s);
@@ -2602,9 +2599,13 @@ void uw_commit(uw_context ctx) {
ctx->transactionals[i].free(ctx->transactionals[i].data);
// Splice script data into appropriate part of page
- if (ctx->returning_blob || ctx->script_header[0] == 0)
- ;
- else if (buf_used(&ctx->script) == 0) {
+ if (ctx->returning_blob || ctx->script_header[0] == 0) {
+ char *start = strstr(ctx->page.start, "<sc>");
+ if (start) {
+ memmove(start, start + 4, buf_used(&ctx->page) - (start - ctx->page.start) - 4);
+ ctx->page.front -= 4;
+ }
+ } else if (buf_used(&ctx->script) == 0) {
size_t len = strlen(ctx->script_header);
char *start = strstr(ctx->page.start, "<sc>");
if (start) {
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 9f337b5b..25666d97 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -536,23 +536,6 @@ fun getPargs (e, _) =
| _ => raise Fail "CjrPrint: getPargs"
-fun p_ensql t e =
- case t of
- Int => box [string "uw_Basis_attrifyInt(ctx, ", e, string ")"]
- | Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"]
- | String => e
- | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"]
- | Time => box [string "uw_Basis_attrifyTime(ctx, ", e, string ")"]
- | Blob => box [e, string ".data"]
- | Channel => box [string "uw_Basis_attrifyChannel(ctx, ", e, string ")"]
- | Client => box [string "uw_Basis_attrifyClient(ctx, ", e, string ")"]
- | Nullable String => e
- | Nullable t => box [string "(",
- e,
- string " == NULL ? NULL : ",
- p_ensql t (box [string "(*", e, string ")"]),
- string ")"]
-
fun notLeaky env allowHeapAllocated =
let
fun nl ok (t, _) =
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 07e54b4d..b07f81b6 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -380,7 +380,8 @@ fun reduce file =
else
[Unsure])
| EApp (f, x) =>
- unravel (#1 f, passed + 1, summarize d x @ ls)
+ unravel (#1 f, passed + 1, List.revAppend (summarize d x,
+ ls))
| _ => [Unsure]
in
unravel (e, 0, [])
@@ -584,6 +585,7 @@ fun reduce file =
(*val () = Print.prefaces "Try"
[(*("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),*)
("e'", MonoPrint.p_exp env e'),
+ ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
("e'_eff", p_events effs_e'),
("b", p_events effs_b)]*)