8d347a33 |
1 | structure Init :> INIT = |
2 | struct |
3 | |
9d313c5f |
4 | open Util Sql Config |
8d347a33 |
5 | structure C = PgClient |
6 | |
20acb925 |
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 | |
8d347a33 |
17 | exception Access of string |
5146e435 |
18 | exception NeedTos |
8d347a33 |
19 | |
9d313c5f |
20 | fun conn () = C.conn dbstring |
8d347a33 |
21 | val close = C.close |
22 | |
5146e435 |
23 | type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp, |
20acb925 |
24 | app : int, shares : int, paypal : string option, checkout : string option } |
8d347a33 |
25 | |
26 | val db = ref (NONE : C.conn option) |
27 | val user = ref (NONE : user option) |
28 | |
369e1577 |
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 | |
8d347a33 |
37 | fun getDb () = valOf (!db) |
38 | |
20acb925 |
39 | fun mkUserRow [id, name, rname, bal, joined, app, shares, paypal, checkout] = |
8d347a33 |
40 | {id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname, |
5146e435 |
41 | bal = C.intFromSql bal, joined = C.timestampFromSql joined, |
20acb925 |
42 | app = C.intFromSql app, shares = C.intFromSql shares, |
43 | paypal = nullableFromSql C.stringFromSql paypal, |
44 | checkout = nullableFromSql C.stringFromSql checkout} |
369e1577 |
45 | | mkUserRow row = rowError ("user", row) |
8d347a33 |
46 | |
47 | fun init () = |
48 | let |
78304862 |
49 | val _ = Util.init () |
50 | |
8d347a33 |
51 | val c = conn () |
52 | in |
5146e435 |
53 | db := SOME c; |
8d347a33 |
54 | C.dml c "BEGIN"; |
55 | case Web.getCgi "REMOTE_USER" of |
56 | NONE => raise Fail "Not logged in" |
57 | | SOME name => |
107a3ded |
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 |
20acb925 |
65 | case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
107a3ded |
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 |
5146e435 |
75 | FROM MemberApp |
76 | WHERE id = ^(C.intToSql (#app r)) |
107a3ded |
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 |
5146e435 |
84 | SET ipaddr = ^(C.stringToSql ra), |
107a3ded |
85 | applied = CURRENT_TIMESTAMP |
86 | WHERE id = ^(C.intToSql (#app r))`))) |
87 | else |
88 | raise NeedTos |
89 | | _ => () |
90 | end |
91 | end |
8d347a33 |
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 = |
20acb925 |
107 | mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
8d347a33 |
108 | FROM WebUser |
109 | WHERE id = ^(C.intToSql id)`)) |
110 | |
111 | fun listUsers () = |
20acb925 |
112 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
8d347a33 |
113 | FROM WebUser |
114 | ORDER BY name`) |
115 | |
da3f3cbc |
116 | fun listActiveUsers () = |
20acb925 |
117 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
da3f3cbc |
118 | FROM WebUserActive |
119 | ORDER BY name`) |
120 | |
8d347a33 |
121 | fun nextSeq (db, seq) = |
122 | case C.oneRow db ($`SELECT nextval('^(seq)')`) of |
369e1577 |
123 | [id] => C.intFromSql id |
8d347a33 |
124 | | _ => raise Fail "Bad next sequence val" |
125 | |
892e3ea1 |
126 | fun addUser (name, rname, bal, app, shares) = |
8d347a33 |
127 | let |
128 | val db = getDb () |
129 | val id = nextSeq (db, "WebUserSeq") |
130 | in |
6b8e4094 |
131 | C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined, app, shares, paypal, checkout) |
892e3ea1 |
132 | VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal), |
6b8e4094 |
133 | CURRENT_TIMESTAMP, ^(C.intToSql app), ^(C.intToSql shares), |
134 | (SELECT paypal FROM MemberApp WHERE app = ^(C.intToSql app)), |
135 | (SELECT checkout FROM MemberApp WHERE app = ^(C.intToSql app)))`); |
369e1577 |
136 | id |
8d347a33 |
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)), |
892e3ea1 |
145 | bal = ^(C.intToSql (#bal user)), app = ^(C.intToSql (#app user)), |
20acb925 |
146 | shares = ^(C.intToSql (#shares user)), |
6ff384e9 |
147 | paypal = ^(nullableToSql (C.stringToSql o Util.normEmail) (#paypal user)), |
148 | checkout = ^(nullableToSql (C.stringToSql o Util.normEmail) (#checkout user)) |
8d347a33 |
149 | WHERE id = ^(C.intToSql (#id user))`)) |
150 | end |
151 | |
892e3ea1 |
152 | fun byPledge () = |
20acb925 |
153 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
892e3ea1 |
154 | FROM WebUser |
155 | WHERE shares > 1 |
6bb84252 |
156 | ORDER BY shares DESC, name`) |
892e3ea1 |
157 | |
8d347a33 |
158 | fun deleteUser id = |
159 | C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`) |
160 | |
161 | fun validUsername name = |
162 | size name <= 10 |
09e213a2 |
163 | andalso size name > 0 |
164 | andalso Char.isLower (String.sub (name, 0)) |
165 | andalso CharVector.all Char.isAlphaNum name |
8d347a33 |
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 | |
4b8df0b1 |
172 | fun dateString () = |
173 | case C.oneRow (getDb ()) "SELECT CURRENT_DATE" of |
174 | [d] => C.stringFromSql d |
175 | | r => rowError ("dateString", r) |
176 | |
5146e435 |
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), |
646dca75 |
192 | NULL, '^name^(emailSuffix)', FALSE, 'GRANDFATHERED', 'GRANDFATHERED', |
5146e435 |
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 |
8023de7b |
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 |
211 | ORDER BY name`) |
212 | |
213 | fun nodeName id = |
214 | case C.oneRow (getDb ()) ($`SELECT name |
215 | FROM WebNode |
216 | WHERE id = ^(C.intToSql id)`) of |
217 | [name] => C.stringFromSql name |
218 | | row => rowError ("nodeName", row) |
219 | |
220 | fun nodeDebian id = |
221 | case C.oneRow (getDb ()) ($`SELECT debian |
222 | FROM WebNode |
223 | WHERE id = ^(C.intToSql id)`) of |
224 | [debian] => C.stringFromSql debian |
225 | | row => rowError ("nodeDebian", row) |
226 | |
1ec55b98 |
227 | fun explain e = |
228 | case e of |
229 | OS.SysErr (name, sop) => |
230 | "System error: " ^ name ^ |
231 | (case sop of |
232 | NONE => "" |
233 | | SOME syserr => ": " ^ OS.errorName syserr ^ ": " ^ OS.errorMsg syserr) |
234 | | _ => "Unknown" |
235 | |
236 | fun tokens () = |
237 | let |
238 | val proc = Unix.execute ("/usr/bin/tokens", []) |
239 | val inf = Unix.textInstreamOf proc |
240 | |
241 | fun reader acc = |
242 | case TextIO.inputLine inf of |
243 | NONE => String.concat (rev acc) |
244 | | SOME s => reader (s :: acc) |
245 | in |
246 | reader [] |
247 | before (TextIO.closeIn inf; |
248 | ignore (Unix.reap proc)) |
249 | end |
250 | |
251 | fun tokensForked () = |
252 | case Posix.Process.fork () of |
253 | NONE => (OS.Process.system "/usr/bin/tokens >/tmp/tokens.child"; |
254 | OS.Process.exit OS.Process.success) |
255 | | _ => ignore (OS.Process.system "/usr/bin/tokens >/tmp/tokens.parent") |
256 | |
da3f3cbc |
257 | fun unmigratedUsers () = |
258 | List.filter (fn user => |
259 | (ignore (Posix.SysDB.getpwnam (#name user)); |
260 | false) |
261 | handle OS.SysErr _ => true) (listActiveUsers ()) |
262 | |
9fe97917 |
263 | fun usersDiff (ls1, ls2) = |
264 | {onlyInFirst = List.filter (fn x => not (Util.mem (x, ls2))) ls1, |
265 | onlyInSecond = List.filter (fn x => not (Util.mem (x, ls1))) ls2} |
266 | |
267 | fun listUsernames () = C.map (getDb ()) |
268 | (fn [name] => C.stringFromSql name |
269 | | row => rowError ("listUsernames", row)) |
270 | "SELECT name FROM WebUserActive ORDER BY name" |
271 | fun usersInAfs () = |
272 | let |
273 | fun explore (dir, level, acc) = |
274 | if level = 3 then |
275 | dir :: acc |
276 | else |
277 | let |
278 | val dr = Posix.FileSys.opendir dir |
279 | |
280 | fun loop acc = |
281 | case Posix.FileSys.readdir dr of |
282 | NONE => acc |
283 | | SOME name => |
284 | let |
285 | val dir' = OS.Path.joinDirFile {dir = dir, |
286 | file = name} |
287 | |
288 | val acc = explore (dir', level+1, acc) |
289 | in |
290 | loop acc |
291 | end |
292 | in |
293 | loop acc |
294 | before Posix.FileSys.closedir dr |
295 | end |
296 | |
297 | val acc = explore ("/afs/hcoop.net/user", 0, []) |
298 | in |
299 | List.map OS.Path.file acc |
300 | end |
301 | |
20acb925 |
302 | fun searchPaypal paypal = |
303 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
304 | FROM WebUser |
6ff384e9 |
305 | WHERE paypal = ^(C.stringToSql (normEmail paypal)) |
20acb925 |
306 | ORDER BY name`) |
307 | |
308 | fun searchCheckout checkout = |
309 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
310 | FROM WebUser |
6ff384e9 |
311 | WHERE checkout = ^(C.stringToSql (normEmail checkout)) |
20acb925 |
312 | ORDER BY name`) |
313 | |
646dca75 |
314 | end |