8d347a33 |
1 | structure Init :> INIT = |
2 | struct |
3 | |
9d313c5f |
4 | open Util Sql Config |
8d347a33 |
5 | structure C = PgClient |
6 | |
7 | exception Access of string |
5146e435 |
8 | exception NeedTos |
8d347a33 |
9 | |
9d313c5f |
10 | fun conn () = C.conn dbstring |
8d347a33 |
11 | val close = C.close |
12 | |
5146e435 |
13 | type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp, |
892e3ea1 |
14 | app : int, shares : int} |
8d347a33 |
15 | |
16 | val db = ref (NONE : C.conn option) |
17 | val user = ref (NONE : user option) |
18 | |
369e1577 |
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 | |
8d347a33 |
27 | fun getDb () = valOf (!db) |
28 | |
892e3ea1 |
29 | fun mkUserRow [id, name, rname, bal, joined, app, shares] = |
8d347a33 |
30 | {id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname, |
5146e435 |
31 | bal = C.intFromSql bal, joined = C.timestampFromSql joined, |
892e3ea1 |
32 | app = C.intFromSql app, shares = C.intFromSql shares} |
369e1577 |
33 | | mkUserRow row = rowError ("user", row) |
8d347a33 |
34 | |
35 | fun init () = |
36 | let |
78304862 |
37 | val _ = Util.init () |
38 | |
8d347a33 |
39 | val c = conn () |
40 | in |
5146e435 |
41 | db := SOME c; |
8d347a33 |
42 | C.dml c "BEGIN"; |
43 | case Web.getCgi "REMOTE_USER" of |
44 | NONE => raise Fail "Not logged in" |
45 | | SOME name => |
107a3ded |
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 |
5146e435 |
63 | FROM MemberApp |
64 | WHERE id = ^(C.intToSql (#app r)) |
107a3ded |
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 |
5146e435 |
72 | SET ipaddr = ^(C.stringToSql ra), |
107a3ded |
73 | applied = CURRENT_TIMESTAMP |
74 | WHERE id = ^(C.intToSql (#app r))`))) |
75 | else |
76 | raise NeedTos |
77 | | _ => () |
78 | end |
79 | end |
8d347a33 |
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 = |
892e3ea1 |
95 | mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined, app, shares |
8d347a33 |
96 | FROM WebUser |
97 | WHERE id = ^(C.intToSql id)`)) |
98 | |
99 | fun listUsers () = |
892e3ea1 |
100 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares |
8d347a33 |
101 | FROM WebUser |
102 | ORDER BY name`) |
103 | |
104 | fun nextSeq (db, seq) = |
105 | case C.oneRow db ($`SELECT nextval('^(seq)')`) of |
369e1577 |
106 | [id] => C.intFromSql id |
8d347a33 |
107 | | _ => raise Fail "Bad next sequence val" |
108 | |
892e3ea1 |
109 | fun addUser (name, rname, bal, app, shares) = |
8d347a33 |
110 | let |
111 | val db = getDb () |
112 | val id = nextSeq (db, "WebUserSeq") |
113 | in |
892e3ea1 |
114 | C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined, app, shares) |
115 | VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal), |
116 | CURRENT_TIMESTAMP, ^(C.intToSql app), ^(C.intToSql shares))`); |
369e1577 |
117 | id |
8d347a33 |
118 | end |
119 | |
120 | fun modUser (user : user) = |
121 | let |
122 | val db = getDb () |
123 | in |
124 | ignore (C.dml db ($`UPDATE WebUser SET |
125 | name = ^(C.stringToSql (#name user)), rname = ^(C.stringToSql (#rname user)), |
892e3ea1 |
126 | bal = ^(C.intToSql (#bal user)), app = ^(C.intToSql (#app user)), |
127 | shares = ^(C.intToSql (#shares user)) |
8d347a33 |
128 | WHERE id = ^(C.intToSql (#id user))`)) |
129 | end |
130 | |
892e3ea1 |
131 | fun byPledge () = |
132 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares |
133 | FROM WebUser |
134 | WHERE shares > 1 |
6bb84252 |
135 | ORDER BY shares DESC, name`) |
892e3ea1 |
136 | |
8d347a33 |
137 | fun deleteUser id = |
138 | C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`) |
139 | |
140 | fun validUsername name = |
141 | size name <= 10 |
09e213a2 |
142 | andalso size name > 0 |
143 | andalso Char.isLower (String.sub (name, 0)) |
144 | andalso CharVector.all Char.isAlphaNum name |
8d347a33 |
145 | |
146 | fun userNameToId name = |
147 | case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebUser WHERE name = ^(C.stringToSql name)`) of |
148 | SOME [id] => SOME (C.intFromSql id) |
149 | | _ => NONE |
150 | |
4b8df0b1 |
151 | fun dateString () = |
152 | case C.oneRow (getDb ()) "SELECT CURRENT_DATE" of |
153 | [d] => C.stringFromSql d |
154 | | r => rowError ("dateString", r) |
155 | |
5146e435 |
156 | fun grandfatherUsers () = |
157 | let |
158 | val db = getDb () |
159 | |
160 | fun mkApp [id, name, rname] = |
161 | let |
162 | val id = C.intFromSql id |
163 | val name = C.stringFromSql name |
164 | val rname = C.stringFromSql rname |
165 | |
166 | val aid = nextSeq (db, "MemberAppSeq") |
167 | in |
168 | ignore (C.dml db ($`INSERT INTO MemberApp (id, name, rname, gname, email, forward, uses, other, |
169 | passwd, status, applied, confirmed, decided, msg) |
170 | VALUES (^(C.intToSql aid), ^(C.stringToSql name), ^(C.stringToSql rname), |
646dca75 |
171 | NULL, '^name^(emailSuffix)', FALSE, 'GRANDFATHERED', 'GRANDFATHERED', |
5146e435 |
172 | 'GRANDFATHERED', 4, CURRENT_TIMESTAMP, CURRENT_TIMESTAMP, |
173 | CURRENT_TIMESTAMP, 'GRANDFATHERED')`)); |
174 | ignore (C.dml db ($`UPDATE WebUser SET app = ^(C.intToSql aid) WHERE id = ^(C.intToSql id)`)) |
175 | end |
176 | in |
177 | C.app db mkApp "SELECT id, name, rname FROM WebUser WHERE app IS NULL" |
178 | end |
8023de7b |
179 | |
180 | type node = {id : int, name : string, descr : string, debian : string} |
181 | |
182 | fun mkNodeRow [id, name, descr, debian] = |
183 | {id = C.intFromSql id, name = C.stringFromSql name, descr = C.stringFromSql descr, |
184 | debian = C.stringFromSql debian} |
185 | | mkNodeRow row = rowError ("node", row) |
186 | |
187 | fun listNodes () = |
188 | C.map (getDb ()) mkNodeRow ($`SELECT id, name, descr, debian |
189 | FROM WebNode |
190 | ORDER BY name`) |
191 | |
192 | fun nodeName id = |
193 | case C.oneRow (getDb ()) ($`SELECT name |
194 | FROM WebNode |
195 | WHERE id = ^(C.intToSql id)`) of |
196 | [name] => C.stringFromSql name |
197 | | row => rowError ("nodeName", row) |
198 | |
199 | fun nodeDebian id = |
200 | case C.oneRow (getDb ()) ($`SELECT debian |
201 | FROM WebNode |
202 | WHERE id = ^(C.intToSql id)`) of |
203 | [debian] => C.stringFromSql debian |
204 | | row => rowError ("nodeDebian", row) |
205 | |
1ec55b98 |
206 | fun explain e = |
207 | case e of |
208 | OS.SysErr (name, sop) => |
209 | "System error: " ^ name ^ |
210 | (case sop of |
211 | NONE => "" |
212 | | SOME syserr => ": " ^ OS.errorName syserr ^ ": " ^ OS.errorMsg syserr) |
213 | | _ => "Unknown" |
214 | |
215 | fun tokens () = |
216 | let |
217 | val proc = Unix.execute ("/usr/bin/tokens", []) |
218 | val inf = Unix.textInstreamOf proc |
219 | |
220 | fun reader acc = |
221 | case TextIO.inputLine inf of |
222 | NONE => String.concat (rev acc) |
223 | | SOME s => reader (s :: acc) |
224 | in |
225 | reader [] |
226 | before (TextIO.closeIn inf; |
227 | ignore (Unix.reap proc)) |
228 | end |
229 | |
230 | fun tokensForked () = |
231 | case Posix.Process.fork () of |
232 | NONE => (OS.Process.system "/usr/bin/tokens >/tmp/tokens.child"; |
233 | OS.Process.exit OS.Process.success) |
234 | | _ => ignore (OS.Process.system "/usr/bin/tokens >/tmp/tokens.parent") |
235 | |
646dca75 |
236 | end |