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