diff options
author | 2009-10-06 17:36:45 -0400 | |
---|---|---|
committer | 2009-10-06 17:36:45 -0400 | |
commit | f0999e0e7b8ae0f3e0ac622d4d70e8a1da61f47e (patch) | |
tree | b83f18305aa8814ca95cf3a7e6a8829f789d8380 | |
parent | 82ed38468f5da48ce6e9f6ec336cf5b11ca4bb4d (diff) |
Versioned1 demo working
-rw-r--r-- | demo/more/prose | 4 | ||||
-rw-r--r-- | demo/more/versioned.ur | 60 | ||||
-rw-r--r-- | demo/more/versioned.urs | 7 | ||||
-rw-r--r-- | demo/more/versioned1.ur | 18 | ||||
-rw-r--r-- | lib/ur/list.ur | 7 | ||||
-rw-r--r-- | src/c/urweb.c | 15 | ||||
-rw-r--r-- | src/cjr_print.sml | 17 | ||||
-rw-r--r-- | src/mono_reduce.sml | 4 |
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)]*) |