Commit | Line | Data |
---|---|---|
208e2cbc AC |
1 | structure Init :> INIT = |
2 | struct | |
3 | ||
dda99898 | 4 | open Util Sql Config |
208e2cbc AC |
5 | structure C = PgClient |
6 | ||
d5f8418b AC |
7 | fun nullableFromSql f x = |
8 | if C.isNull x then | |
9 | NONE | |
10 | else | |
11 | SOME (f x) | |
12 | fun nullableToSql f x = | |
13 | case x of | |
14 | NONE => "NULL" | |
15 | | SOME x => f x | |
16 | ||
208e2cbc | 17 | exception Access of string |
f3f3ad24 | 18 | exception NeedTos |
208e2cbc | 19 | |
dda99898 | 20 | fun conn () = C.conn dbstring |
208e2cbc AC |
21 | val close = C.close |
22 | ||
f3f3ad24 | 23 | type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp, |
d5f8418b | 24 | app : int, shares : int, paypal : string option, checkout : string option } |
208e2cbc AC |
25 | |
26 | val db = ref (NONE : C.conn option) | |
27 | val user = ref (NONE : user option) | |
28 | ||
ee587f7f AC |
29 | fun fromSql v = |
30 | if C.isNull v then | |
31 | "NULL" | |
32 | else | |
33 | C.stringFromSql v | |
34 | ||
35 | fun rowError (tab, vs) = raise Fail ("Bad " ^ tab ^ "row: " ^ makeSet fromSql vs) | |
36 | ||
208e2cbc AC |
37 | fun getDb () = valOf (!db) |
38 | ||
d5f8418b | 39 | fun mkUserRow [id, name, rname, bal, joined, app, shares, paypal, checkout] = |
208e2cbc | 40 | {id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname, |
f3f3ad24 | 41 | bal = C.intFromSql bal, joined = C.timestampFromSql joined, |
d5f8418b AC |
42 | app = C.intFromSql app, shares = C.intFromSql shares, |
43 | paypal = nullableFromSql C.stringFromSql paypal, | |
44 | checkout = nullableFromSql C.stringFromSql checkout} | |
ee587f7f | 45 | | mkUserRow row = rowError ("user", row) |
208e2cbc AC |
46 | |
47 | fun init () = | |
48 | let | |
9d1c0e98 AC |
49 | val _ = Util.init () |
50 | ||
208e2cbc AC |
51 | val c = conn () |
52 | in | |
f3f3ad24 | 53 | db := SOME c; |
208e2cbc AC |
54 | C.dml c "BEGIN"; |
55 | case Web.getCgi "REMOTE_USER" of | |
56 | NONE => raise Fail "Not logged in" | |
57 | | SOME name => | |
f660f7dd AC |
58 | let |
59 | val name = | |
60 | if String.isSuffix kerberosSuffix name then | |
61 | String.substring (name, 0, size name - size kerberosSuffix) | |
62 | else | |
63 | name | |
64 | in | |
d5f8418b | 65 | case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
f660f7dd AC |
66 | FROM WebUserActive |
67 | WHERE name=^(C.stringToSql name)`) of | |
68 | NONE => raise Fail "User not found" | |
69 | | SOME r => | |
70 | let | |
71 | val r = mkUserRow r | |
72 | in | |
73 | user := SOME r; | |
74 | case C.oneOrNoRows c ($`SELECT ipaddr | |
f3f3ad24 AC |
75 | FROM MemberApp |
76 | WHERE id = ^(C.intToSql (#app r)) | |
f660f7dd AC |
77 | AND ipaddr IS NOT NULL`) of |
78 | NONE => | |
79 | if Web.getParam "agree" = "on" then | |
80 | (case Web.getCgi "REMOTE_ADDR" of | |
81 | NONE => raise Fail "REMOTE_ADDR not set" | |
82 | | SOME ra => | |
83 | ignore (C.dml c ($`UPDATE MemberApp | |
f3f3ad24 | 84 | SET ipaddr = ^(C.stringToSql ra), |
f660f7dd AC |
85 | applied = CURRENT_TIMESTAMP |
86 | WHERE id = ^(C.intToSql (#app r))`))) | |
87 | else | |
88 | raise NeedTos | |
89 | | _ => () | |
90 | end | |
91 | end | |
208e2cbc AC |
92 | end |
93 | ||
94 | fun done () = | |
95 | let | |
96 | val db = getDb () | |
97 | in | |
98 | C.dml db "COMMIT"; | |
99 | close db | |
100 | end | |
101 | ||
102 | fun getUser () = valOf (!user) | |
103 | fun getUserId () = #id (getUser ()) | |
104 | fun getUserName () = #name (getUser ()) | |
105 | ||
106 | fun lookupUser id = | |
d5f8418b | 107 | mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
208e2cbc AC |
108 | FROM WebUser |
109 | WHERE id = ^(C.intToSql id)`)) | |
110 | ||
111 | fun listUsers () = | |
d5f8418b | 112 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
208e2cbc AC |
113 | FROM WebUser |
114 | ORDER BY name`) | |
115 | ||
60754922 | 116 | fun listActiveUsers () = |
d5f8418b | 117 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
60754922 AC |
118 | FROM WebUserActive |
119 | ORDER BY name`) | |
120 | ||
208e2cbc AC |
121 | fun nextSeq (db, seq) = |
122 | case C.oneRow db ($`SELECT nextval('^(seq)')`) of | |
ee587f7f | 123 | [id] => C.intFromSql id |
208e2cbc AC |
124 | | _ => raise Fail "Bad next sequence val" |
125 | ||
aaa50197 | 126 | fun addUser (name, rname, bal, app, shares) = |
208e2cbc AC |
127 | let |
128 | val db = getDb () | |
129 | val id = nextSeq (db, "WebUserSeq") | |
130 | in | |
2076f2da | 131 | C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined, app, shares, paypal, checkout) |
aaa50197 | 132 | VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal), |
2076f2da | 133 | CURRENT_TIMESTAMP, ^(C.intToSql app), ^(C.intToSql shares), |
7be17e39 AC |
134 | (SELECT paypal FROM MemberApp WHERE id = ^(C.intToSql app)), |
135 | (SELECT checkout FROM MemberApp WHERE id = ^(C.intToSql app)))`); | |
ee587f7f | 136 | id |
208e2cbc AC |
137 | end |
138 | ||
139 | fun modUser (user : user) = | |
140 | let | |
141 | val db = getDb () | |
142 | in | |
143 | ignore (C.dml db ($`UPDATE WebUser SET | |
144 | name = ^(C.stringToSql (#name user)), rname = ^(C.stringToSql (#rname user)), | |
aaa50197 | 145 | bal = ^(C.intToSql (#bal user)), app = ^(C.intToSql (#app user)), |
d5f8418b | 146 | shares = ^(C.intToSql (#shares user)), |
9953bee7 AC |
147 | paypal = ^(nullableToSql (C.stringToSql o Util.normEmail) (#paypal user)), |
148 | checkout = ^(nullableToSql (C.stringToSql o Util.normEmail) (#checkout user)) | |
208e2cbc AC |
149 | WHERE id = ^(C.intToSql (#id user))`)) |
150 | end | |
151 | ||
aaa50197 | 152 | fun byPledge () = |
d5f8418b | 153 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
466c5944 | 154 | FROM WebUserPaying |
aaa50197 | 155 | WHERE shares > 1 |
d90048bd | 156 | ORDER BY shares DESC, name`) |
aaa50197 | 157 | |
208e2cbc AC |
158 | fun deleteUser id = |
159 | C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`) | |
160 | ||
161 | fun validUsername name = | |
96bd398e | 162 | size name <= 12 |
03fc7566 AC |
163 | andalso size name > 0 |
164 | andalso Char.isLower (String.sub (name, 0)) | |
165 | andalso CharVector.all Char.isAlphaNum name | |
208e2cbc AC |
166 | |
167 | fun userNameToId name = | |
168 | case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebUser WHERE name = ^(C.stringToSql name)`) of | |
169 | SOME [id] => SOME (C.intFromSql id) | |
170 | | _ => NONE | |
171 | ||
98a5f121 AC |
172 | fun dateString () = |
173 | case C.oneRow (getDb ()) "SELECT CURRENT_DATE" of | |
174 | [d] => C.stringFromSql d | |
175 | | r => rowError ("dateString", r) | |
176 | ||
f3f3ad24 AC |
177 | fun grandfatherUsers () = |
178 | let | |
179 | val db = getDb () | |
180 | ||
181 | fun mkApp [id, name, rname] = | |
182 | let | |
183 | val id = C.intFromSql id | |
184 | val name = C.stringFromSql name | |
185 | val rname = C.stringFromSql rname | |
186 | ||
187 | val aid = nextSeq (db, "MemberAppSeq") | |
188 | in | |
189 | ignore (C.dml db ($`INSERT INTO MemberApp (id, name, rname, gname, email, forward, uses, other, | |
190 | passwd, status, applied, confirmed, decided, msg) | |
191 | VALUES (^(C.intToSql aid), ^(C.stringToSql name), ^(C.stringToSql rname), | |
93f77ca7 | 192 | NULL, '^name^(emailSuffix)', FALSE, 'GRANDFATHERED', 'GRANDFATHERED', |
f3f3ad24 AC |
193 | 'GRANDFATHERED', 4, CURRENT_TIMESTAMP, CURRENT_TIMESTAMP, |
194 | CURRENT_TIMESTAMP, 'GRANDFATHERED')`)); | |
195 | ignore (C.dml db ($`UPDATE WebUser SET app = ^(C.intToSql aid) WHERE id = ^(C.intToSql id)`)) | |
196 | end | |
197 | in | |
198 | C.app db mkApp "SELECT id, name, rname FROM WebUser WHERE app IS NULL" | |
199 | end | |
18eeb749 AC |
200 | |
201 | type node = {id : int, name : string, descr : string, debian : string} | |
202 | ||
203 | fun mkNodeRow [id, name, descr, debian] = | |
204 | {id = C.intFromSql id, name = C.stringFromSql name, descr = C.stringFromSql descr, | |
205 | debian = C.stringFromSql debian} | |
206 | | mkNodeRow row = rowError ("node", row) | |
207 | ||
208 | fun listNodes () = | |
209 | C.map (getDb ()) mkNodeRow ($`SELECT id, name, descr, debian | |
210 | FROM WebNode | |
ee252433 | 211 | WHERE id IN (SELECT id FROM ActiveWebNode) |
18eeb749 AC |
212 | ORDER BY name`) |
213 | ||
214 | fun nodeName id = | |
215 | case C.oneRow (getDb ()) ($`SELECT name | |
216 | FROM WebNode | |
217 | WHERE id = ^(C.intToSql id)`) of | |
218 | [name] => C.stringFromSql name | |
219 | | row => rowError ("nodeName", row) | |
220 | ||
221 | fun nodeDebian id = | |
222 | case C.oneRow (getDb ()) ($`SELECT debian | |
223 | FROM WebNode | |
224 | WHERE id = ^(C.intToSql id)`) of | |
225 | [debian] => C.stringFromSql debian | |
226 | | row => rowError ("nodeDebian", row) | |
227 | ||
30b8ceb4 AC |
228 | fun explain e = |
229 | case e of | |
230 | OS.SysErr (name, sop) => | |
231 | "System error: " ^ name ^ | |
232 | (case sop of | |
233 | NONE => "" | |
234 | | SOME syserr => ": " ^ OS.errorName syserr ^ ": " ^ OS.errorMsg syserr) | |
235 | | _ => "Unknown" | |
236 | ||
237 | fun tokens () = | |
238 | let | |
239 | val proc = Unix.execute ("/usr/bin/tokens", []) | |
240 | val inf = Unix.textInstreamOf proc | |
241 | ||
242 | fun reader acc = | |
243 | case TextIO.inputLine inf of | |
244 | NONE => String.concat (rev acc) | |
245 | | SOME s => reader (s :: acc) | |
246 | in | |
247 | reader [] | |
248 | before (TextIO.closeIn inf; | |
249 | ignore (Unix.reap proc)) | |
250 | end | |
251 | ||
252 | fun tokensForked () = | |
253 | case Posix.Process.fork () of | |
254 | NONE => (OS.Process.system "/usr/bin/tokens >/tmp/tokens.child"; | |
255 | OS.Process.exit OS.Process.success) | |
256 | | _ => ignore (OS.Process.system "/usr/bin/tokens >/tmp/tokens.parent") | |
257 | ||
60754922 AC |
258 | fun unmigratedUsers () = |
259 | List.filter (fn user => | |
260 | (ignore (Posix.SysDB.getpwnam (#name user)); | |
261 | false) | |
262 | handle OS.SysErr _ => true) (listActiveUsers ()) | |
263 | ||
59eb5381 AC |
264 | fun usersDiff (ls1, ls2) = |
265 | {onlyInFirst = List.filter (fn x => not (Util.mem (x, ls2))) ls1, | |
266 | onlyInSecond = List.filter (fn x => not (Util.mem (x, ls1))) ls2} | |
267 | ||
268 | fun listUsernames () = C.map (getDb ()) | |
269 | (fn [name] => C.stringFromSql name | |
270 | | row => rowError ("listUsernames", row)) | |
271 | "SELECT name FROM WebUserActive ORDER BY name" | |
272 | fun usersInAfs () = | |
273 | let | |
274 | fun explore (dir, level, acc) = | |
275 | if level = 3 then | |
276 | dir :: acc | |
277 | else | |
278 | let | |
279 | val dr = Posix.FileSys.opendir dir | |
280 | ||
281 | fun loop acc = | |
282 | case Posix.FileSys.readdir dr of | |
283 | NONE => acc | |
284 | | SOME name => | |
285 | let | |
286 | val dir' = OS.Path.joinDirFile {dir = dir, | |
287 | file = name} | |
288 | ||
289 | val acc = explore (dir', level+1, acc) | |
290 | in | |
291 | loop acc | |
292 | end | |
293 | in | |
294 | loop acc | |
295 | before Posix.FileSys.closedir dr | |
296 | end | |
297 | ||
298 | val acc = explore ("/afs/hcoop.net/user", 0, []) | |
299 | in | |
300 | List.map OS.Path.file acc | |
301 | end | |
302 | ||
d5f8418b AC |
303 | fun searchPaypal paypal = |
304 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout | |
305 | FROM WebUser | |
9953bee7 | 306 | WHERE paypal = ^(C.stringToSql (normEmail paypal)) |
d5f8418b AC |
307 | ORDER BY name`) |
308 | ||
309 | fun searchCheckout checkout = | |
310 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout | |
311 | FROM WebUser | |
9953bee7 | 312 | WHERE checkout = ^(C.stringToSql (normEmail checkout)) |
d5f8418b AC |
313 | ORDER BY name`) |
314 | ||
b1bb018a CE |
315 | fun searchRealName realname = |
316 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout | |
317 | FROM WebUser | |
29cabb75 | 318 | WHERE rname ILIKE (^(C.stringToSql "%") || trim (both ^(C.stringToSql " ") from ^(C.stringToSql realname)) || ^(C.stringToSql "%")) |
b1bb018a CE |
319 | ORDER BY name`) |
320 | ||
93f77ca7 | 321 | end |