adamc@1022: signature INPUT = sig
adamc@1023:     con paper :: {Type}
adamc@1022:     constraint [Id, Document] ~ paper
adamc@1022: 
adamc@1022:     type userId
adamc@1022:     val userId_inj : sql_injectable_prim userId
adamc@1022:     table user : {Id : userId, Nam : string, Password : string, Chair : bool, OnPc : bool}
adamc@1022:                      PRIMARY KEY Id,
adamc@1022:           CONSTRAINT Nam UNIQUE Nam
adamc@1022: 
adamc@1022:     type paperId
adamc@1022:     val paperId_inj : sql_injectable_prim paperId
adamc@1023:     val paperId_show : show paperId
adamc@1023:     val paperId_read : read paperId
adamc@1025:     val paperId_eq : eq paperId
adamc@1023:     table paper : ([Id = paperId, Document = blob] ++ paper)
adamc@1022:                       PRIMARY KEY Id
adamc@1022: 
adamc@1032:     con review :: {Type}
adamc@1032:     constraint [Paper, User] ~ review
adamc@1032:     table review : ([Paper = paperId, User = userId] ++ review)
adamc@1032:                        PRIMARY KEY (Paper, User)
adamc@1032: 
adamc@1022:     val checkLogin : transaction (option {Id : userId, Nam : string, Chair : bool, OnPc : bool})
adamc@1022:     val getLogin : transaction {Id : userId, Nam : string, Chair : bool, OnPc : bool}
adamc@1023:     val getPcLogin : transaction {Id : userId, Nam : string, Chair : bool}
adamc@1025:     val checkChair : transaction unit
adamc@1023:     val summarizePaper : ctx ::: {Unit} -> [[Body] ~ ctx] => $paper -> xml ([Body] ++ ctx) [] []
adamc@1022: end
adamc@1022: 
adamc@1022: signature OUTPUT = sig
adamc@1023:     con paper :: {Type}
adamc@1022:     type userId
adamc@1022:     type paperId
adamc@1022: 
adamc@1022:     val linksForPc : xbody
adamc@1025:     val linksForChair : xbody
adamc@1022: 
adamc@1022:     con yourPaperTables :: {{Type}}
adamc@1022:     constraint [Paper] ~ yourPaperTables
adamc@1022:     val joinYourPaper : tabs ::: {{Type}} -> paper ::: {Type}
adamc@1022:         -> [[Paper] ~ tabs] => [[Paper] ~ yourPaperTables] => [tabs ~ yourPaperTables] => [[Id] ~ paper] =>
adamc@1027:         userId
adamc@1027:         -> sql_from_items ([Paper = [Id = paperId] ++ paper] ++ tabs)
adamc@1022:         -> sql_from_items (yourPaperTables ++ [Paper = [Id = paperId] ++ paper] ++ tabs)
adamc@1022: end
adamc@1022: 
adamc@1004: open Meta
adamc@1001: 
adamc@1001: functor Make(M : sig
adamc@1003:                  con paper :: {(Type * Type)}
adamc@1010:                  constraint [Id, Document, Authors] ~ paper
adamc@1030:                  val paper : $(map Meta.meta paper)
adamc@1007:                  val paperFolder : folder paper
adamc@1003: 
adamc@1030:                  con paperPrivate :: {Type}
adamc@1030:                  constraint [Id, Document, Authors] ~ paperPrivate
adamc@1030:                  constraint paper ~ paperPrivate
adamc@1030:                  val paperPrivate : $(map Meta.private paperPrivate)
adamc@1030:                  val paperPrivateFolder : folder paperPrivate
adamc@1030: 
adamc@1001:                  con review :: {(Type * Type)}
adamc@1003:                  constraint [Paper, User] ~ review
adamc@1030:                  val review : $(map Meta.meta review)
adamc@1011:                  val reviewFolder : folder review
adamc@1006: 
adamc@1006:                  val submissionDeadline : time
adamc@1030:                  val summarizePaper : ctx ::: {Unit} -> [[Body] ~ ctx] => $(map fst paper ++ paperPrivate)
adamc@1030:                                                                           -> xml ([Body] ++ ctx) [] []
adamc@1022: 
adamc@1032:                  functor Make (M : INPUT where con paper = map fst paper ++ paperPrivate
adamc@1032:                                          where con review = map fst review)
adamc@1030:                          : OUTPUT where con paper = map fst paper ++ paperPrivate
adamc@1023:                                   where con userId = M.userId
adamc@1022:                                   where con paperId = M.paperId
adamc@1001:              end) = struct
adamc@1001: 
adamc@1003:     table user : {Id : int, Nam : string, Password : string, Chair : bool, OnPc : bool}
adamc@1003:           PRIMARY KEY Id,
adamc@1003:           CONSTRAINT Nam UNIQUE Nam
adamc@1003:     sequence userId
adamc@1003: 
adamc@1030:     con paper = [Id = int, Document = blob] ++ map fst M.paper ++ M.paperPrivate
adamc@1003:     table paper : paper
adamc@1003:           PRIMARY KEY Id
adamc@1003:     sequence paperId
adamc@1003: 
adamc@1010:     table authorship : {Paper : int, User : int}
adamc@1010:           PRIMARY KEY (Paper, User),
adamc@1011:           CONSTRAINT Paper FOREIGN KEY Paper REFERENCES paper(Id) ON DELETE CASCADE,
adamc@1010:           CONSTRAINT User FOREIGN KEY User REFERENCES user(Id)
adamc@1010: 
adamc@1003:     con review = [Paper = int, User = int] ++ map fst M.review
adamc@1003:     table review : review
adamc@1003:           PRIMARY KEY (Paper, User),
adamc@1003:           CONSTRAINT Paper FOREIGN KEY Paper REFERENCES paper(Id),
adamc@1003:           CONSTRAINT User FOREIGN KEY User REFERENCES user(Id)
adamc@1003:     sequence reviewId
adamc@1003: 
adamc@1003:     cookie login : {Id : int, Password : string}
adamc@1003: 
adamc@1004:     val checkLogin =
adamc@1003:         r <- getCookie login;
adamc@1003:         case r of
adamc@1003:             None => return None
adamc@1003:           | Some r =>
adamc@1003:             oneOrNoRows1 (SELECT user.Id, user.Nam, user.Chair, user.OnPc
adamc@1003:                           FROM user
adamc@1003:                           WHERE user.Id = {[r.Id]}
adamc@1003:                             AND user.Password = {[r.Password]})
adamc@1003: 
adamc@1010:     val getLogin =
adamc@1010:         ro <- checkLogin;
adamc@1010:         case ro of
adamc@1010:             None => error <xml>You must be logged in to do that.</xml>
adamc@1010:           | Some r => return r
adamc@1010: 
adamc@1023:     val getPcLogin =
adamc@1023:         r <- getLogin;
adamc@1023:         if r.OnPc then
adamc@1023:             return (r -- #OnPc)
adamc@1023:         else
adamc@1023:             error <xml>You are not on the PC.</xml>
adamc@1023: 
adamc@1025:     val checkChair =
adamc@1025:         r <- getLogin;
adamc@1025:         if r.Chair then
adamc@1025:             return ()
adamc@1025:         else
adamc@1025:             error <xml>You are not a chair.</xml>
adamc@1025: 
adamc@1022:     structure O = M.Make(struct
adamc@1022:                              val user = user
adamc@1022:                              val paper = paper
adamc@1032:                              val review = review
adamc@1022:                              val checkLogin = checkLogin
adamc@1022:                              val getLogin = getLogin
adamc@1023:                              val getPcLogin = getPcLogin
adamc@1025:                              val checkChair = checkChair
adamc@1023:                              val summarizePaper = @@M.summarizePaper
adamc@1022:                          end)
adamc@1022: 
adamc@1022:     val checkOnPc =
adamc@1022:         r <- getLogin;
adamc@1022:         if r.OnPc then
adamc@1022:             return ()
adamc@1022:         else
adamc@1022:             error <xml>You aren't authorized to do that.</xml>
adamc@1022: 
adamc@1009:     fun checkPaper id =
adamc@1010:         r <- getLogin;
adamc@1010:         if r.OnPc then
adamc@1009:             return ()
adamc@1009:         else
adamc@1010:             error <xml>You aren't authorized to see that paper.</xml>
adamc@1009: 
adamc@1004:     structure Users = BulkEdit.Make(struct
adamc@1004:                                         con keyName = #Id
adamc@1004:                                         val visible = {Nam = string "Name",
adamc@1004:                                                        Chair = bool "Chair?",
adamc@1004:                                                        OnPc = bool "On PC?"}
adamc@1004: 
adamc@1004:                                         val title = "Users"
adamc@1004:                                         val isAllowed =
adamc@1004:                                             me <- checkLogin;
adamc@1004:                                             return (Option.isSome me)
adamc@1004: 
adamc@1004:                                         val t = user
adamc@1004:                                     end)
adamc@1004: 
adamc@1003:     fun doRegister r =
adamc@1003:         n <- oneRowE1 (SELECT COUNT( * ) AS N
adamc@1003:                        FROM user
adamc@1003:                        WHERE user.Nam = {[r.Nam]});
adamc@1003:         if n > 0 then
adamc@1003:             register (Some "Sorry; that username is taken.")
adamc@1003:         else
adamc@1003:             id <- nextval userId;
adamc@1003:             dml (INSERT INTO user (Id, Nam, Password, Chair, OnPc)
adamc@1003:                  VALUES ({[id]}, {[r.Nam]}, {[r.Password]}, FALSE, FALSE));
adamc@1003:             setCookie login {Id = id, Password = r.Password};
adamc@1003:             main ()
adamc@1003: 
adamc@1003:     and register msg = return <xml><body>
adamc@1003:       <h1>Registering a New Account</h1>
adamc@1003: 
adamc@1003:       {case msg of
adamc@1003:            None => <xml/>
adamc@1003:          | Some msg => <xml><div>{[msg]}</div></xml>}
adamc@1003: 
adamc@1003:       <form><table>
adamc@1003:         <tr> <th>Username:</th> <td><textbox{#Nam}/></td> </tr>
adamc@1003:         <tr> <th>Password:</th> <td><password{#Password}/></td> </tr>
adamc@1003:         <tr> <th><submit action={doRegister}/></th> </tr>
adamc@1003:       </table></form>
adamc@1003:     </body></xml>
adamc@1003: 
adamc@1006:     and signin r =
adamc@1006:         ro <- oneOrNoRowsE1 (SELECT user.Id AS N
adamc@1006:                              FROM user
adamc@1006:                              WHERE user.Nam = {[r.Nam]}
adamc@1006:                                AND user.Password = {[r.Password]});
adamc@1006:         (case ro of
adamc@1006:              None => return ()
adamc@1006:            | Some id => setCookie login {Id = id, Password = r.Password});
adamc@1006:         m <- main' ();
adamc@1006:         return <xml><body>
adamc@1006:           {case ro of
adamc@1006:                None => <xml><div>Invalid username or password.</div></xml>
adamc@1006:              | _ => <xml/>}
adamc@1006: 
adamc@1006:           {m}
adamc@1006:         </body></xml>
adamc@1006: 
adamc@1006:     and main' () =
adamc@1004:         me <- checkLogin;
adamc@1006:         now <- now;
adamc@1006:         return <xml><ul>
adamc@1003:           {case me of
adamc@1006:                None => <xml>
adamc@1006:                  <li><a link={register None}>Register for access</a></li>
adamc@1006:                  <li><b>Log in:</b> <form><table>
adamc@1006:                    <tr> <th>Username:</th> <td><textbox{#Nam}/></td> </tr>
adamc@1006:                    <tr> <th>Password:</th> <td><password{#Password}/></td> </tr>
adamc@1006:                    <tr> <th><submit value="Log in" action={signin}/></th> </tr>
adamc@1006:                  </table></form></li>
adamc@1006:                </xml>
adamc@1004:              | Some me => <xml>
adamc@1004:                <div>Welcome, {[me.Nam]}!</div>
adamc@1004: 
adamc@1004:                {if me.Chair then
adamc@1025:                     <xml>
adamc@1025:                       <li><a link={Users.main ()}>Manage users</a></li>
adamc@1025:                       {O.linksForChair}
adamc@1025:                     </xml>
adamc@1004:                 else
adamc@1004:                     <xml/>}
adamc@1006: 
adamc@1009:                {if me.OnPc then
adamc@1022:                     <xml>
adamc@1022:                       <li><a link={all ()}>All papers</a></li>
adamc@1023:                       <li><a link={your ()}>Your papers</a></li>
adamc@1022:                       {O.linksForPc}
adamc@1022:                     </xml>
adamc@1009:                 else
adamc@1009:                     <xml/>}
adamc@1009: 
adamc@1006:                {if now < M.submissionDeadline then
adamc@1007:                     <xml><li><a link={submit ()}>Submit</a></li></xml>
adamc@1006:                 else
adamc@1006:                     <xml/>}
adamc@1004:              </xml>}
adamc@1006:         </ul></xml>
adamc@1006: 
adamc@1006:     and main () =
adamc@1006:         m <- main' ();
adamc@1006:         return <xml><body>{m}</body></xml>
adamc@1001: 
adamc@1008:     and submit () =
adamc@1008:         let
adamc@1009:             fun doSubmit r =
adamc@1010:                 me <- getLogin;
adamc@1010:                 coauthors <- List.mapM (fn name => oneOrNoRowsE1 (SELECT user.Id AS N
adamc@1010:                                                                   FROM user
adamc@1010:                                                                   WHERE user.Nam = {[name.Nam]})) r.Authors;
adamc@1010:                 if List.exists Option.isNone coauthors then
adamc@1010:                     error <xml>At least one of those coauthor usernames isn't registered.</xml>
adamc@1010:                 else
adamc@1010:                     id <- nextval paperId;
adamc@1010:                     dml (insert paper ({Id = sql_inject id, Document = sql_inject (fileData r.Document)}
adamc@1030:                                            ++ ensql M.paper (r -- #Authors -- #Document) M.paperFolder
adamc@1030:                                            ++ initialize M.paperPrivate M.paperPrivateFolder));
adamc@1010:                     List.app (fn uid =>
adamc@1010:                                  case uid of
adamc@1010:                                      None => error <xml>Impossible empty uid!</xml>
adamc@1010:                                    | Some uid => dml (INSERT INTO authorship (Paper, User)
adamc@1010:                                                       VALUES ({[id]}, {[uid]})))
adamc@1010:                              (Some me.Id :: coauthors);
adamc@1010:                     return <xml><body>
adamc@1010:                       Thanks for submitting!
adamc@1010:                     </body></xml>
adamc@1008:         in
adamc@1010:             me <- getLogin;
adamc@1015:             numAuthors <- Dnat.zero;
adamc@1010: 
adamc@1008:             return <xml><body>
adamc@1008:               <h1>Submit a Paper</h1>
adamc@1008:               
adamc@1008:               <form>
adamc@1010:                 <b>Author:</b> {[me.Nam]}<br/>
adamc@1010:                 <subforms{#Authors}>
adamc@1015:                   {Dnat.render <xml><entry><b>Author:</b> <textbox{#Nam}/><br/></entry></xml> numAuthors}
adamc@1010:                 </subforms>
adamc@1015:                 <button value="Add author" onclick={Dnat.inc numAuthors}/><br/>
adamc@1015:                 <button value="Remove author" onclick={Dnat.dec numAuthors}/><br/>
adamc@1010:                 <br/>
adamc@1010: 
adamc@1010:                 {useMore (allWidgets M.paper M.paperFolder)}
adamc@1008:                 <b>Paper:</b> <upload{#Document}/><br/>
adamc@1008:                 <submit value="Submit" action={doSubmit}/>
adamc@1008:               </form>
adamc@1008:             </body></xml>
adamc@1008:         end
adamc@1007: 
adamc@1030:     and listPapers [tabs] [[Paper] ~ tabs]
adamc@1030:                    (q : sql_query ([Paper = [Id = int] ++ map fst M.paper ++ M.paperPrivate] ++ tabs) []) =
adamc@1022:         checkOnPc;
adamc@1022:         ps <- queryX q
adamc@1030:                      (fn r => <xml><li><a link={one r.Paper.Id}>{M.summarizePaper (r.Paper -- #Id)}</a>
adamc@1030:                      </li></xml>);
adamc@1009:         return <xml><body>
adamc@1009:           <h1>All Papers</h1>
adamc@1022:           
adamc@1009:           <ul>
adamc@1009:             {ps}
adamc@1009:           </ul>
adamc@1009:         </body></xml>
adamc@1009: 
adamc@1022:     and all () =
adamc@1022:         checkOnPc;
adamc@1030:         listPapers (SELECT paper.Id, paper.{{map fst M.paper ++ M.paperPrivate}} FROM paper)
adamc@1022: 
adamc@1022:     and your () =
adamc@1022:         me <- getLogin;
adamc@1022:         listPapers (sql_query {Rows = sql_query1 {Distinct = False,
adamc@1027:                                                   From = O.joinYourPaper me.Id (sql_from_table [#Paper] paper),
adamc@1022:                                                   Where = (WHERE TRUE),
adamc@1022:                                                   GroupBy = sql_subset_all [_],
adamc@1022:                                                   Having = (WHERE TRUE),
adamc@1030:                                                   SelectFields = sql_subset [[Paper =
adamc@1030:                                                                               ([Id = _]
adamc@1030:                                                                                    ++ map fst M.paper
adamc@1030:                                                                                    ++ M.paperPrivate, _)]
adamc@1022:                                                                                  ++ map (fn ts => ([], ts))
adamc@1022:                                                                                             O.yourPaperTables],
adamc@1022:                                                   SelectExps = {}},
adamc@1022:                                OrderBy = sql_order_by_Nil [_],
adamc@1022:                                Limit = sql_no_limit,
adamc@1022:                                Offset = sql_no_offset})
adamc@1022: 
adamc@1009:     and one id =
adamc@1012:         let
adamc@1012:             fun newReview r =
adamc@1012:                 me <- getLogin;
adamc@1012:                 checkPaper id;
adamc@1012:                 dml (insert review ({Paper = sql_inject id, User = sql_inject me.Id}
adamc@1012:                                         ++ ensql M.review r M.reviewFolder));
adamc@1012:                 one id
adamc@1009: 
adamc@1012:             fun saveReview r =
adamc@1012:                 me <- getLogin;
adamc@1012:                 checkPaper id;
adamc@1012:                 dml (update [map fst M.review] ! (ensql M.review r M.reviewFolder)
adamc@1012:                             review (WHERE T.Paper = {[id]} AND T.User = {[me.Id]}));
adamc@1012:                 one id
adamc@1012:         in
adamc@1012:             me <- getLogin;
adamc@1012:             checkPaper id;
adamc@1012:             ro <- oneOrNoRows (SELECT paper.{{map fst M.paper}}, octet_length(paper.Document) AS N
adamc@1012:                                FROM paper
adamc@1012:                                WHERE paper.Id = {[id]});
adamc@1012:             authors <- queryX (SELECT user.Nam
adamc@1012:                                FROM authorship
adamc@1012:                                  JOIN user ON authorship.User = user.Id
adamc@1012:                                WHERE authorship.Paper = {[id]})
adamc@1012:                               (fn r => <xml><li>{[r.User.Nam]}</li></xml>);
adamc@1012:             myReview <- oneOrNoRows1 (SELECT review.{{map fst M.review}}
adamc@1012:                                       FROM review
adamc@1012:                                       WHERE review.User = {[me.Id]}
adamc@1012:                                         AND review.Paper = {[id]});
adamc@1029:             otherReviews <- queryX (SELECT user.Nam, review.{{map fst M.review}}
adamc@1029:                                     FROM review JOIN user ON review.User = user.Id
adamc@1029:                                     WHERE review.Paper = {[id]}
adamc@1029:                                       AND review.User <> {[me.Id]})
adamc@1029:                             (fn r => <xml>
adamc@1029:                               <hr/>
adamc@1029:                               <b>User:</b> {[r.User.Nam]}<br/>
adamc@1029:                               {allContent M.review r.Review M.reviewFolder}
adamc@1029:                             </xml>);
adamc@1029: 
adamc@1012:             case ro of
adamc@1012:                 None => error <xml>Paper not found!</xml>
adamc@1012:               | Some r => return <xml><body>
adamc@1012:                 <h1>Paper #{[id]}</h1>
adamc@1010: 
adamc@1012:                 <h3>Authors:</h3>
adamc@1012:                 <ul>
adamc@1012:                   {authors}
adamc@1012:                 </ul>
adamc@1009: 
adamc@1012:                 {allContent M.paper r.Paper M.paperFolder}<br/>
adamc@1011: 
adamc@1012:                 {if r.N = 0 then
adamc@1012:                      <xml><div>No paper uploaded yet.</div></xml>
adamc@1012:                  else
adamc@1012:                      <xml><a link={download id}>Download paper</a> ({[r.N]} bytes)</xml>}
adamc@1011: 
adamc@1012:                 <hr/>
adamc@1011: 
adamc@1012:                 {case myReview of
adamc@1012:                      None => <xml>
adamc@1012:                        <h2>Add Your Review</h2>
adamc@1012:                        
adamc@1012:                        <form>
adamc@1012:                          {allWidgets M.review M.reviewFolder}
adamc@1012:                          <submit value="Add" action={newReview}/>
adamc@1012:                        </form>
adamc@1012:                      </xml>
adamc@1012:                    | Some myReview => <xml>
adamc@1012:                      <h2>Edit Your Review</h2>
adamc@1012: 
adamc@1012:                      <form>
adamc@1012:                        {allPopulated M.review myReview M.reviewFolder}
adamc@1012:                        <submit value="Save" action={saveReview}/>
adamc@1012:                      </form>
adamc@1012:                    </xml>}
adamc@1029: 
adamc@1029:                 <hr/>
adamc@1029:                 <h2>Other reviews</h2>
adamc@1029: 
adamc@1029:                 {otherReviews}
adamc@1012:               </body></xml>
adamc@1012:         end
adamc@1009: 
adamc@1009:     and download id =
adamc@1009:         checkPaper id;
adamc@1009:         ro <- oneOrNoRows (SELECT paper.Document
adamc@1009:                            FROM paper
adamc@1009:                            WHERE paper.Id = {[id]});
adamc@1009:         case ro of
adamc@1009:             None => error <xml>Paper not found!</xml>
adamc@1009:           | Some r => returnBlob r.Paper.Document (blessMime "application/pdf")
adamc@1009: 
adamc@1001: end
adamc@1030: 
adamc@1030: 
adamc@1030: functor Join(M : sig
adamc@1030:                  structure O1 : OUTPUT
adamc@1030: 
adamc@1030:                  structure O2 : OUTPUT where con paper = O1.paper
adamc@1030:                                        where con userId = O1.userId
adamc@1030:                                        where con paperId = O1.paperId
adamc@1030: 
adamc@1030:                  constraint O1.yourPaperTables ~ O2.yourPaperTables
adamc@1030:              end)
adamc@1030:         = struct
adamc@1030:             open M
adamc@1030:             open O1
adamc@1030: 
adamc@1030:             val linksForPc = <xml>{O1.linksForPc}{O2.linksForPc}</xml>
adamc@1030:             val linksForChair = <xml>{O1.linksForChair}{O2.linksForChair}</xml>
adamc@1030: 
adamc@1030:             con yourPaperTables = O1.yourPaperTables ++ O2.yourPaperTables
adamc@1030:             constraint [Paper] ~ yourPaperTables
adamc@1030: 
adamc@1030:             fun joinYourPaper [tabs] [paper] [[Paper] ~ tabs] [[Paper] ~ _] [tabs ~ yourPaperTables] [[Id] ~ paper]
adamc@1030:                               uid (fi : sql_from_items ([Paper = [Id = paperId] ++ paper] ++ tabs)) =
adamc@1030:                 O2.joinYourPaper uid (O1.joinYourPaper uid fi)
adamc@1030:         end