Mercurial > urweb
diff demo/more/versioned.ur @ 995:166ea3944b91
Versioned1 demo working
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Tue, 06 Oct 2009 17:36:45 -0400 |
parents | 10114d7b7477 |
children | 8d3aa6c7cee0 |
line wrap: on
line diff
--- 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