requestH.sml

   1 functor RequestH (T : REQUESTH_IN) :> REQUESTH_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, node : 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, node, data, msg, status, stamp] =
  31     {id = C.intFromSql id, usr = C.intFromSql usr, node = C.intFromSql node,
  32      data = C.stringFromSql data,
  33      msg = C.stringFromSql msg, status = statusFromSql status, stamp = C.timestampFromSql stamp}
  34   | mkRow r = rowError ("APT request", r)
  35
  36 fun add {usr, node, data, msg} =
  37     let
  38         val db = getDb ()
  39         val id = nextSeq (db, seq)
  40     in
  41         C.dml db ($`INSERT INTO ^table (id, usr, node, data, msg, status, stamp)
  42                     VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql node), ^(C.stringToSql data), ^(C.stringToSql msg),
  43                             0, CURRENT_TIMESTAMP)`);
  44         id
  45     end
  46
  47 fun modify (req : request) =
  48     let
  49         val db = getDb ()
  50     in
  51         ignore (C.dml db ($`UPDATE ^table SET
  52                             usr = ^(C.intToSql (#usr req)), data = ^(C.stringToSql (#data req)),
  53                                node = ^(C.intToSql (#node req)),
  54                                msg = ^(C.stringToSql (#msg req)), status = ^(statusToSql (#status req))
  55                             WHERE id = ^(C.intToSql (#id req))`))
  56     end
  57
  58 fun delete id =
  59     ignore (C.dml (getDb ()) ($`DELETE FROM ^table WHERE id = ^(C.intToSql id)`))
  60
  61 fun lookup id =
  62     case C.oneOrNoRows (getDb ()) ($`SELECT id, usr, node, data, msg, status, stamp
  63                                      FROM ^table
  64                                      WHERE id = ^(C.intToSql id)`) of
  65         SOME row => mkRow row
  66       | NONE => raise Fail ($`^table request not found`)
  67
  68 fun mkRow' (name :: rest) = (C.stringFromSql name, mkRow rest)
  69   | mkRow' r = rowError ("Apt.request'", r)
  70
  71 fun list () =
  72     C.map (getDb ()) mkRow' ($`SELECT name, ^table.id, usr, node, data, msg, status, stamp
  73                                FROM ^table JOIN WebUser ON usr = WebUser.id
  74                                ORDER BY stamp DESC`)
  75
  76 fun listOpen () =
  77     C.map (getDb ()) mkRow' ($`SELECT name, ^table.id, usr, node, data, msg, status, stamp
  78                                FROM ^table JOIN WebUser ON usr = WebUser.id
  79                                WHERE status = 0
  80                                ORDER BY stamp DESC`)
  81
  82 fun notify f req =
  83     let
  84         val grp =
  85             case Group.groupNameToId T.adminGroup of
  86                 NONE => 0
  87               | SOME grp => grp
  88
  89         val req = lookup req
  90         val user = Init.lookupUser (#usr req)
  91
  92         val mail = Mail.mopen ()
  93
  94         fun doOne [name] =
  95             let
  96                 val name = C.stringFromSql name
  97             in
  98                 if name = #name user then
  99                     ()
 100                 else
 101                     (Mail.mwrite (mail, name);
 102                      Mail.mwrite (mail, emailSuffix);
 103                      Mail.mwrite (mail, ","))
 104             end
 105           | doOne r = rowError (table ^ ".doOne", r)
 106     in
 107         Mail.mwrite (mail, "From: Hcoop Portal <portal");
 108         Mail.mwrite (mail, emailSuffix);
 109         Mail.mwrite (mail, ">\nTo: ");
 110         Mail.mwrite (mail, #name user);
 111         Mail.mwrite (mail, emailSuffix);
 112         Mail.mwrite (mail, "\nBcc: ");
 113         C.app (getDb ()) doOne ($`SELECT name
 114                                   FROM WebUser JOIN Membership ON (usr = id AND grp = ^(C.intToSql grp))`);
 115         Mail.mwrite (mail, "\nSubject: ");
 116         Mail.mwrite (mail, T.subject (#data req));
 117         Mail.mwrite (mail, "\n\n");
 118
 119         Mail.mwrite (mail, "Machine: ");
 120         Mail.mwrite (mail, Init.nodeName (#node req));
 121         Mail.mwrite (mail, "\n\n");
 122
 123         f (user, mail);
 124
 125         T.body {node = #node req, mail = mail, data = #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 {old, new, 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 old);
 154                 Mail.mwrite (mail, " to ");
 155                 Mail.mwrite (mail, statusToString new);
 156                 Mail.mwrite (mail, ".\n\n"))) req
 157
 158 end