| 1 | structure Init :> INIT = |
| 2 | struct |
| 3 | |
| 4 | open Util Sql Config |
| 5 | structure C = PgClient |
| 6 | |
| 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 | |
| 17 | exception Access of string |
| 18 | exception NeedTos |
| 19 | |
| 20 | fun conn () = C.conn dbstring |
| 21 | val close = C.close |
| 22 | |
| 23 | type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp, |
| 24 | app : int, shares : int, paypal : string option, checkout : string option } |
| 25 | |
| 26 | val db = ref (NONE : C.conn option) |
| 27 | val user = ref (NONE : user option) |
| 28 | |
| 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 | |
| 37 | fun getDb () = valOf (!db) |
| 38 | |
| 39 | fun mkUserRow [id, name, rname, bal, joined, app, shares, paypal, checkout] = |
| 40 | {id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname, |
| 41 | bal = C.intFromSql bal, joined = C.timestampFromSql joined, |
| 42 | app = C.intFromSql app, shares = C.intFromSql shares, |
| 43 | paypal = nullableFromSql C.stringFromSql paypal, |
| 44 | checkout = nullableFromSql C.stringFromSql checkout} |
| 45 | | mkUserRow row = rowError ("user", row) |
| 46 | |
| 47 | fun init () = |
| 48 | let |
| 49 | val _ = Util.init () |
| 50 | |
| 51 | val c = conn () |
| 52 | in |
| 53 | db := SOME c; |
| 54 | C.dml c "BEGIN"; |
| 55 | case Web.getCgi "REMOTE_USER" of |
| 56 | NONE => raise Fail "Not logged in" |
| 57 | | SOME name => |
| 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 |
| 65 | case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
| 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 |
| 75 | FROM MemberApp |
| 76 | WHERE id = ^(C.intToSql (#app r)) |
| 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 |
| 84 | SET ipaddr = ^(C.stringToSql ra), |
| 85 | applied = CURRENT_TIMESTAMP |
| 86 | WHERE id = ^(C.intToSql (#app r))`))) |
| 87 | else |
| 88 | raise NeedTos |
| 89 | | _ => () |
| 90 | end |
| 91 | end |
| 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 = |
| 107 | mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
| 108 | FROM WebUser |
| 109 | WHERE id = ^(C.intToSql id)`)) |
| 110 | |
| 111 | fun listUsers () = |
| 112 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
| 113 | FROM WebUser |
| 114 | ORDER BY name`) |
| 115 | |
| 116 | fun listActiveUsers () = |
| 117 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
| 118 | FROM WebUserActive |
| 119 | ORDER BY name`) |
| 120 | |
| 121 | fun nextSeq (db, seq) = |
| 122 | case C.oneRow db ($`SELECT nextval('^(seq)')`) of |
| 123 | [id] => C.intFromSql id |
| 124 | | _ => raise Fail "Bad next sequence val" |
| 125 | |
| 126 | fun addUser (name, rname, bal, app, shares) = |
| 127 | let |
| 128 | val db = getDb () |
| 129 | val id = nextSeq (db, "WebUserSeq") |
| 130 | in |
| 131 | C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined, app, shares, paypal, checkout) |
| 132 | VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal), |
| 133 | CURRENT_TIMESTAMP, ^(C.intToSql app), ^(C.intToSql shares), |
| 134 | (SELECT paypal FROM MemberApp WHERE id = ^(C.intToSql app)), |
| 135 | (SELECT checkout FROM MemberApp WHERE id = ^(C.intToSql app)))`); |
| 136 | id |
| 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)), |
| 145 | bal = ^(C.intToSql (#bal user)), app = ^(C.intToSql (#app user)), |
| 146 | shares = ^(C.intToSql (#shares user)), |
| 147 | paypal = ^(nullableToSql (C.stringToSql o Util.normEmail) (#paypal user)), |
| 148 | checkout = ^(nullableToSql (C.stringToSql o Util.normEmail) (#checkout user)) |
| 149 | WHERE id = ^(C.intToSql (#id user))`)) |
| 150 | end |
| 151 | |
| 152 | fun byPledge () = |
| 153 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
| 154 | FROM WebUserPaying |
| 155 | WHERE shares > 1 |
| 156 | ORDER BY shares DESC, name`) |
| 157 | |
| 158 | fun deleteUser id = |
| 159 | C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`) |
| 160 | |
| 161 | fun validUsername name = |
| 162 | size name <= 12 |
| 163 | andalso size name > 0 |
| 164 | andalso Char.isLower (String.sub (name, 0)) |
| 165 | andalso CharVector.all Char.isAlphaNum name |
| 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 | |
| 172 | fun dateString () = |
| 173 | case C.oneRow (getDb ()) "SELECT CURRENT_DATE" of |
| 174 | [d] => C.stringFromSql d |
| 175 | | r => rowError ("dateString", r) |
| 176 | |
| 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), |
| 192 | NULL, '^name^(emailSuffix)', FALSE, 'GRANDFATHERED', 'GRANDFATHERED', |
| 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 |
| 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 | WHERE id IN (SELECT id FROM ActiveWebNode) |
| 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 | |
| 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 | |
| 258 | fun unmigratedUsers () = |
| 259 | List.filter (fn user => |
| 260 | (ignore (Posix.SysDB.getpwnam (#name user)); |
| 261 | false) |
| 262 | handle OS.SysErr _ => true) (listActiveUsers ()) |
| 263 | |
| 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 | |
| 303 | fun searchPaypal paypal = |
| 304 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
| 305 | FROM WebUser |
| 306 | WHERE paypal = ^(C.stringToSql (normEmail paypal)) |
| 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 |
| 312 | WHERE checkout = ^(C.stringToSql (normEmail checkout)) |
| 313 | ORDER BY name`) |
| 314 | |
| 315 | fun searchRealName realname = |
| 316 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
| 317 | FROM WebUser |
| 318 | WHERE rname ILIKE (^(C.stringToSql "%") || trim (both ^(C.stringToSql " ") from ^(C.stringToSql realname)) || ^(C.stringToSql "%")) |
| 319 | ORDER BY name`) |
| 320 | |
| 321 | end |