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 | ||
7 | exception Access of string | |
f3f3ad24 | 8 | exception NeedTos |
208e2cbc | 9 | |
dda99898 | 10 | fun conn () = C.conn dbstring |
208e2cbc AC |
11 | val close = C.close |
12 | ||
f3f3ad24 | 13 | type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp, |
aaa50197 | 14 | app : int, shares : int} |
208e2cbc AC |
15 | |
16 | val db = ref (NONE : C.conn option) | |
17 | val user = ref (NONE : user option) | |
18 | ||
ee587f7f AC |
19 | fun fromSql v = |
20 | if C.isNull v then | |
21 | "NULL" | |
22 | else | |
23 | C.stringFromSql v | |
24 | ||
25 | fun rowError (tab, vs) = raise Fail ("Bad " ^ tab ^ "row: " ^ makeSet fromSql vs) | |
26 | ||
208e2cbc AC |
27 | fun getDb () = valOf (!db) |
28 | ||
aaa50197 | 29 | fun mkUserRow [id, name, rname, bal, joined, app, shares] = |
208e2cbc | 30 | {id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname, |
f3f3ad24 | 31 | bal = C.intFromSql bal, joined = C.timestampFromSql joined, |
aaa50197 | 32 | app = C.intFromSql app, shares = C.intFromSql shares} |
ee587f7f | 33 | | mkUserRow row = rowError ("user", row) |
208e2cbc AC |
34 | |
35 | fun init () = | |
36 | let | |
9d1c0e98 AC |
37 | val _ = Util.init () |
38 | ||
208e2cbc AC |
39 | val c = conn () |
40 | in | |
f3f3ad24 | 41 | db := SOME c; |
208e2cbc AC |
42 | C.dml c "BEGIN"; |
43 | case Web.getCgi "REMOTE_USER" of | |
44 | NONE => raise Fail "Not logged in" | |
45 | | SOME name => | |
f660f7dd AC |
46 | let |
47 | val name = | |
48 | if String.isSuffix kerberosSuffix name then | |
49 | String.substring (name, 0, size name - size kerberosSuffix) | |
50 | else | |
51 | name | |
52 | in | |
53 | case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined, app, shares | |
54 | FROM WebUserActive | |
55 | WHERE name=^(C.stringToSql name)`) of | |
56 | NONE => raise Fail "User not found" | |
57 | | SOME r => | |
58 | let | |
59 | val r = mkUserRow r | |
60 | in | |
61 | user := SOME r; | |
62 | case C.oneOrNoRows c ($`SELECT ipaddr | |
f3f3ad24 AC |
63 | FROM MemberApp |
64 | WHERE id = ^(C.intToSql (#app r)) | |
f660f7dd AC |
65 | AND ipaddr IS NOT NULL`) of |
66 | NONE => | |
67 | if Web.getParam "agree" = "on" then | |
68 | (case Web.getCgi "REMOTE_ADDR" of | |
69 | NONE => raise Fail "REMOTE_ADDR not set" | |
70 | | SOME ra => | |
71 | ignore (C.dml c ($`UPDATE MemberApp | |
f3f3ad24 | 72 | SET ipaddr = ^(C.stringToSql ra), |
f660f7dd AC |
73 | applied = CURRENT_TIMESTAMP |
74 | WHERE id = ^(C.intToSql (#app r))`))) | |
75 | else | |
76 | raise NeedTos | |
77 | | _ => () | |
78 | end | |
79 | end | |
208e2cbc AC |
80 | end |
81 | ||
82 | fun done () = | |
83 | let | |
84 | val db = getDb () | |
85 | in | |
86 | C.dml db "COMMIT"; | |
87 | close db | |
88 | end | |
89 | ||
90 | fun getUser () = valOf (!user) | |
91 | fun getUserId () = #id (getUser ()) | |
92 | fun getUserName () = #name (getUser ()) | |
93 | ||
94 | fun lookupUser id = | |
aaa50197 | 95 | mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined, app, shares |
208e2cbc AC |
96 | FROM WebUser |
97 | WHERE id = ^(C.intToSql id)`)) | |
98 | ||
99 | fun listUsers () = | |
aaa50197 | 100 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares |
208e2cbc AC |
101 | FROM WebUser |
102 | ORDER BY name`) | |
103 | ||
60754922 AC |
104 | fun listActiveUsers () = |
105 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares | |
106 | FROM WebUserActive | |
107 | ORDER BY name`) | |
108 | ||
208e2cbc AC |
109 | fun nextSeq (db, seq) = |
110 | case C.oneRow db ($`SELECT nextval('^(seq)')`) of | |
ee587f7f | 111 | [id] => C.intFromSql id |
208e2cbc AC |
112 | | _ => raise Fail "Bad next sequence val" |
113 | ||
aaa50197 | 114 | fun addUser (name, rname, bal, app, shares) = |
208e2cbc AC |
115 | let |
116 | val db = getDb () | |
117 | val id = nextSeq (db, "WebUserSeq") | |
118 | in | |
aaa50197 AC |
119 | C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined, app, shares) |
120 | VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal), | |
121 | CURRENT_TIMESTAMP, ^(C.intToSql app), ^(C.intToSql shares))`); | |
ee587f7f | 122 | id |
208e2cbc AC |
123 | end |
124 | ||
125 | fun modUser (user : user) = | |
126 | let | |
127 | val db = getDb () | |
128 | in | |
129 | ignore (C.dml db ($`UPDATE WebUser SET | |
130 | name = ^(C.stringToSql (#name user)), rname = ^(C.stringToSql (#rname user)), | |
aaa50197 AC |
131 | bal = ^(C.intToSql (#bal user)), app = ^(C.intToSql (#app user)), |
132 | shares = ^(C.intToSql (#shares user)) | |
208e2cbc AC |
133 | WHERE id = ^(C.intToSql (#id user))`)) |
134 | end | |
135 | ||
aaa50197 AC |
136 | fun byPledge () = |
137 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares | |
138 | FROM WebUser | |
139 | WHERE shares > 1 | |
d90048bd | 140 | ORDER BY shares DESC, name`) |
aaa50197 | 141 | |
208e2cbc AC |
142 | fun deleteUser id = |
143 | C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`) | |
144 | ||
145 | fun validUsername name = | |
146 | size name <= 10 | |
03fc7566 AC |
147 | andalso size name > 0 |
148 | andalso Char.isLower (String.sub (name, 0)) | |
149 | andalso CharVector.all Char.isAlphaNum name | |
208e2cbc AC |
150 | |
151 | fun userNameToId name = | |
152 | case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebUser WHERE name = ^(C.stringToSql name)`) of | |
153 | SOME [id] => SOME (C.intFromSql id) | |
154 | | _ => NONE | |
155 | ||
98a5f121 AC |
156 | fun dateString () = |
157 | case C.oneRow (getDb ()) "SELECT CURRENT_DATE" of | |
158 | [d] => C.stringFromSql d | |
159 | | r => rowError ("dateString", r) | |
160 | ||
f3f3ad24 AC |
161 | fun grandfatherUsers () = |
162 | let | |
163 | val db = getDb () | |
164 | ||
165 | fun mkApp [id, name, rname] = | |
166 | let | |
167 | val id = C.intFromSql id | |
168 | val name = C.stringFromSql name | |
169 | val rname = C.stringFromSql rname | |
170 | ||
171 | val aid = nextSeq (db, "MemberAppSeq") | |
172 | in | |
173 | ignore (C.dml db ($`INSERT INTO MemberApp (id, name, rname, gname, email, forward, uses, other, | |
174 | passwd, status, applied, confirmed, decided, msg) | |
175 | VALUES (^(C.intToSql aid), ^(C.stringToSql name), ^(C.stringToSql rname), | |
93f77ca7 | 176 | NULL, '^name^(emailSuffix)', FALSE, 'GRANDFATHERED', 'GRANDFATHERED', |
f3f3ad24 AC |
177 | 'GRANDFATHERED', 4, CURRENT_TIMESTAMP, CURRENT_TIMESTAMP, |
178 | CURRENT_TIMESTAMP, 'GRANDFATHERED')`)); | |
179 | ignore (C.dml db ($`UPDATE WebUser SET app = ^(C.intToSql aid) WHERE id = ^(C.intToSql id)`)) | |
180 | end | |
181 | in | |
182 | C.app db mkApp "SELECT id, name, rname FROM WebUser WHERE app IS NULL" | |
183 | end | |
18eeb749 AC |
184 | |
185 | type node = {id : int, name : string, descr : string, debian : string} | |
186 | ||
187 | fun mkNodeRow [id, name, descr, debian] = | |
188 | {id = C.intFromSql id, name = C.stringFromSql name, descr = C.stringFromSql descr, | |
189 | debian = C.stringFromSql debian} | |
190 | | mkNodeRow row = rowError ("node", row) | |
191 | ||
192 | fun listNodes () = | |
193 | C.map (getDb ()) mkNodeRow ($`SELECT id, name, descr, debian | |
194 | FROM WebNode | |
195 | ORDER BY name`) | |
196 | ||
197 | fun nodeName id = | |
198 | case C.oneRow (getDb ()) ($`SELECT name | |
199 | FROM WebNode | |
200 | WHERE id = ^(C.intToSql id)`) of | |
201 | [name] => C.stringFromSql name | |
202 | | row => rowError ("nodeName", row) | |
203 | ||
204 | fun nodeDebian id = | |
205 | case C.oneRow (getDb ()) ($`SELECT debian | |
206 | FROM WebNode | |
207 | WHERE id = ^(C.intToSql id)`) of | |
208 | [debian] => C.stringFromSql debian | |
209 | | row => rowError ("nodeDebian", row) | |
210 | ||
30b8ceb4 AC |
211 | fun explain e = |
212 | case e of | |
213 | OS.SysErr (name, sop) => | |
214 | "System error: " ^ name ^ | |
215 | (case sop of | |
216 | NONE => "" | |
217 | | SOME syserr => ": " ^ OS.errorName syserr ^ ": " ^ OS.errorMsg syserr) | |
218 | | _ => "Unknown" | |
219 | ||
220 | fun tokens () = | |
221 | let | |
222 | val proc = Unix.execute ("/usr/bin/tokens", []) | |
223 | val inf = Unix.textInstreamOf proc | |
224 | ||
225 | fun reader acc = | |
226 | case TextIO.inputLine inf of | |
227 | NONE => String.concat (rev acc) | |
228 | | SOME s => reader (s :: acc) | |
229 | in | |
230 | reader [] | |
231 | before (TextIO.closeIn inf; | |
232 | ignore (Unix.reap proc)) | |
233 | end | |
234 | ||
235 | fun tokensForked () = | |
236 | case Posix.Process.fork () of | |
237 | NONE => (OS.Process.system "/usr/bin/tokens >/tmp/tokens.child"; | |
238 | OS.Process.exit OS.Process.success) | |
239 | | _ => ignore (OS.Process.system "/usr/bin/tokens >/tmp/tokens.parent") | |
240 | ||
60754922 AC |
241 | fun unmigratedUsers () = |
242 | List.filter (fn user => | |
243 | (ignore (Posix.SysDB.getpwnam (#name user)); | |
244 | false) | |
245 | handle OS.SysErr _ => true) (listActiveUsers ()) | |
246 | ||
93f77ca7 | 247 | end |