Mercurial > urweb
changeset 995:166ea3944b91
Versioned1 demo working
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 06 Oct 2009 17:36:45 -0400 |
| parents | 7932d577cf78 |
| children | 6c5f79209db6 |
| files | demo/more/prose demo/more/versioned.ur demo/more/versioned.urs demo/more/versioned1.ur lib/ur/list.ur src/c/urweb.c src/cjr_print.sml src/mono_reduce.sml |
| diffstat | 8 files changed, 83 insertions(+), 49 deletions(-) [+] |
line wrap: on
line diff
--- a/demo/more/prose Tue Oct 06 15:59:11 2009 -0400 +++ b/demo/more/prose Tue Oct 06 17:36:45 2009 -0400 @@ -9,3 +9,7 @@ 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>
--- a/demo/more/versioned.ur Tue Oct 06 15:59:11 2009 -0400 +++ b/demo/more/versioned.ur Tue Oct 06 17:36:45 2009 -0400 @@ -2,7 +2,7 @@ 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 @@ 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 @@ (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 @@ [_] 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 @@ 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 @@ 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 @@ 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
--- a/demo/more/versioned.urs Tue Oct 06 15:59:11 2009 -0400 +++ b/demo/more/versioned.urs Tue Oct 06 17:36:45 2009 -0400 @@ -2,7 +2,7 @@ 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 @@ 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
--- a/demo/more/versioned1.ur Tue Oct 06 15:59:11 2009 -0400 +++ b/demo/more/versioned1.ur Tue Oct 06 17:36:45 2009 -0400 @@ -9,6 +9,18 @@ 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 @@ 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 @@ 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>
--- a/lib/ur/list.ur Tue Oct 06 15:59:11 2009 -0400 +++ b/lib/ur/list.ur Tue Oct 06 17:36:45 2009 -0400 @@ -230,9 +230,10 @@ 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
--- a/src/c/urweb.c Tue Oct 06 15:59:11 2009 -0400 +++ b/src/c/urweb.c Tue Oct 06 17:36:45 2009 -0400 @@ -2160,6 +2160,7 @@ 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 @@ 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 @@ *dot = 0; if (strptime(s, TIME_FMT_PG, &stm)) { *dot = '.'; - --stm.tm_hour; return mktime(&stm); } else { @@ -2439,10 +2438,8 @@ } 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 @@ 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) {
--- a/src/cjr_print.sml Tue Oct 06 15:59:11 2009 -0400 +++ b/src/cjr_print.sml Tue Oct 06 17:36:45 2009 -0400 @@ -536,23 +536,6 @@ | _ => 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, _) =
--- a/src/mono_reduce.sml Tue Oct 06 15:59:11 2009 -0400 +++ b/src/mono_reduce.sml Tue Oct 06 17:36:45 2009 -0400 @@ -380,7 +380,8 @@ 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 @@ (*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)]*)