| 1 | structure Init :> INIT = |
| 2 | struct |
| 3 | |
| 4 | open Util Sql |
| 5 | structure C = PgClient |
| 6 | |
| 7 | exception Access of string |
| 8 | |
| 9 | fun conn () = C.conn "dbname='hcoop'" |
| 10 | val close = C.close |
| 11 | |
| 12 | type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp} |
| 13 | |
| 14 | val db = ref (NONE : C.conn option) |
| 15 | val user = ref (NONE : user option) |
| 16 | |
| 17 | fun getDb () = valOf (!db) |
| 18 | |
| 19 | fun mkUserRow [id, name, rname, bal, joined] = |
| 20 | {id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname, |
| 21 | bal = C.intFromSql bal, joined = C.timestampFromSql joined} |
| 22 | | mkUserRow row = raise Fail ("Bad user row : " ^ makeSet id row) |
| 23 | |
| 24 | fun init () = |
| 25 | let |
| 26 | val c = conn () |
| 27 | in |
| 28 | C.dml c "BEGIN"; |
| 29 | case Web.getCgi "REMOTE_USER" of |
| 30 | NONE => raise Fail "Not logged in" |
| 31 | | SOME name => |
| 32 | (case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined |
| 33 | FROM WebUser |
| 34 | WHERE name=^(C.stringToSql name)`) of |
| 35 | NONE => raise Fail "User not found" |
| 36 | | SOME r => user := SOME (mkUserRow r)); |
| 37 | db := SOME c |
| 38 | end |
| 39 | |
| 40 | fun done () = |
| 41 | let |
| 42 | val db = getDb () |
| 43 | in |
| 44 | C.dml db "COMMIT"; |
| 45 | close db |
| 46 | end |
| 47 | |
| 48 | fun getUser () = valOf (!user) |
| 49 | fun getUserId () = #id (getUser ()) |
| 50 | fun getUserName () = #name (getUser ()) |
| 51 | |
| 52 | fun lookupUser id = |
| 53 | mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined |
| 54 | FROM WebUser |
| 55 | WHERE id = ^(C.intToSql id)`)) |
| 56 | |
| 57 | fun listUsers () = |
| 58 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined |
| 59 | FROM WebUser |
| 60 | ORDER BY name`) |
| 61 | |
| 62 | fun nextSeq (db, seq) = |
| 63 | case C.oneRow db ($`SELECT nextval('^(seq)')`) of |
| 64 | [id] => id |
| 65 | | _ => raise Fail "Bad next sequence val" |
| 66 | |
| 67 | fun addUser (name, rname, bal) = |
| 68 | let |
| 69 | val db = getDb () |
| 70 | val id = nextSeq (db, "WebUserSeq") |
| 71 | in |
| 72 | C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined) |
| 73 | VALUES (^id, ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal), CURRENT_TIMESTAMP)`); |
| 74 | C.intFromSql id |
| 75 | end |
| 76 | |
| 77 | fun modUser (user : user) = |
| 78 | let |
| 79 | val db = getDb () |
| 80 | in |
| 81 | ignore (C.dml db ($`UPDATE WebUser SET |
| 82 | name = ^(C.stringToSql (#name user)), rname = ^(C.stringToSql (#rname user)), |
| 83 | bal = ^(C.intToSql (#bal user)) |
| 84 | WHERE id = ^(C.intToSql (#id user))`)) |
| 85 | end |
| 86 | |
| 87 | fun deleteUser id = |
| 88 | C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`) |
| 89 | |
| 90 | fun validUsername name = |
| 91 | size name <= 10 |
| 92 | andalso CharVector.all Char.isAlpha name |
| 93 | |
| 94 | fun userNameToId name = |
| 95 | case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebUser WHERE name = ^(C.stringToSql name)`) of |
| 96 | SOME [id] => SOME (C.intFromSql id) |
| 97 | | _ => NONE |
| 98 | |
| 99 | end |