diff options
| author |  Adam Chlipala <adamc@hcoop.net> | 2009-04-05 11:48:55 -0400 |
|---|---|---|
| committer | Adam Chlipala <adamc@hcoop.net> | 2009-04-05 11:48:55 -0400 |
| commit | f6559c7555465c479d45529748deb8c15dfa346c (patch) | |
| tree | affa61639daa2a14b7eb6c9f8bb56617fa62582c | |
| parent | 37eeae6bc2503281d1b806c85aa0e70645fd9966 (diff) | |
Chat demo
| -rw-r--r-- | demo/broadcast.ur | 28 | ||||
| -rw-r--r-- | demo/broadcast.urs | 11 | ||||
| -rw-r--r-- | demo/chat.ur | 90 | ||||
| -rw-r--r-- | demo/chat.urp | 6 | ||||
| -rw-r--r-- | demo/chat.urs | 1 | ||||
| -rw-r--r-- | demo/prose | 8 | ||||
| -rw-r--r-- | lib/ur/top.ur | 26 | ||||
| -rw-r--r-- | lib/ur/top.urs | 11 |
8 files changed, 144 insertions, 37 deletions
diff --git a/demo/broadcast.ur b/demo/broadcast.ur new file mode 100644 index 00000000..13cb5ceb --- /dev/null +++ b/demo/broadcast.ur @@ -0,0 +1,28 @@ +functor Make(M : sig type t end) = struct + sequence s + table t : {Id : int, Client : client, Channel : channel M.t} + + type topic = int + + val inj : sql_injectable topic = _ + + val create = nextval s + + fun subscribe id = + cli <- self; + ro <- oneOrNoRows (SELECT t.Channel FROM t WHERE t.Id = {[id]} AND t.Client = {[cli]}); + case ro of + None => + ch <- channel; + dml (INSERT INTO t (Id, Client, Channel) VALUES ({[id]}, {[cli]}, {[ch]})); + return ch + | Some r => return r.T.Channel + + fun send id msg = + queryI (SELECT t.Channel FROM t WHERE t.Id = {[id]}) + (fn r => Basis.send r.T.Channel msg) + + fun subscribers id = + r <- oneRow (SELECT COUNT( * ) AS N FROM t WHERE t.Id = {[id]}); + return r.N +end diff --git a/demo/broadcast.urs b/demo/broadcast.urs new file mode 100644 index 00000000..9a4d0bba --- /dev/null +++ b/demo/broadcast.urs @@ -0,0 +1,11 @@ +functor Make(M : sig type t end) : sig + type topic + + val inj : sql_injectable topic + + val create : transaction topic + val subscribe : topic -> transaction (channel M.t) + val send : topic -> M.t -> transaction unit + + val subscribers : topic -> transaction int +end diff --git a/demo/chat.ur b/demo/chat.ur new file mode 100644 index 00000000..ad1bf2ca --- /dev/null +++ b/demo/chat.ur @@ -0,0 +1,90 @@ +structure Room = Broadcast.Make(struct + type t = string + end) + +sequence s +table t : { Id : int, Title : string, Room : Room.topic } + +fun chat id = + r <- oneRow (SELECT t.Title, t.Room FROM t WHERE t.Id = {[id]}); + ch <- Room.subscribe r.T.Room; + + newLine <- source ""; + buf <- Buffer.create; + + let + fun onload () = + let + fun listener () = + s <- recv ch; + Buffer.write buf s; + listener () + in + listener () + end + + fun getRoom () = + r <- oneRow (SELECT t.Room FROM t WHERE t.Id = {[id]}); + return r.T.Room + + fun speak line = + room <- getRoom (); + Room.send room line + + fun doSpeak () = + line <- get newLine; + set newLine ""; + speak line + in + return <xml><body onload={onload ()}> + <h1>{[r.T.Title]}</h1> + + <button value="Send:" onclick={doSpeak ()}/> <ctextbox source={newLine}/> + + <h2>Messages</h2> + + <dyn signal={Buffer.render buf}/> + + </body></xml> + end + +fun list () = + queryX' (SELECT * FROM t) + (fn r => + count <- Room.subscribers r.T.Room; + return <xml><tr> + <td>{[r.T.Id]}</td> + <td><a link={chat r.T.Id}>{[r.T.Title]}</a></td> + <td>{[count]}</td> + <td><a link={delete r.T.Id}>[delete]</a></td> + </tr></xml>) + +and delete id = + dml (DELETE FROM t WHERE Id = {[id]}); + main () + +and main () = + let + fun create r = + id <- nextval s; + room <- Room.create; + dml (INSERT INTO t (Id, Title, Room) VALUES ({[id]}, {[r.Title]}, {[room]})); + main () + in + ls <- list (); + return <xml><body> + <h1>Current Channels</h1> + + <table> + <tr> <th>ID</th> <th>Title</th> <th>#Subscribers</th> </tr> + {ls} + </table> + + <h1>New Channel</h1> + + <form> + Title: <textbox{#Title}/><br/> + <submit action={create}/> + </form> + </body></xml> + end diff --git a/demo/chat.urp b/demo/chat.urp new file mode 100644 index 00000000..29da66be --- /dev/null +++ b/demo/chat.urp @@ -0,0 +1,6 @@ +database dbname=test +sql chat.sql + +broadcast +buffer +chat diff --git a/demo/chat.urs b/demo/chat.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/demo/chat.urs @@ -0,0 +1 @@ +val main : unit -> transaction page @@ -256,3 +256,11 @@ roundTrip.urp <p>The <tt>main</tt> function begins by retrieving the current client ID, allocating a new channel, and associating that channel with the current client in the database. Next, we allocate a buffer and return the page, which in its <tt>onload</tt> attribute starts two loops running in parallel. In contrast to in the last example, here we only use <tt>spawn</tt> with the call to the first loop, since every client-side event handler is implicitly started in a new thread.</tt> <p>The first loop, <tt>receiver</tt>, repeatedly reads messages from the channel and writes them to the buffer. The second loop, <tt>sender</tt>, periodically sends messages to the channel. Client code can't send messages directly. Instead, we must use server-side functions to do the sending. Clients aren't trusted to pass channels to the server, so our server-side function <tt>writeBack</tt> instead keys off of the client ID, looking up the corresponding channel in the database.</p> + +chat.urp + +<p>This example provides a simple anonymous online chatting system, with multiple named channels.</p> + +<p>First, we build another useful component. Recall that each channel has an owning client, who has the exclusive ability to read messages sent to it. On top of that functionality, we can build a kind of broadcast channel that accepts multiple subscribers. The <tt>Broadcast</tt> module contains a functor with such an implementation. We instantiate the functor with the type of data we want to send over the channel. The functor output gives us an abstract type of "topics," which are subscribable IDs. When a client subscribes to a topic, it is handed a channel that it can use to read new messages on that topic. We also have an operation to count the number of subscribers to a topic. This number shouldn't be treated as too precise, since some clients that have surfed away from the application may still be considered subscribed until a timeout period elapses.</p> + +<p>The main <tt>Chat</tt> application includes some standard management of a table of named channels. All of the interesting client-server work is done with the <tt>recv</tt> function and with the functions provided by <tt>Broadcast</tt>.</p> diff --git a/lib/ur/top.ur b/lib/ur/top.ur index 154e88e9..b9728158 100644 --- a/lib/ur/top.ur +++ b/lib/ur/top.ur @@ -196,29 +196,3 @@ fun eqNullable' (tables ::: {{Type}}) (agg ::: {{Type}}) (exps ::: {Type}) case e2 of None => (SQL {e1} IS NULL) | Some _ => sql_binary sql_eq e1 (sql_inject e2) - - -functor Broadcast(M : sig type t end) = struct - sequence s - table t : {Id : int, Client : client, Channel : channel M.t} - - type topic = int - - val inj : sql_injectable topic = _ - - val create = nextval s - - fun subscribe id = - cli <- self; - ro <- oneOrNoRows (SELECT t.Channel FROM t WHERE t.Id = {[id]} AND t.Client = {[cli]}); - case ro of - None => - ch <- channel; - dml (INSERT INTO t (Id, Client, Channel) VALUES ({[id]}, {[cli]}, {[ch]})); - return ch - | Some r => return r.T.Channel - - fun send id msg = - queryI (SELECT t.Channel FROM t WHERE t.Id = {[id]}) - (fn r => Basis.send r.T.Channel msg) -end diff --git a/lib/ur/top.urs b/lib/ur/top.urs index 821aa42a..60b6dac2 100644 --- a/lib/ur/top.urs +++ b/lib/ur/top.urs @@ -134,14 +134,3 @@ val eqNullable' : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> sql_exp tables agg exps (option t) -> option t -> sql_exp tables agg exps bool - - -functor Broadcast(M : sig type t end) : sig - type topic - - val inj : sql_injectable topic - - val create : transaction topic - val subscribe : topic -> transaction (channel M.t) - val send : topic -> M.t -> transaction unit -end |