apt.sml

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