summaryrefslogtreecommitdiff
path: root/demo/more/conference.ur
blob: 8f6dff2a61cf38d1c3aa77c526629d7ba623a04e (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
signature INPUT = sig
    con paper :: {Type}
    constraint [Id, Document] ~ paper

    type userId
    val userId_inj : sql_injectable_prim userId
    table user : {Id : userId, Nam : string, Password : string, Chair : bool, OnPc : bool}
                     PRIMARY KEY Id,
          CONSTRAINT Nam UNIQUE Nam

    type paperId
    val paperId_inj : sql_injectable_prim paperId
    val paperId_show : show paperId
    val paperId_read : read paperId
    val paperId_eq : eq paperId
    table paper : ([Id = paperId, Document = blob] ++ paper)
                      PRIMARY KEY Id

    val checkLogin : transaction (option {Id : userId, Nam : string, Chair : bool, OnPc : bool})
    val getLogin : transaction {Id : userId, Nam : string, Chair : bool, OnPc : bool}
    val getPcLogin : transaction {Id : userId, Nam : string, Chair : bool}
    val checkChair : transaction unit
    val summarizePaper : ctx ::: {Unit} -> [[Body] ~ ctx] => $paper -> xml ([Body] ++ ctx) [] []
end

signature OUTPUT = sig
    con paper :: {Type}
    type userId
    type paperId

    val linksForPc : xbody
    val linksForChair : xbody

    con yourPaperTables :: {{Type}}
    constraint [Paper] ~ yourPaperTables
    val joinYourPaper : tabs ::: {{Type}} -> paper ::: {Type}
        -> [[Paper] ~ tabs] => [[Paper] ~ yourPaperTables] => [tabs ~ yourPaperTables] => [[Id] ~ paper] =>
        userId
        -> sql_from_items ([Paper = [Id = paperId] ++ paper] ++ tabs)
        -> sql_from_items (yourPaperTables ++ [Paper = [Id = paperId] ++ paper] ++ tabs)
end

open Meta

functor Make(M : sig
                 con paper :: {(Type * Type)}
                 constraint [Id, Document, Authors] ~ paper
                 val paper : $(map Meta.meta paper)
                 val paperFolder : folder paper

                 con paperPrivate :: {Type}
                 constraint [Id, Document, Authors] ~ paperPrivate
                 constraint paper ~ paperPrivate
                 val paperPrivate : $(map Meta.private paperPrivate)
                 val paperPrivateFolder : folder paperPrivate

                 con review :: {(Type * Type)}
                 constraint [Paper, User] ~ review
                 val review : $(map Meta.meta review)
                 val reviewFolder : folder review

                 val submissionDeadline : time
                 val summarizePaper : ctx ::: {Unit} -> [[Body] ~ ctx] => $(map fst paper ++ paperPrivate)
                                                                          -> xml ([Body] ++ ctx) [] []

                 functor Make (M : INPUT where con paper = map fst paper ++ paperPrivate)
                         : OUTPUT where con paper = map fst paper ++ paperPrivate
                                  where con userId = M.userId
                                  where con paperId = M.paperId
             end) = struct

    table user : {Id : int, Nam : string, Password : string, Chair : bool, OnPc : bool}
          PRIMARY KEY Id,
          CONSTRAINT Nam UNIQUE Nam
    sequence userId

    con paper = [Id = int, Document = blob] ++ map fst M.paper ++ M.paperPrivate
    table paper : paper
          PRIMARY KEY Id
    sequence paperId

    table authorship : {Paper : int, User : int}
          PRIMARY KEY (Paper, User),
          CONSTRAINT Paper FOREIGN KEY Paper REFERENCES paper(Id) ON DELETE CASCADE,
          CONSTRAINT User FOREIGN KEY User REFERENCES user(Id)

    con review = [Paper = int, User = int] ++ map fst M.review
    table review : review
          PRIMARY KEY (Paper, User),
          CONSTRAINT Paper FOREIGN KEY Paper REFERENCES paper(Id),
          CONSTRAINT User FOREIGN KEY User REFERENCES user(Id)
    sequence reviewId

    cookie login : {Id : int, Password : string}

    val checkLogin =
        r <- getCookie login;
        case r of
            None => return None
          | Some r =>
            oneOrNoRows1 (SELECT user.Id, user.Nam, user.Chair, user.OnPc
                          FROM user
                          WHERE user.Id = {[r.Id]}
                            AND user.Password = {[r.Password]})

    val getLogin =
        ro <- checkLogin;
        case ro of
            None => error <xml>You must be logged in to do that.</xml>
          | Some r => return r

    val getPcLogin =
        r <- getLogin;
        if r.OnPc then
            return (r -- #OnPc)
        else
            error <xml>You are not on the PC.</xml>

    val checkChair =
        r <- getLogin;
        if r.Chair then
            return ()
        else
            error <xml>You are not a chair.</xml>

    structure O = M.Make(struct
                             val user = user
                             val paper = paper
                             val checkLogin = checkLogin
                             val getLogin = getLogin
                             val getPcLogin = getPcLogin
                             val checkChair = checkChair
                             val summarizePaper = @@M.summarizePaper
                         end)

    val checkOnPc =
        r <- getLogin;
        if r.OnPc then
            return ()
        else
            error <xml>You aren't authorized to do that.</xml>

    fun checkPaper id =
        r <- getLogin;
        if r.OnPc then
            return ()
        else
            error <xml>You aren't authorized to see that paper.</xml>

    structure Users = BulkEdit.Make(struct
                                        con keyName = #Id
                                        val visible = {Nam = string "Name",
                                                       Chair = bool "Chair?",
                                                       OnPc = bool "On PC?"}

                                        val title = "Users"
                                        val isAllowed =
                                            me <- checkLogin;
                                            return (Option.isSome me)

                                        val t = user
                                    end)

    fun doRegister r =
        n <- oneRowE1 (SELECT COUNT( * ) AS N
                       FROM user
                       WHERE user.Nam = {[r.Nam]});
        if n > 0 then
            register (Some "Sorry; that username is taken.")
        else
            id <- nextval userId;
            dml (INSERT INTO user (Id, Nam, Password, Chair, OnPc)
                 VALUES ({[id]}, {[r.Nam]}, {[r.Password]}, FALSE, FALSE));
            setCookie login {Id = id, Password = r.Password};
            main ()

    and register msg = return <xml><body>
      <h1>Registering a New Account</h1>

      {case msg of
           None => <xml/>
         | Some msg => <xml><div>{[msg]}</div></xml>}

      <form><table>
        <tr> <th>Username:</th> <td><textbox{#Nam}/></td> </tr>
        <tr> <th>Password:</th> <td><password{#Password}/></td> </tr>
        <tr> <th><submit action={doRegister}/></th> </tr>
      </table></form>
    </body></xml>

    and signin r =
        ro <- oneOrNoRowsE1 (SELECT user.Id AS N
                             FROM user
                             WHERE user.Nam = {[r.Nam]}
                               AND user.Password = {[r.Password]});
        (case ro of
             None => return ()
           | Some id => setCookie login {Id = id, Password = r.Password});
        m <- main' ();
        return <xml><body>
          {case ro of
               None => <xml><div>Invalid username or password.</div></xml>
             | _ => <xml/>}

          {m}
        </body></xml>

    and main' () =
        me <- checkLogin;
        now <- now;
        return <xml><ul>
          {case me of
               None => <xml>
                 <li><a link={register None}>Register for access</a></li>
                 <li><b>Log in:</b> <form><table>
                   <tr> <th>Username:</th> <td><textbox{#Nam}/></td> </tr>
                   <tr> <th>Password:</th> <td><password{#Password}/></td> </tr>
                   <tr> <th><submit value="Log in" action={signin}/></th> </tr>
                 </table></form></li>
               </xml>
             | Some me => <xml>
               <div>Welcome, {[me.Nam]}!</div>

               {if me.Chair then
                    <xml>
                      <li><a link={Users.main ()}>Manage users</a></li>
                      {O.linksForChair}
                    </xml>
                else
                    <xml/>}

               {if me.OnPc then
                    <xml>
                      <li><a link={all ()}>All papers</a></li>
                      <li><a link={your ()}>Your papers</a></li>
                      {O.linksForPc}
                    </xml>
                else
                    <xml/>}

               {if now < M.submissionDeadline then
                    <xml><li><a link={submit ()}>Submit</a></li></xml>
                else
                    <xml/>}
             </xml>}
        </ul></xml>

    and main () =
        m <- main' ();
        return <xml><body>{m}</body></xml>

    and submit () =
        let
            fun doSubmit r =
                me <- getLogin;
                coauthors <- List.mapM (fn name => oneOrNoRowsE1 (SELECT user.Id AS N
                                                                  FROM user
                                                                  WHERE user.Nam = {[name.Nam]})) r.Authors;
                if List.exists Option.isNone coauthors then
                    error <xml>At least one of those coauthor usernames isn't registered.</xml>
                else
                    id <- nextval paperId;
                    dml (insert paper ({Id = sql_inject id, Document = sql_inject (fileData r.Document)}
                                           ++ ensql M.paper (r -- #Authors -- #Document) M.paperFolder
                                           ++ initialize M.paperPrivate M.paperPrivateFolder));
                    List.app (fn uid =>
                                 case uid of
                                     None => error <xml>Impossible empty uid!</xml>
                                   | Some uid => dml (INSERT INTO authorship (Paper, User)
                                                      VALUES ({[id]}, {[uid]})))
                             (Some me.Id :: coauthors);
                    return <xml><body>
                      Thanks for submitting!
                    </body></xml>
        in
            me <- getLogin;
            numAuthors <- Dnat.zero;

            return <xml><body>
              <h1>Submit a Paper</h1>
              
              <form>
                <b>Author:</b> {[me.Nam]}<br/>
                <subforms{#Authors}>
                  {Dnat.render <xml><entry><b>Author:</b> <textbox{#Nam}/><br/></entry></xml> numAuthors}
                </subforms>
                <button value="Add author" onclick={Dnat.inc numAuthors}/><br/>
                <button value="Remove author" onclick={Dnat.dec numAuthors}/><br/>
                <br/>

                {useMore (allWidgets M.paper M.paperFolder)}
                <b>Paper:</b> <upload{#Document}/><br/>
                <submit value="Submit" action={doSubmit}/>
              </form>
            </body></xml>
        end

    and listPapers [tabs] [[Paper] ~ tabs]
                   (q : sql_query ([Paper = [Id = int] ++ map fst M.paper ++ M.paperPrivate] ++ tabs) []) =
        checkOnPc;
        ps <- queryX q
                     (fn r => <xml><li><a link={one r.Paper.Id}>{M.summarizePaper (r.Paper -- #Id)}</a>
                     </li></xml>);
        return <xml><body>
          <h1>All Papers</h1>
          
          <ul>
            {ps}
          </ul>
        </body></xml>

    and all () =
        checkOnPc;
        listPapers (SELECT paper.Id, paper.{{map fst M.paper ++ M.paperPrivate}} FROM paper)

    and your () =
        me <- getLogin;
        listPapers (sql_query {Rows = sql_query1 {Distinct = False,
                                                  From = O.joinYourPaper me.Id (sql_from_table [#Paper] paper),
                                                  Where = (WHERE TRUE),
                                                  GroupBy = sql_subset_all [_],
                                                  Having = (WHERE TRUE),
                                                  SelectFields = sql_subset [[Paper =
                                                                              ([Id = _]
                                                                                   ++ map fst M.paper
                                                                                   ++ M.paperPrivate, _)]
                                                                                 ++ map (fn ts => ([], ts))
                                                                                            O.yourPaperTables],
                                                  SelectExps = {}},
                               OrderBy = sql_order_by_Nil [_],
                               Limit = sql_no_limit,
                               Offset = sql_no_offset})

    and one id =
        let
            fun newReview r =
                me <- getLogin;
                checkPaper id;
                dml (insert review ({Paper = sql_inject id, User = sql_inject me.Id}
                                        ++ ensql M.review r M.reviewFolder));
                one id

            fun saveReview r =
                me <- getLogin;
                checkPaper id;
                dml (update [map fst M.review] ! (ensql M.review r M.reviewFolder)
                            review (WHERE T.Paper = {[id]} AND T.User = {[me.Id]}));
                one id
        in
            me <- getLogin;
            checkPaper id;
            ro <- oneOrNoRows (SELECT paper.{{map fst M.paper}}, octet_length(paper.Document) AS N
                               FROM paper
                               WHERE paper.Id = {[id]});
            authors <- queryX (SELECT user.Nam
                               FROM authorship
                                 JOIN user ON authorship.User = user.Id
                               WHERE authorship.Paper = {[id]})
                              (fn r => <xml><li>{[r.User.Nam]}</li></xml>);
            myReview <- oneOrNoRows1 (SELECT review.{{map fst M.review}}
                                      FROM review
                                      WHERE review.User = {[me.Id]}
                                        AND review.Paper = {[id]});
            otherReviews <- queryX (SELECT user.Nam, review.{{map fst M.review}}
                                    FROM review JOIN user ON review.User = user.Id
                                    WHERE review.Paper = {[id]}
                                      AND review.User <> {[me.Id]})
                            (fn r => <xml>
                              <hr/>
                              <b>User:</b> {[r.User.Nam]}<br/>
                              {allContent M.review r.Review M.reviewFolder}
                            </xml>);

            case ro of
                None => error <xml>Paper not found!</xml>
              | Some r => return <xml><body>
                <h1>Paper #{[id]}</h1>

                <h3>Authors:</h3>
                <ul>
                  {authors}
                </ul>

                {allContent M.paper r.Paper M.paperFolder}<br/>

                {if r.N = 0 then
                     <xml><div>No paper uploaded yet.</div></xml>
                 else
                     <xml><a link={download id}>Download paper</a> ({[r.N]} bytes)</xml>}

                <hr/>

                {case myReview of
                     None => <xml>
                       <h2>Add Your Review</h2>
                       
                       <form>
                         {allWidgets M.review M.reviewFolder}
                         <submit value="Add" action={newReview}/>
                       </form>
                     </xml>
                   | Some myReview => <xml>
                     <h2>Edit Your Review</h2>

                     <form>
                       {allPopulated M.review myReview M.reviewFolder}
                       <submit value="Save" action={saveReview}/>
                     </form>
                   </xml>}

                <hr/>
                <h2>Other reviews</h2>

                {otherReviews}
              </body></xml>
        end

    and download id =
        checkPaper id;
        ro <- oneOrNoRows (SELECT paper.Document
                           FROM paper
                           WHERE paper.Id = {[id]});
        case ro of
            None => error <xml>Paper not found!</xml>
          | Some r => returnBlob r.Paper.Document (blessMime "application/pdf")

end


functor Join(M : sig
                 structure O1 : OUTPUT

                 structure O2 : OUTPUT where con paper = O1.paper
                                       where con userId = O1.userId
                                       where con paperId = O1.paperId

                 constraint O1.yourPaperTables ~ O2.yourPaperTables
             end)
        = struct
            open M
            open O1

            val linksForPc = <xml>{O1.linksForPc}{O2.linksForPc}</xml>
            val linksForChair = <xml>{O1.linksForChair}{O2.linksForChair}</xml>

            con yourPaperTables = O1.yourPaperTables ++ O2.yourPaperTables
            constraint [Paper] ~ yourPaperTables

            fun joinYourPaper [tabs] [paper] [[Paper] ~ tabs] [[Paper] ~ _] [tabs ~ yourPaperTables] [[Id] ~ paper]
                              uid (fi : sql_from_items ([Paper = [Id = paperId] ++ paper] ++ tabs)) =
                O2.joinYourPaper uid (O1.joinYourPaper uid fi)
        end