summaryrefslogtreecommitdiff
path: root/demo
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
commit9a77aeccaeaf77fb1c05929ef2b9eb1b8c97be9b (patch)
treeb83f18305aa8814ca95cf3a7e6a8829f789d8380 /demo
parent3c25448d761138df94b3ca1c86bbfc5d46521068 (diff)
Versioned1 demo working
Diffstat (limited to 'demo')
-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
4 files changed, 68 insertions, 21 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>