Mercurial > urweb

annotate tests/chat.ur @ 680:54ec237a3028

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Marshalcheck
author Adam Chlipala <adamc@hcoop.net>
date Sat, 28 Mar 2009 11:13:36 -0400
parents 44f23712020d
children 5bbb542243e8
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@678 12 sequence s
adamc@678 13 table t : { Id : int, Title : string, Chan : option (channel string) }
adamc@678 14
adamc@679 15 fun chat id =
adamc@679 16 r <- oneRow (SELECT t.Title, t.Chan FROM t WHERE t.Id = {[id]});
adamc@679 17 ch <- (case r.T.Chan of
adamc@679 18 None => (ch <- channel;
adamc@679 19 dml (UPDATE t SET Chan = {[Some ch]} WHERE Id = {[id]});
adamc@679 20 return ch)
adamc@679 21 | Some ch => return ch);
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@680 28 fun getCh () =
adamc@680 29 r <- oneRow (SELECT t.Chan FROM t WHERE t.Id = {[id]});
adamc@680 30 case r.T.Chan of
adamc@680 31 None => error <xml>Channel disappeared</xml>
adamc@680 32 | Some ch => return ch
adamc@680 33
adamc@680 34 fun join () =
adamc@680 35 ch <- getCh ();
adamc@680 36 subscribe ch
adamc@679 37
adamc@679 38 fun onload () =
adamc@679 39 let
adamc@679 40 fun listener () =
adamc@679 41 s <- recv ch;
adamc@679 42 oldTail <- get logTail;
adamc@679 43 newTail <- source End;
adamc@679 44 set oldTail (Line (s, newTail));
adamc@679 45 set logTail newTail;
adamc@679 46 listener ()
adamc@679 47 in
adamc@679 48 join ();
adamc@679 49 listener ()
adamc@679 50 end
adamc@679 51
adamc@679 52 fun speak line =
adamc@680 53 ch <- getCh ();
adamc@679 54 send ch line
adamc@679 55
adamc@679 56 fun doSpeak () =
adamc@679 57 line <- get newLine;
adamc@679 58 speak line
adamc@679 59 in
adamc@679 60 return <xml><body onload={onload ()}>
adamc@679 61 <h1>{[r.T.Title]}</h1>
adamc@679 62
adamc@679 63 <button value="Send:" onclick={doSpeak ()}/> <ctextbox source={newLine}/>
adamc@679 64
adamc@679 65 <h2>Messages</h2>
adamc@679 66
adamc@679 67 <dyn signal={renderS logHead}/>
adamc@679 68
adamc@679 69 </body></xml>
adamc@679 70 end
adamc@679 71
adamc@678 72 fun list () =
adamc@678 73 queryX (SELECT * FROM t)
adamc@678 74 (fn r => <xml><tr>
adamc@679 75 <td>{[r.T.Id]}</td> <td><a link={chat r.T.Id}>{[r.T.Title]}</a></td>
adamc@678 76 <td><a link={delete r.T.Id}>[delete]</a></td>
adamc@678 77 </tr></xml>)
adamc@678 78
adamc@678 79 and delete id =
adamc@678 80 dml (DELETE FROM t WHERE Id = {[id]});
adamc@678 81 main ()
adamc@678 82
adamc@678 83 and main () : transaction page =
adamc@678 84 let
adamc@678 85 fun create r =
adamc@678 86 id <- nextval s;
adamc@678 87 dml (INSERT INTO t (Id, Title, Chan) VALUES ({[id]}, {[r.Title]}, NULL));
adamc@678 88 main ()
adamc@678 89 in
adamc@678 90 ls <- list ();
adamc@678 91 return <xml><body>
adamc@678 92 <table>
adamc@678 93 <tr> <th>ID</th> <th>Title</th> </tr>
adamc@678 94 {ls}
adamc@678 95 </table>
adamc@678 96
adamc@678 97 <h1>New Channel</h1>
adamc@678 98
adamc@678 99 <form>
adamc@678 100 Title: <textbox{#Title}/><br/>
adamc@678 101 <submit action={create}/>
adamc@678 102 </form>
adamc@678 103 </body></xml>
adamc@678 104 end