calendar.ur

open User

sequence eventIds
policy sendOwnIds eventIds

type event = int
table event : {Id : event, Creator : user, Time : time, Title : string, Desc : string}
  PRIMARY KEY Id,
  CONSTRAINT Creator FOREIGN KEY Creator REFERENCES user(Id)

policy sendClient (SELECT *
                   FROM event, user
                   WHERE event.Creator = user.Id
                     AND known(user.Pass))

policy mayInsert (SELECT *
                  FROM event AS New, user
                  WHERE New.Creator = user.Id
                    AND known(user.Pass)
                    AND known(New.Title)
                    AND known(New.Desc))

policy mayUpdate (SELECT *
                  FROM event AS New, event AS Old, user
                  WHERE Old.Id = New.Id
                    AND Old.Creator = user.Id
                    AND New.Creator = Old.Creator
                    AND known(user.Pass)
                    AND known(New.Title)
                    AND known(New.Desc))

policy mayDelete (SELECT *
                  FROM event AS Old, user
                  WHERE Old.Creator = user.Id
                    AND known(user.Pass))

table attendee : {Event : event, User : user}
  PRIMARY KEY (Event, User),
  CONSTRAINT Event FOREIGN KEY Event REFERENCES event(Id) ON DELETE CASCADE,
  CONSTRAINT User FOREIGN KEY User REFERENCES user(Id) ON DELETE CASCADE

fun aclPolicy tab =
    also (mayInsert (SELECT *
                     FROM tab AS New, event, user
                     WHERE known(user.Pass)
                       AND New.Event = event.Id
                       AND event.Creator = user.Id))
         (mayDelete (SELECT *
                     FROM tab AS Old, event, user
                     WHERE known(user.Pass)
                       AND Old.Event = event.Id
                       AND event.Creator = user.Id))

policy sendClient (SELECT event.Id, event.Creator, event.Time, event.Title, event.Desc
                   FROM event, user, attendee
                   WHERE known(user.Pass)
                     AND attendee.Event = event.Id
                     AND attendee.User = user.Id)

policy aclPolicy attendee
      
table timeOnly : {Event : event, User : user}
  PRIMARY KEY (Event, User),
  CONSTRAINT Event FOREIGN KEY Event REFERENCES event(Id) ON DELETE CASCADE,
  CONSTRAINT User FOREIGN KEY User REFERENCES user(Id) ON DELETE CASCADE

policy sendClient (SELECT event.Id, event.Time
                   FROM event, user, timeOnly
                   WHERE known(user.Pass)
                     AND timeOnly.Event = event.Id
                     AND timeOnly.User = user.Id)

policy aclPolicy timeOnly

val forceUserId =
    u <- User.userId ();
    case u of
        None => error <xml>You must log in to proceed further.</xml>
      | Some u => return u

fun wrap titl bod =
    bl <- User.blurb ();
    return <xml>
      <head>
        <title>Calendar - {[titl]}</title>
      </head>

      <body>
        {bl}

        <h1>{[titl]}</h1>

        {bod}
      </body>
    </xml>

fun idOf uname =
    uo <- oneOrNoRowsE1 (SELECT (user.Id)
                         FROM user
                         WHERE user.Nam = {[uname]});
    
    case uo of
        None => error <xml>Username not found</xml>
      | Some u => return u

fun display id =
    let
        fun delete () =
            u <- forceUserId;
            dml (DELETE FROM event
                 WHERE Id = {[id]} AND Creator = {[u]});
            main ()

        fun update r =
            u <- forceUserId;
            dml (UPDATE event
                 SET Time = {[readError r.Time]}, Title = {[r.Title]}, Desc = {[r.Desc]}
                 WHERE Id = {[id]} AND Creator = {[u]});
            display id

        fun allowed () =
            u <- forceUserId;
            b <- oneRowE1 (SELECT COUNT( * ) > 0
                           FROM event
                           WHERE event.Id = {[id]}
                             AND event.Creator = {[u]});
            if b then
                return ()
            else
                error <xml>You are not the creator of that event!</xml>

        fun adder tab r =
            allowed ();
            u <- idOf r.Nam;
            dml (DELETE FROM tab
                 WHERE Event = {[id]} AND User = {[u]});
            dml (INSERT INTO tab (Event, User)
                 VALUES ({[id]}, {[u]}));
            display id

        fun addAttendee r = adder attendee r
        fun addTimeOnly r = adder timeOnly r
    in
        u <- forceUserId;
        ro <- oneOrNoRows (SELECT user.Nam, event.Time, event.Title, event.Desc, event.Creator
                           FROM event, user
                           WHERE event.Id = {[id]}
                             AND event.Creator = user.Id
                             AND event.Creator = {[u]}
                             UNION SELECT user.Nam, event.Time, event.Title, event.Desc, event.Creator
                                   FROM event, user, attendee
                                   WHERE event.Id = {[id]}
                                     AND event.Creator = user.Id
                                     AND attendee.Event = event.Id
                                     AND attendee.User = {[u]});

        case ro of
            None =>
            ro <- oneOrNoRows (SELECT event.Time
                               FROM event, timeOnly
                               WHERE event.Id = {[id]}
                                 AND timeOnly.Event = event.Id
                                 AND timeOnly.User = {[u]});
            (case ro of
                 None => error <xml>Event not found</xml>
               | Some r =>
                 wrap ("Event: [title unavailable]")
                      <xml>
                        Time: {[r.Event.Time]}<br/>
                      </xml>)
          | Some r =>
            atts <- queryX1 (SELECT user.Id, user.Nam
                             FROM attendee, user
                             WHERE attendee.User = user.Id
                               AND attendee.Event = {[id]}
                             ORDER BY user.Nam)
                    (fn r => <xml><li><a link={byId r.Id}>{[r.Nam]}</a></li></xml>);
            tos <- queryX1 (SELECT user.Id, user.Nam
                            FROM timeOnly, user
                            WHERE timeOnly.User = user.Id
                              AND timeOnly.Event = {[id]}
                            ORDER BY user.Nam)
                           (fn r => <xml><li><a link={byId r.Id}>{[r.Nam]}</a></li></xml>);

            wrap ("Event: " ^ r.Event.Title)
                 <xml>
                   Creator: {[r.User.Nam]}<br/>
                   Time: {[r.Event.Time]}<br/>
                   <br/>
                   {[r.Event.Desc]}
                   <br/>
                   <h4>Attendees:</h4>
                   {atts}
                   <h4>People who may know something is happening at this time:</h4>
                   {tos}
                   
                   {if r.Event.Creator = u then
                        <xml>
                          <form> <submit value="Delete" action={delete}/> </form>

                          <h2>Change event details</h2>
                          
                          <form><table>
                            <tr> <th>Title:</th> <td><textbox{#Title} value={r.Event.Title}/></td> </tr>
                            <tr> <th>Time:</th> <td><textbox{#Time} value={show r.Event.Time}/></td> </tr>
                            <tr> <th>Description:</th> <td><textbox{#Desc} value={r.Event.Desc}/></td> </tr>
                            <tr> <td><submit action={update}/></td> </tr>
                          </table></form>

                          <h2>Add attendee</h2>
                          
                          <form>
                            <textbox{#Nam}/> <submit action={addAttendee}/>
                          </form>

                          <h2>Add time-only access</h2>
                          
                          <form>
                            <textbox{#Nam}/> <submit action={addTimeOnly}/>
                          </form>
                        </xml>
                    else
                        <xml/>}

                   <hr/>
                   <a link={main ()}>Back to your calendar</a>
                 </xml>
    end

and add r =
    u <- forceUserId;
    id <- nextval eventIds;
    dml (INSERT INTO event (Id, Creator, Time, Title, Desc)
         VALUES ({[id]}, {[u]}, {[readError r.Time]}, {[r.Title]}, {[r.Desc]}));
    display id

and main () =
    u <- userId ();
    case u of
        None => wrap "Main" <xml>You must log in to proceed further.</xml>
      | Some u =>
        evs <- queryX (SELECT event.Id AS Id, event.Time AS Time, event.Title AS Title
                       FROM event
                       WHERE event.Creator = {[u]}
                       UNION SELECT event.Id AS Id, event.Time AS Time, event.Title AS Title
                             FROM event, attendee
                             WHERE attendee.Event = event.Id
                               AND attendee.User = {[u]}
                       ORDER BY Time)
               (fn r => <xml>
                 <hr/>

                 <h3><a link={display r.Id}>{[r.Title]}</a></h3>
                 Time: {[r.Time]}<br/>
               </xml>);

        wrap "Main" <xml>
          {evs}

          <hr/>

          <h2>Add event</h2>

          <form><table>
            <tr> <th>Title:</th> <td><textbox{#Title}/></td> </tr>
            <tr> <th>Time:</th> <td><textbox{#Time}/></td> </tr>
            <tr> <th>Description:</th> <td><textbox{#Desc}/></td> </tr>
            <tr> <td><submit action={add}/></td> </tr>
          </table></form>

          <hr/>

          <h2>View another user's calendar</h2>

          <form>
            <textbox{#Nam}/> <submit value="View" action={byName}/>
          </form>
        </xml>

and byName r =
    uname <- return r.Nam;
    u <- idOf uname;
    other uname u

and byId u =
    uname <- oneRowE1 (SELECT (user.Nam)
                       FROM user
                       WHERE user.Id = {[u]});
    other uname u

and other uname u =
    u' <- userId ();
    case u' of
        None => wrap "Someone else's calendar" <xml>You must log in to proceed further.</xml>
      | Some u' =>
        evs <- queryX' (SELECT event.Id AS Id, event.Time AS Time
                        FROM event
                        WHERE event.Creator = {[u]}
                          AND event.Creator = {[u']}
                          UNION SELECT event.Id AS Id, event.Time AS Time
                                FROM event, attendee AS You
                                WHERE event.Creator = {[u]}
                                  AND You.Event = event.Id
                                  AND You.User = {[u']}
                          UNION SELECT event.Id AS Id, event.Time AS Time
                                FROM event, timeOnly AS You
                                WHERE event.Creator = {[u]}
                                  AND You.Event = event.Id
                                  AND You.User = {[u']}
                          UNION SELECT event.Id AS Id, event.Time AS Time
                                FROM event, attendee AS Other
                                WHERE event.Creator = {[u']}
                                  AND Other.Event = event.Id
                                  AND Other.User = {[u]}
                          UNION SELECT event.Id AS Id, event.Time AS Time
                                FROM event, attendee AS You, attendee AS Other
                                WHERE You.Event = event.Id
                                  AND You.User = {[u']}
                                  AND Other.Event = event.Id
                                  AND Other.User = {[u]}
                          UNION SELECT event.Id AS Id, event.Time AS Time
                                FROM event, timeOnly AS You, attendee AS Other
                                WHERE You.Event = event.Id
                                  AND You.User = {[u']}
                                  AND Other.Event = event.Id
                                  AND Other.User = {[u]}
                          ORDER BY Time)
                       (fn r =>
                           title <- oneOrNoRowsE1 (SELECT (event.Title)
                                                   FROM event
                                                   WHERE event.Id = {[r.Id]}
                                                     AND event.Creator = {[u']}
                                                   UNION SELECT (event.Title)
                                                         FROM event, attendee
                                                         WHERE event.Id = {[r.Id]}
                                                           AND attendee.Event = event.Id
                                                           AND attendee.User = {[u']});
                   
                           return <xml>
                             <hr/>

                             <h3>{case title of
                                      None => <xml><i>Busy</i></xml>
                                    | Some title => <xml><a link={display r.Id}>{[title]}</a></xml>}</h3>
                             Time: {[r.Time]}<br/>
                           </xml>);

        wrap (uname ^ "'s Calendar") <xml>
          {evs}

          <hr/>
          <a link={main ()}>Back to your calendar</a>
        </xml>