request.sml

   1 functor Request (T : REQUEST_IN) :> REQUEST_OUT =
   2 struct
   3
   4 open Util Sql Init
   5
   6 val table = T.table
   7 val seq = table ^ "Seq"
   8
   9 datatype status =
  10          NEW
  11        | INSTALLED
  12        | REJECTED
  13
  14 type request = { id : int, usr : int, data : string, msg : string, status : status, stamp : C.timestamp }
  15
  16 val statusFromInt =
  17     fn 0 => NEW
  18      | 1 => INSTALLED
  19      | 2 => REJECTED
  20      | _ => raise C.Sql "Bad APT request status"
  21
  22 val statusToInt =
  23     fn NEW => 0
  24      | INSTALLED => 1
  25      | REJECTED => 2
  26
  27 fun statusFromSql v = statusFromInt (C.intFromSql v)
  28 fun statusToSql s = C.intToSql (statusToInt s)
  29
  30 fun mkRow [id, usr, data, msg, status, stamp] =
  31     {id = C.intFromSql id, usr = C.intFromSql usr, data = C.stringFromSql data,
  32      msg = C.stringFromSql msg, status = statusFromSql status, stamp = C.timestampFromSql stamp}
  33   | mkRow r = rowError ("APT request", r)
  34
  35 fun add (usr, data, msg) =
  36     let
  37         val db = getDb ()
  38         val id = nextSeq (db, seq)
  39     in
  40         C.dml db ($`INSERT INTO ^table (id, usr, data, msg, status, stamp)
  41                     VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.stringToSql data), ^(C.stringToSql msg),
  42                             0, CURRENT_TIMESTAMP)`);
  43         id
  44     end
  45
  46 fun modify (req : request) =
  47     let
  48         val db = getDb ()
  49     in
  50         ignore (C.dml db ($`UPDATE ^table SET
  51                             usr = ^(C.intToSql (#usr req)), data = ^(C.stringToSql (#data req)),
  52                                msg = ^(C.stringToSql (#msg req)), status = ^(statusToSql (#status req))
  53                             WHERE id = ^(C.intToSql (#id req))`))
  54     end
  55
  56 fun delete id =
  57     ignore (C.dml (getDb ()) ($`DELETE FROM ^table WHERE id = ^(C.intToSql id)`))
  58
  59 fun lookup id =
  60     case C.oneOrNoRows (getDb ()) ($`SELECT id, usr, data, msg, status, stamp
  61                                      FROM ^table
  62                                      WHERE id = ^(C.intToSql id)`) of
  63         SOME row => mkRow row
  64       | NONE => raise Fail ($`^table request not found`)
  65
  66 fun mkRow' (name :: rest) = (C.stringFromSql name, mkRow rest)
  67   | mkRow' r = rowError ("Apt.request'", r)
  68
  69 fun list () =
  70     C.map (getDb ()) mkRow' ($`SELECT name, ^table.id, usr, data, msg, status, stamp
  71                                FROM ^table JOIN WebUser ON usr = WebUser.id
  72                                ORDER BY stamp DESC`)
  73
  74 fun listOpen () =
  75     C.map (getDb ()) mkRow' ($`SELECT name, ^table.id, usr, data, msg, status, stamp
  76                                FROM ^table JOIN WebUser ON usr = WebUser.id
  77                                WHERE status = 0
  78                                ORDER BY stamp DESC`)
  79
  80 fun notify f req =
  81     let
  82         val grp =
  83             case Group.groupNameToId T.adminGroup of
  84                 NONE => 0
  85               | SOME grp => grp
  86
  87         val req = lookup req
  88         val user = Init.lookupUser (#usr req)
  89
  90         val mail = Mail.mopen ()
  91
  92         fun doOne [name] =
  93             let
  94                 val name = C.stringFromSql name
  95             in
  96                 if name = #name user then
  97                     ()
  98                 else
  99                     (Mail.mwrite (mail, name);
 100                      Mail.mwrite (mail, emailSuffix);
 101                      Mail.mwrite (mail, ","))
 102             end
 103           | doOne r = rowError (table ^ ".doOne", r)
 104     in
 105         Mail.mwrite (mail, "From: Hcoop Portal <portal");
 106         Mail.mwrite (mail, emailSuffix);
 107         Mail.mwrite (mail, ">\nTo: ");
 108         Mail.mwrite (mail, #name user);
 109         Mail.mwrite (mail, emailSuffix);
 110         Mail.mwrite (mail, "\nBcc: ");
 111         C.app (getDb ()) doOne ($`SELECT name
 112                                   FROM WebUser JOIN Membership ON (usr = id AND grp = ^(C.intToSql grp))`);
 113         Mail.mwrite (mail, "\nSubject: ");
 114         Mail.mwrite (mail, T.subject (#data req));
 115         Mail.mwrite (mail, "\n\n");
 116
 117         f (user, mail);
 118
 119         T.body (mail, #data req);
 120
 121         Mail.mwrite (mail, "\n");
 122         Mail.mwrite (mail, #msg req);
 123
 124         Mail.mwrite (mail, "\n\nOpen requests: ");
 125         Mail.mwrite (mail, urlPrefix);
 126         Mail.mwrite (mail, T.template);
 127         Mail.mwrite (mail, "?cmd=open\n");
 128
 129         OS.Process.isSuccess (Mail.mclose mail)
 130     end
 131
 132 val notifyNew = notify (fn (user, mail) =>
 133                            (Mail.mwrite (mail, #name user);
 134                             Mail.mwrite (mail, " has requested the following ");
 135                             Mail.mwrite (mail, T.descr);
 136                             Mail.mwrite (mail, ":\n\n")))
 137
 138 val statusToString =
 139     fn NEW => "New"
 140      | INSTALLED => "Installed"
 141      | REJECTED => "Rejected"
 142
 143 fun notifyMod (oldStatus, newStatus, changer, req) =
 144     notify (fn (_, mail) =>
 145                (Mail.mwrite (mail, changer);
 146                 Mail.mwrite (mail, " has changed the status of this request from ");
 147                 Mail.mwrite (mail, statusToString oldStatus);
 148                 Mail.mwrite (mail, " to ");
 149                 Mail.mwrite (mail, statusToString newStatus);
 150                 Mail.mwrite (mail, ".\n\n"))) req
 151
 152 end