Join script should rule out retired usernames
[bpt/portal.git] / init.sml
CommitLineData
208e2cbc
AC
1structure Init :> INIT =
2struct
3
dda99898 4open Util Sql Config
208e2cbc
AC
5structure C = PgClient
6
d5f8418b
AC
7fun nullableFromSql f x =
8 if C.isNull x then
9 NONE
10 else
11 SOME (f x)
12fun nullableToSql f x =
13 case x of
14 NONE => "NULL"
15 | SOME x => f x
16
208e2cbc 17exception Access of string
f3f3ad24 18exception NeedTos
208e2cbc 19
dda99898 20fun conn () = C.conn dbstring
208e2cbc
AC
21val close = C.close
22
f3f3ad24 23type 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
26val db = ref (NONE : C.conn option)
27val user = ref (NONE : user option)
28
ee587f7f
AC
29fun fromSql v =
30 if C.isNull v then
31 "NULL"
32 else
33 C.stringFromSql v
34
35fun rowError (tab, vs) = raise Fail ("Bad " ^ tab ^ "row: " ^ makeSet fromSql vs)
36
208e2cbc
AC
37fun getDb () = valOf (!db)
38
d5f8418b 39fun 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
47fun 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
94fun done () =
95 let
96 val db = getDb ()
97 in
98 C.dml db "COMMIT";
99 close db
100 end
101
102fun getUser () = valOf (!user)
103fun getUserId () = #id (getUser ())
104fun getUserName () = #name (getUser ())
105
106fun 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
111fun 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 116fun 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
121fun 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 126fun 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
139fun 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 152fun 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
158fun deleteUser id =
159 C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`)
160
161fun 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
167fun 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
172fun dateString () =
173 case C.oneRow (getDb ()) "SELECT CURRENT_DATE" of
174 [d] => C.stringFromSql d
175 | r => rowError ("dateString", r)
176
f3f3ad24
AC
177fun 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
201type node = {id : int, name : string, descr : string, debian : string}
202
203fun 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
208fun listNodes () =
209 C.map (getDb ()) mkNodeRow ($`SELECT id, name, descr, debian
210 FROM WebNode
211 ORDER BY name`)
212
213fun 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
220fun 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
30b8ceb4
AC
227fun 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
236fun 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
251fun 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
60754922
AC
257fun unmigratedUsers () =
258 List.filter (fn user =>
259 (ignore (Posix.SysDB.getpwnam (#name user));
260 false)
261 handle OS.SysErr _ => true) (listActiveUsers ())
262
59eb5381
AC
263fun 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
267fun listUsernames () = C.map (getDb ())
268 (fn [name] => C.stringFromSql name
269 | row => rowError ("listUsernames", row))
270 "SELECT name FROM WebUserActive ORDER BY name"
271fun 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
d5f8418b
AC
302fun searchPaypal paypal =
303 C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
304 FROM WebUser
9953bee7 305 WHERE paypal = ^(C.stringToSql (normEmail paypal))
d5f8418b
AC
306 ORDER BY name`)
307
308fun searchCheckout checkout =
309 C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
310 FROM WebUser
9953bee7 311 WHERE checkout = ^(C.stringToSql (normEmail checkout))
d5f8418b
AC
312 ORDER BY name`)
313
93f77ca7 314end