ff2b7604 |
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, ",")) |
101 | end |
102 | | doOne r = rowError (table ^ ".doOne", r) |
103 | in |
104 | Mail.mwrite (mail, "From: Hcoop Portal <portal@hcoop.net>\nTo: "); |
105 | Mail.mwrite (mail, #name user); |
106 | Mail.mwrite (mail, "@hcoop.net\n"); |
107 | Mail.mwrite (mail, "Bcc: "); |
108 | C.app (getDb ()) doOne ($`SELECT name |
109 | FROM WebUser JOIN Membership ON (usr = id AND grp = ^(C.intToSql grp))`); |
110 | Mail.mwrite (mail, "\nSubject: "); |
111 | Mail.mwrite (mail, T.subject (#data req)); |
112 | Mail.mwrite (mail, "\n\n"); |
113 | |
114 | f (user, mail); |
115 | |
116 | T.body (mail, #data req); |
117 | |
118 | Mail.mwrite (mail, "\n"); |
119 | Mail.mwrite (mail, #msg req); |
120 | |
121 | Mail.mwrite (mail, "\n\nOpen requests: "); |
122 | Mail.mwrite (mail, urlPrefix); |
123 | Mail.mwrite (mail, T.template); |
124 | Mail.mwrite (mail, "?cmd=open\n"); |
125 | |
126 | OS.Process.isSuccess (Mail.mclose mail) |
127 | end |
128 | |
129 | val notifyNew = notify (fn (user, mail) => |
130 | (Mail.mwrite (mail, #name user); |
131 | Mail.mwrite (mail, " has requested the following "); |
132 | Mail.mwrite (mail, T.descr); |
133 | Mail.mwrite (mail, " packages:\n\n"))) |
134 | |
135 | val statusToString = |
136 | fn NEW => "New" |
137 | | INSTALLED => "Installed" |
138 | | REJECTED => "Rejected" |
139 | |
140 | fun notifyMod (oldStatus, newStatus, changer, req) = |
141 | notify (fn (_, mail) => |
142 | (Mail.mwrite (mail, changer); |
143 | Mail.mwrite (mail, " has changed the status of this request from "); |
144 | Mail.mwrite (mail, statusToString oldStatus); |
145 | Mail.mwrite (mail, " to "); |
146 | Mail.mwrite (mail, statusToString newStatus); |
147 | Mail.mwrite (mail, ".\n\n"))) req |
148 | |
149 | end |