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