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