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