-structure Apt :> APT =
-struct
-
-open Util Sql Init
-
-datatype status =
- NEW
- | INSTALLED
- | REJECTED
-
-type request = { id : int, usr : int, pkgs : string, msg : string, status : status, stamp : C.timestamp }
-
-val statusFromInt =
- fn 0 => NEW
- | 1 => INSTALLED
- | 2 => REJECTED
- | _ => raise C.Sql "Bad APT request status"
-
-val statusToInt =
- fn NEW => 0
- | INSTALLED => 1
- | REJECTED => 2
-
-fun statusFromSql v = statusFromInt (C.intFromSql v)
-fun statusToSql s = C.intToSql (statusToInt s)
-
-fun mkRequestRow [id, usr, pkgs, msg, status, stamp] =
- {id = C.intFromSql id, usr = C.intFromSql usr, pkgs = C.stringFromSql pkgs,
- msg = C.stringFromSql msg, status = statusFromSql status, stamp = C.timestampFromSql stamp}
- | mkRequestRow r = rowError ("APT request", r)
-
-fun addRequest (usr, pkgs, msg) =
- let
- val db = getDb ()
- val id = nextSeq (db, "AptSeq")
- in
- C.dml db ($`INSERT INTO Apt (id, usr, pkgs, msg, status, stamp)
- VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.stringToSql pkgs), ^(C.stringToSql msg),
- 0, CURRENT_TIMESTAMP)`);
- id
- end
-
-fun modRequest (req : request) =
- let
- val db = getDb ()
- in
- ignore (C.dml db ($`UPDATE Apt SET
- usr = ^(C.intToSql (#usr req)), pkgs = ^(C.stringToSql (#pkgs req)),
- msg = ^(C.stringToSql (#msg req)), status = ^(statusToSql (#status req))
- WHERE id = ^(C.intToSql (#id req))`))
- end
-
-fun deleteRequest id =
- ignore (C.dml (getDb ()) ($`DELETE FROM Apt WHERE id = ^(C.intToSql id)`))
-
-fun lookupRequest id =
- case C.oneOrNoRows (getDb ()) ($`SELECT id, usr, pkgs, msg, status, stamp
- FROM Apt
- WHERE id = ^(C.intToSql id)`) of
- SOME row => mkRequestRow row
- | NONE => raise Fail "APT request not found"
-
-fun mkRequestRow' (name :: rest) = (C.stringFromSql name, mkRequestRow rest)
- | mkRequestRow' r = rowError ("Apt.request'", r)
-
-fun listRequests () =
- C.map (getDb ()) mkRequestRow' ($`SELECT name, Apt.id, usr, pkgs, msg, status, stamp
- FROM Apt JOIN WebUser ON usr = WebUser.id
- ORDER BY stamp DESC`)
-
-fun listOpenRequests () =
- C.map (getDb ()) mkRequestRow' ($`SELECT name, Apt.id, usr, pkgs, msg, status, stamp
- FROM Apt JOIN WebUser ON usr = WebUser.id
- WHERE status = 0
- ORDER BY stamp DESC`)
-
-fun notify f req =
- let
- val grp =
- case Group.groupNameToId "server" of
- NONE => 0
- | SOME grp => grp
-
- val req = lookupRequest req
- val user = Init.lookupUser (#usr req)
-
- val mail = Mail.mopen ()
-
- fun doOne [name] =
- let
- val name = C.stringFromSql name
- in
- if name = #name user then
- ()
- else
- (Mail.mwrite (mail, name);
- Mail.mwrite (mail, ","))
- end
- | doOne r = rowError ("apt.doOne", r)
-
- fun rightJustify (n, s) =
- let
- fun pad n =
- if n <= 0 then
- ()
- else
- (Mail.mwrite (mail, " ");
- pad (n-1))
- in
- pad (n - size s);
- Mail.mwrite (mail, s)
- end
-
- val pkgs = String.tokens Char.isSpace (#pkgs req)
- val infos = map (valOf o AptQuery.query) pkgs
- in
- Mail.mwrite (mail, "From: Hcoop Portal <portal@hcoop.net>\nTo: ");
- Mail.mwrite (mail, #name user);
- Mail.mwrite (mail, "@hcoop.net\n");
- Mail.mwrite (mail, "Bcc: ");
- C.app (getDb ()) doOne ($`SELECT name
- FROM WebUser JOIN Membership ON (usr = id AND grp = ^(C.intToSql grp))`);
- Mail.mwrite (mail, "\nSubject: Apt package installation request\n\n");
-
- f (user, mail);
-
- app (fn info =>
- (rightJustify (10, #name info);
- Mail.mwrite (mail, " ");
- Mail.mwrite (mail, #descr info);
- Mail.mwrite (mail, "\n"))) infos;
-
- Mail.mwrite (mail, "\n");
- Mail.mwrite (mail, #msg req);
-
- Mail.mwrite (mail, "\n\nOpen requests: ");
- Mail.mwrite (mail, urlPrefix);
- Mail.mwrite (mail, "apt?cmd=open\n");
-
- OS.Process.isSuccess (Mail.mclose mail)
- end
-
-val notifyNew = notify (fn (user, mail) =>
- (Mail.mwrite (mail, #name user);
- Mail.mwrite (mail, " has requested the following packages:\n\n")))
-
-val statusToString =
- fn NEW => "New"
- | INSTALLED => "Installed"
- | REJECTED => "Rejected"
-
-fun notifyMod (oldStatus, newStatus, changer, req) =
- notify (fn (_, mail) =>
- (Mail.mwrite (mail, changer);
- Mail.mwrite (mail, " has changed the status of this request from ");
- Mail.mwrite (mail, statusToString oldStatus);
- Mail.mwrite (mail, " to ");
- Mail.mwrite (mail, statusToString newStatus);
- Mail.mwrite (mail, ".\n\n"))) req
-
-end
\ No newline at end of file
+structure Apt = RequestH(struct
+ val table = "Apt"
+ val adminGroup = "server"
+ fun subject _ = "Apt package installation request"
+ val template = "apt"
+ val descr = "packages"
+
+ fun body {node, mail, data = pkgs} =
+ let
+ val pkgs = String.tokens Char.isSpace pkgs
+ val infos = map (valOf o (fn x => AptQuery.query {node = node, pkg = x})) pkgs
+
+ fun rightJustify (n, s) =
+ let
+ fun pad n =
+ if n <= 0 then
+ ()
+ else
+ (Mail.mwrite (mail, " ");
+ pad (n-1))
+ in
+ pad (n - size s);
+ Mail.mwrite (mail, s)
+ end
+ in
+ app (fn info =>
+ (rightJustify (10, #name info);
+ Mail.mwrite (mail, " ");
+ Mail.mwrite (mail, #descr info);
+ Mail.mwrite (mail, "\n"))) infos
+ end
+ end)
HCoop / hcoop / portal.git / blobdiff