roll.sml

   1 structure Roll :> ROLL = struct
   2
   3 open Init Sql Util
   4
   5 fun activeUsernames () =
   6     let
   7         fun mkRow [name] = C.stringFromSql name
   8           | mkRow row = rowError ("activeUsernames", row)
   9     in
  10         C.map (getDb ()) mkRow "SELECT name FROM WebUserActive ORDER BY name"
  11     end
  12
  13 type roll_call = {
  14      id : int,
  15      title : string,
  16      msg : string,
  17      started : C.timestamp
  18 }
  19
  20 fun mkRollRow [id, title, msg, started] =
  21     {id = C.intFromSql id, title = C.stringFromSql title,
  22      msg = C.stringFromSql msg, started = C.timestampFromSql started}
  23   | mkRollRow row = rowError ("roll", row)
  24
  25 fun addRollCall (title, msg) =
  26     let
  27         val db = getDb ()
  28         val id = nextSeq (db, "RollCallSeq")
  29
  30         fun addUser [uid, name] =
  31             let
  32                 val uid = C.intFromSql uid
  33                 val name = C.stringFromSql name
  34                 val code = randomPassword ()
  35
  36                 val _ = C.dml db ($`INSERT INTO RollCallEntry (rol, usr, code, responded)
  37                                     VALUES (^(C.intToSql id), ^(C.intToSql uid), ^(C.stringToSql code), NULL)`)
  38
  39                 val mail = Mail.mopen ()
  40             in
  41                 Mail.mwrite (mail, "From: Hcoop Portal <hcoop");
  42                 Mail.mwrite (mail, emailSuffix);
  43                 Mail.mwrite (mail, ">\nTo: ");
  44                 Mail.mwrite (mail, name);
  45                 Mail.mwrite (mail, emailSuffix);
  46                 Mail.mwrite (mail, "\nSubject: HCoop Roll Call: ");
  47                 Mail.mwrite (mail, title);
  48                 Mail.mwrite (mail, "\n\n");
  49                 Mail.mwrite (mail, "The admins want to make sure that they can reach everyone by e-mail.  To let them know that you're here, please visit this URL:\n\t");
  50                 Mail.mwrite (mail, urlPrefix);
  51                 Mail.mwrite (mail, "roll?cmd=respond&rol=");
  52                 Mail.mwrite (mail, Int.toString id);
  53                 Mail.mwrite (mail, "&code=");
  54                 Mail.mwrite (mail, code);
  55                 Mail.mwrite (mail, "\nYou may have to hit \"reload\" in your web browser, if you aren't already logged into the portal.\n\n");
  56                 Mail.mwrite (mail, msg);
  57                 ignore (Mail.mclose mail)
  58             end
  59           | addUser row = rowError ("add roll entry", row)
  60     in
  61         C.dml db ($`INSERT INTO RollCall (id, title, msg, started)
  62                     VALUES (^(C.intToSql id), ^(C.stringToSql title), ^(C.stringToSql msg),
  63                             CURRENT_TIMESTAMP)`);
  64         C.app db addUser "SELECT id, name FROM WebUserActive";
  65         id
  66     end
  67
  68 fun modRollCall (rc : roll_call) =
  69     let
  70         val db = getDb ()
  71     in
  72         ignore (C.dml db ($`UPDATE RollCall SET
  73                             title = ^(C.stringToSql (#title rc)),
  74                             msg = ^(C.stringToSql (#msg rc))
  75                             WHERE id = ^(C.intToSql (#id rc))`))
  76     end
  77
  78 fun deleteRollCall id =
  79     ignore (C.dml (getDb ()) ($`DELETE FROM RollCall WHERE id = ^(C.intToSql id)`))
  80
  81 fun lookupRollCall id =
  82     case C.oneOrNoRows (getDb ()) ($`SELECT id, title, msg, started
  83                                      FROM RollCall
  84                                      WHERE id = ^(C.intToSql id)`) of
  85         NONE => raise Fail "Roll call not found"
  86       | SOME row => mkRollRow row
  87
  88 fun listRollCalls id =
  89     C.map (getDb ()) mkRollRow "SELECT id, title, msg, started FROM RollCall ORDER BY started DESC"
  90
  91 type roll_call_entry = {
  92      rol : int,
  93      usr : int,
  94      code : string,
  95      responded : C.timestamp option
  96 }
  97
  98 fun mkEntryRow [rol, usr, code, responded] =
  99     {rol = C.intFromSql rol, usr = C.intFromSql usr,
 100      code = C.stringFromSql code,
 101      responded = (if C.isNull responded then NONE else SOME (C.timestampFromSql responded))}
 102   | mkEntryRow row = rowError ("roll entry", row)
 103
 104 fun lookupEntry (rol, usr) =
 105     case C.oneOrNoRows (getDb ()) ($`SELECT rol, usr, code, responded
 106                                      FROM RollCallEntry
 107                                      WHERE rol = ^(C.intToSql rol) AND usr = ^(C.intToSql usr)`) of
 108         NONE => raise Fail "Roll call entry not found"
 109       | SOME row => mkEntryRow row
 110
 111 fun listEntries id =
 112     let
 113         fun folder (_ :: row, (didnt, did)) =
 114             let
 115                 val ent = mkEntryRow row
 116                 val uent = (Init.lookupUser (#usr ent), ent)
 117             in
 118                 case #responded ent of
 119                     NONE => (uent :: didnt, did)
 120                   | SOME _ => (didnt, uent :: did)
 121             end
 122           | folder (row, _) = rowError ("listEntries folder", row)
 123     in
 124         C.fold (getDb ()) folder ([], [])
 125                ($`SELECT name, rol, usr, code, responded
 126                   FROM RollCallEntry JOIN WebUser ON id = usr
 127                   WHERE rol = ^(C.intToSql id)
 128                   ORDER BY responded, name DESC`)
 129     end
 130
 131 fun respond (rol, usr) =
 132     ignore (C.dml (getDb ()) ($`UPDATE RollCallEntry
 133                                 SET responded = CURRENT_TIMESTAMP
 134                                 WHERE rol = ^(C.intToSql rol) AND usr = ^(C.intToSql usr)`))
 135
 136 end