Mercurial > urweb

annotate tests/chat.ur @ 685:c73c5fe72388

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Stop holding client locks throughout request processing
author Adam Chlipala <adamc@hcoop.net>
date Thu, 02 Apr 2009 10:55:00 -0400
parents 5bbb542243e8
children 01b6f2ee2ef0
rev   line source
adamc@679 1 datatype log = End | Line of string * source log
adamc@679 2
adamc@679 3 fun render log =
adamc@679 4 case log of
adamc@679 5 End => <xml/>
adamc@679 6 | Line (line, logS) => <xml>{[line]}<br/><dyn signal={renderS logS}/></xml>
adamc@679 7
adamc@679 8 and renderS logS =
adamc@679 9 log <- signal logS;
adamc@679 10 return (render log)
adamc@679 11
adamc@682 12 structure Room = Broadcast(struct
adamc@682 13 type t = string
adamc@682 14 end)
adamc@682 15
adamc@678 16 sequence s
adamc@682 17 table t : { Id : int, Title : string, Room : Room.topic }
adamc@678 18
adamc@679 19 fun chat id =
adamc@682 20 r <- oneRow (SELECT t.Title, t.Room FROM t WHERE t.Id = {[id]});
adamc@682 21 ch <- Room.subscribe r.T.Room;
adamc@679 22
adamc@679 23 newLine <- source "";
adamc@679 24 logHead <- source End;
adamc@679 25 logTail <- source logHead;
adamc@679 26
adamc@679 27 let
adamc@679 28 fun onload () =
adamc@679 29 let
adamc@679 30 fun listener () =
adamc@679 31 s <- recv ch;
adamc@679 32 oldTail <- get logTail;
adamc@679 33 newTail <- source End;
adamc@679 34 set oldTail (Line (s, newTail));
adamc@679 35 set logTail newTail;
adamc@679 36 listener ()
adamc@679 37 in
adamc@679 38 listener ()
adamc@679 39 end
adamc@679 40
adamc@682 41 fun getRoom () =
adamc@682 42 r <- oneRow (SELECT t.Room FROM t WHERE t.Id = {[id]});
adamc@682 43 return r.T.Room
adamc@682 44
adamc@679 45 fun speak line =
adamc@682 46 room <- getRoom ();
adamc@682 47 Room.send room line
adamc@679 48
adamc@679 49 fun doSpeak () =
adamc@679 50 line <- get newLine;
adamc@679 51 speak line
adamc@679 52 in
adamc@679 53 return <xml><body onload={onload ()}>
adamc@679 54 <h1>{[r.T.Title]}</h1>
adamc@679 55
adamc@679 56 <button value="Send:" onclick={doSpeak ()}/> <ctextbox source={newLine}/>
adamc@679 57
adamc@679 58 <h2>Messages</h2>
adamc@679 59
adamc@679 60 <dyn signal={renderS logHead}/>
adamc@679 61
adamc@679 62 </body></xml>
adamc@679 63 end
adamc@679 64
adamc@678 65 fun list () =
adamc@678 66 queryX (SELECT * FROM t)
adamc@678 67 (fn r => <xml><tr>
adamc@679 68 <td>{[r.T.Id]}</td> <td><a link={chat r.T.Id}>{[r.T.Title]}</a></td>
adamc@678 69 <td><a link={delete r.T.Id}>[delete]</a></td>
adamc@678 70 </tr></xml>)
adamc@678 71
adamc@678 72 and delete id =
adamc@678 73 dml (DELETE FROM t WHERE Id = {[id]});
adamc@678 74 main ()
adamc@678 75
adamc@678 76 and main () : transaction page =
adamc@678 77 let
adamc@678 78 fun create r =
adamc@678 79 id <- nextval s;
adamc@682 80 room <- Room.create;
adamc@682 81 dml (INSERT INTO t (Id, Title, Room) VALUES ({[id]}, {[r.Title]}, {[room]}));
adamc@678 82 main ()
adamc@678 83 in
adamc@678 84 ls <- list ();
adamc@678 85 return <xml><body>
adamc@678 86 <table>
adamc@678 87 <tr> <th>ID</th> <th>Title</th> </tr>
adamc@678 88 {ls}
adamc@678 89 </table>
adamc@678 90
adamc@678 91 <h1>New Channel</h1>
adamc@678 92
adamc@678 93 <form>
adamc@678 94 Title: <textbox{#Title}/><br/>
adamc@678 95 <submit action={create}/>
adamc@678 96 </form>
adamc@678 97 </body></xml>
adamc@678 98 end