Mercurial > urweb

annotate demo/more/conference.ur @ 1020:dfe34fad749d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
RPC uses VM support for call/cc
author Adam Chlipala <adamc@hcoop.net>
date Sun, 25 Oct 2009 14:07:10 -0400
parents e47303e5d73d
children 4de35df3d545
rev   line source
adamc@1004 1 open Meta
adamc@1001 2
adamc@1001 3 functor Make(M : sig
adamc@1003 4 con paper :: {(Type * Type)}
adamc@1010 5 constraint [Id, Document, Authors] ~ paper
adamc@1003 6 val paper : $(map meta paper)
adamc@1007 7 val paperFolder : folder paper
adamc@1003 8
adamc@1001 9 con review :: {(Type * Type)}
adamc@1003 10 constraint [Paper, User] ~ review
adamc@1003 11 val review : $(map meta review)
adamc@1011 12 val reviewFolder : folder review
adamc@1006 13
adamc@1006 14 val submissionDeadline : time
adamc@1009 15 val summarizePaper : $(map fst paper) -> xbody
adamc@1001 16 end) = struct
adamc@1001 17
adamc@1003 18 table user : {Id : int, Nam : string, Password : string, Chair : bool, OnPc : bool}
adamc@1003 19 PRIMARY KEY Id,
adamc@1003 20 CONSTRAINT Nam UNIQUE Nam
adamc@1003 21 sequence userId
adamc@1003 22
adamc@1008 23 con paper = [Id = int, Document = blob] ++ map fst M.paper
adamc@1003 24 table paper : paper
adamc@1003 25 PRIMARY KEY Id
adamc@1003 26 sequence paperId
adamc@1003 27
adamc@1010 28 table authorship : {Paper : int, User : int}
adamc@1010 29 PRIMARY KEY (Paper, User),
adamc@1011 30 CONSTRAINT Paper FOREIGN KEY Paper REFERENCES paper(Id) ON DELETE CASCADE,
adamc@1010 31 CONSTRAINT User FOREIGN KEY User REFERENCES user(Id)
adamc@1010 32
adamc@1003 33 con review = [Paper = int, User = int] ++ map fst M.review
adamc@1003 34 table review : review
adamc@1003 35 PRIMARY KEY (Paper, User),
adamc@1003 36 CONSTRAINT Paper FOREIGN KEY Paper REFERENCES paper(Id),
adamc@1003 37 CONSTRAINT User FOREIGN KEY User REFERENCES user(Id)
adamc@1003 38 sequence reviewId
adamc@1003 39
adamc@1003 40 cookie login : {Id : int, Password : string}
adamc@1003 41
adamc@1004 42 val checkLogin =
adamc@1003 43 r <- getCookie login;
adamc@1003 44 case r of
adamc@1003 45 None => return None
adamc@1003 46 | Some r =>
adamc@1003 47 oneOrNoRows1 (SELECT user.Id, user.Nam, user.Chair, user.OnPc
adamc@1003 48 FROM user
adamc@1003 49 WHERE user.Id = {[r.Id]}
adamc@1003 50 AND user.Password = {[r.Password]})
adamc@1003 51
adamc@1010 52 val getLogin =
adamc@1010 53 ro <- checkLogin;
adamc@1010 54 case ro of
adamc@1010 55 None => error <xml>You must be logged in to do that.</xml>
adamc@1010 56 | Some r => return r
adamc@1010 57
adamc@1009 58 fun checkPaper id =
adamc@1010 59 r <- getLogin;
adamc@1010 60 if r.OnPc then
adamc@1009 61 return ()
adamc@1009 62 else
adamc@1010 63 error <xml>You aren't authorized to see that paper.</xml>
adamc@1009 64
adamc@1004 65 structure Users = BulkEdit.Make(struct
adamc@1004 66 con keyName = #Id
adamc@1004 67 val visible = {Nam = string "Name",
adamc@1004 68 Chair = bool "Chair?",
adamc@1004 69 OnPc = bool "On PC?"}
adamc@1004 70
adamc@1004 71 val title = "Users"
adamc@1004 72 val isAllowed =
adamc@1004 73 me <- checkLogin;
adamc@1004 74 return (Option.isSome me)
adamc@1004 75
adamc@1004 76 val t = user
adamc@1004 77 end)
adamc@1004 78
adamc@1003 79 fun doRegister r =
adamc@1003 80 n <- oneRowE1 (SELECT COUNT( * ) AS N
adamc@1003 81 FROM user
adamc@1003 82 WHERE user.Nam = {[r.Nam]});
adamc@1003 83 if n > 0 then
adamc@1003 84 register (Some "Sorry; that username is taken.")
adamc@1003 85 else
adamc@1003 86 id <- nextval userId;
adamc@1003 87 dml (INSERT INTO user (Id, Nam, Password, Chair, OnPc)
adamc@1003 88 VALUES ({[id]}, {[r.Nam]}, {[r.Password]}, FALSE, FALSE));
adamc@1003 89 setCookie login {Id = id, Password = r.Password};
adamc@1003 90 main ()
adamc@1003 91
adamc@1003 92 and register msg = return <xml><body>
adamc@1003 93 <h1>Registering a New Account</h1>
adamc@1003 94
adamc@1003 95 {case msg of
adamc@1003 96 None => <xml/>
adamc@1003 97 | Some msg => <xml><div>{[msg]}</div></xml>}
adamc@1003 98
adamc@1003 99 <form><table>
adamc@1003 100 <tr> <th>Username:</th> <td><textbox{#Nam}/></td> </tr>
adamc@1003 101 <tr> <th>Password:</th> <td><password{#Password}/></td> </tr>
adamc@1003 102 <tr> <th><submit action={doRegister}/></th> </tr>
adamc@1003 103 </table></form>
adamc@1003 104 </body></xml>
adamc@1003 105
adamc@1006 106 and signin r =
adamc@1006 107 ro <- oneOrNoRowsE1 (SELECT user.Id AS N
adamc@1006 108 FROM user
adamc@1006 109 WHERE user.Nam = {[r.Nam]}
adamc@1006 110 AND user.Password = {[r.Password]});
adamc@1006 111 (case ro of
adamc@1006 112 None => return ()
adamc@1006 113 | Some id => setCookie login {Id = id, Password = r.Password});
adamc@1006 114 m <- main' ();
adamc@1006 115 return <xml><body>
adamc@1006 116 {case ro of
adamc@1006 117 None => <xml><div>Invalid username or password.</div></xml>
adamc@1006 118 | _ => <xml/>}
adamc@1006 119
adamc@1006 120 {m}
adamc@1006 121 </body></xml>
adamc@1006 122
adamc@1006 123 and main' () =
adamc@1004 124 me <- checkLogin;
adamc@1006 125 now <- now;
adamc@1006 126 return <xml><ul>
adamc@1003 127 {case me of
adamc@1006 128 None => <xml>
adamc@1006 129 <li><a link={register None}>Register for access</a></li>
adamc@1006 130 <li><b>Log in:</b> <form><table>
adamc@1006 131 <tr> <th>Username:</th> <td><textbox{#Nam}/></td> </tr>
adamc@1006 132 <tr> <th>Password:</th> <td><password{#Password}/></td> </tr>
adamc@1006 133 <tr> <th><submit value="Log in" action={signin}/></th> </tr>
adamc@1006 134 </table></form></li>
adamc@1006 135 </xml>
adamc@1004 136 | Some me => <xml>
adamc@1004 137 <div>Welcome, {[me.Nam]}!</div>
adamc@1004 138
adamc@1004 139 {if me.Chair then
adamc@1004 140 <xml><li><a link={Users.main ()}>Manage users</a></li></xml>
adamc@1004 141 else
adamc@1004 142 <xml/>}
adamc@1006 143
adamc@1009 144 {if me.OnPc then
adamc@1009 145 <xml><li><a link={all ()}>All papers</a></li></xml>
adamc@1009 146 else
adamc@1009 147 <xml/>}
adamc@1009 148
adamc@1006 149 {if now < M.submissionDeadline then
adamc@1007 150 <xml><li><a link={submit ()}>Submit</a></li></xml>
adamc@1006 151 else
adamc@1006 152 <xml/>}
adamc@1004 153 </xml>}
adamc@1006 154 </ul></xml>
adamc@1006 155
adamc@1006 156 and main () =
adamc@1006 157 m <- main' ();
adamc@1006 158 return <xml><body>{m}</body></xml>
adamc@1001 159
adamc@1008 160 and submit () =
adamc@1008 161 let
adamc@1009 162 fun doSubmit r =
adamc@1010 163 me <- getLogin;
adamc@1010 164 coauthors <- List.mapM (fn name => oneOrNoRowsE1 (SELECT user.Id AS N
adamc@1010 165 FROM user
adamc@1010 166 WHERE user.Nam = {[name.Nam]})) r.Authors;
adamc@1010 167 if List.exists Option.isNone coauthors then
adamc@1010 168 error <xml>At least one of those coauthor usernames isn't registered.</xml>
adamc@1010 169 else
adamc@1010 170 id <- nextval paperId;
adamc@1010 171 dml (insert paper ({Id = sql_inject id, Document = sql_inject (fileData r.Document)}
adamc@1010 172 ++ ensql M.paper (r -- #Authors -- #Document) M.paperFolder));
adamc@1010 173 List.app (fn uid =>
adamc@1010 174 case uid of
adamc@1010 175 None => error <xml>Impossible empty uid!</xml>
adamc@1010 176 | Some uid => dml (INSERT INTO authorship (Paper, User)
adamc@1010 177 VALUES ({[id]}, {[uid]})))
adamc@1010 178 (Some me.Id :: coauthors);
adamc@1010 179 return <xml><body>
adamc@1010 180 Thanks for submitting!
adamc@1010 181 </body></xml>
adamc@1008 182 in
adamc@1010 183 me <- getLogin;
adamc@1015 184 numAuthors <- Dnat.zero;
adamc@1010 185
adamc@1008 186 return <xml><body>
adamc@1008 187 <h1>Submit a Paper</h1>
adamc@1008 188
adamc@1008 189 <form>
adamc@1010 190 <b>Author:</b> {[me.Nam]}<br/>
adamc@1010 191 <subforms{#Authors}>
adamc@1015 192 {Dnat.render <xml><entry><b>Author:</b> <textbox{#Nam}/><br/></entry></xml> numAuthors}
adamc@1010 193 </subforms>
adamc@1015 194 <button value="Add author" onclick={Dnat.inc numAuthors}/><br/>
adamc@1015 195 <button value="Remove author" onclick={Dnat.dec numAuthors}/><br/>
adamc@1010 196 <br/>
adamc@1010 197
adamc@1010 198 {useMore (allWidgets M.paper M.paperFolder)}
adamc@1008 199 <b>Paper:</b> <upload{#Document}/><br/>
adamc@1008 200 <submit value="Submit" action={doSubmit}/>
adamc@1008 201 </form>
adamc@1008 202 </body></xml>
adamc@1008 203 end
adamc@1007 204
adamc@1009 205 and all () =
adamc@1009 206 ps <- queryX (SELECT paper.Id, paper.{{map fst M.paper}} FROM paper)
adamc@1009 207 (fn r => <xml><li><a link={one r.Paper.Id}>{M.summarizePaper (r.Paper -- #Id)}</a></li></xml>);
adamc@1009 208 return <xml><body>
adamc@1009 209 <h1>All Papers</h1>
adamc@1009 210
adamc@1009 211 <ul>
adamc@1009 212 {ps}
adamc@1009 213 </ul>
adamc@1009 214 </body></xml>
adamc@1009 215
adamc@1009 216 and one id =
adamc@1012 217 let
adamc@1012 218 fun newReview r =
adamc@1012 219 me <- getLogin;
adamc@1012 220 checkPaper id;
adamc@1012 221 dml (insert review ({Paper = sql_inject id, User = sql_inject me.Id}
adamc@1012 222 ++ ensql M.review r M.reviewFolder));
adamc@1012 223 one id
adamc@1009 224
adamc@1012 225 fun saveReview r =
adamc@1012 226 me <- getLogin;
adamc@1012 227 checkPaper id;
adamc@1012 228 dml (update [map fst M.review] ! (ensql M.review r M.reviewFolder)
adamc@1012 229 review (WHERE T.Paper = {[id]} AND T.User = {[me.Id]}));
adamc@1012 230 one id
adamc@1012 231 in
adamc@1012 232 me <- getLogin;
adamc@1012 233 checkPaper id;
adamc@1012 234 ro <- oneOrNoRows (SELECT paper.{{map fst M.paper}}, octet_length(paper.Document) AS N
adamc@1012 235 FROM paper
adamc@1012 236 WHERE paper.Id = {[id]});
adamc@1012 237 authors <- queryX (SELECT user.Nam
adamc@1012 238 FROM authorship
adamc@1012 239 JOIN user ON authorship.User = user.Id
adamc@1012 240 WHERE authorship.Paper = {[id]})
adamc@1012 241 (fn r => <xml><li>{[r.User.Nam]}</li></xml>);
adamc@1012 242 myReview <- oneOrNoRows1 (SELECT review.{{map fst M.review}}
adamc@1012 243 FROM review
adamc@1012 244 WHERE review.User = {[me.Id]}
adamc@1012 245 AND review.Paper = {[id]});
adamc@1012 246 case ro of
adamc@1012 247 None => error <xml>Paper not found!</xml>
adamc@1012 248 | Some r => return <xml><body>
adamc@1012 249 <h1>Paper #{[id]}</h1>
adamc@1010 250
adamc@1012 251 <h3>Authors:</h3>
adamc@1012 252 <ul>
adamc@1012 253 {authors}
adamc@1012 254 </ul>
adamc@1009 255
adamc@1012 256 {allContent M.paper r.Paper M.paperFolder}<br/>
adamc@1011 257
adamc@1012 258 {if r.N = 0 then
adamc@1012 259 <xml><div>No paper uploaded yet.</div></xml>
adamc@1012 260 else
adamc@1012 261 <xml><a link={download id}>Download paper</a> ({[r.N]} bytes)</xml>}
adamc@1011 262
adamc@1012 263 <hr/>
adamc@1011 264
adamc@1012 265 {case myReview of
adamc@1012 266 None => <xml>
adamc@1012 267 <h2>Add Your Review</h2>
adamc@1012 268
adamc@1012 269 <form>
adamc@1012 270 {allWidgets M.review M.reviewFolder}
adamc@1012 271 <submit value="Add" action={newReview}/>
adamc@1012 272 </form>
adamc@1012 273 </xml>
adamc@1012 274 | Some myReview => <xml>
adamc@1012 275 <h2>Edit Your Review</h2>
adamc@1012 276
adamc@1012 277 <form>
adamc@1012 278 {allPopulated M.review myReview M.reviewFolder}
adamc@1012 279 <submit value="Save" action={saveReview}/>
adamc@1012 280 </form>
adamc@1012 281 </xml>}
adamc@1012 282 </body></xml>
adamc@1012 283 end
adamc@1009 284
adamc@1009 285 and download id =
adamc@1009 286 checkPaper id;
adamc@1009 287 ro <- oneOrNoRows (SELECT paper.Document
adamc@1009 288 FROM paper
adamc@1009 289 WHERE paper.Id = {[id]});
adamc@1009 290 case ro of
adamc@1009 291 None => error <xml>Paper not found!</xml>
adamc@1009 292 | Some r => returnBlob r.Paper.Document (blessMime "application/pdf")
adamc@1009 293
adamc@1001 294 end