8d347a33 |
1 | structure Init :> INIT = |
2 | struct |
3 | |
4 | open Util Sql |
5 | structure C = PgClient |
6 | |
7 | exception Access of string |
5146e435 |
8 | exception NeedTos |
8d347a33 |
9 | |
2eae496b |
10 | val urlPrefix = "http://users.hcoop.net/portal/" |
453d7579 |
11 | val boardEmail = "board.fake@hcoop.net" |
2eae496b |
12 | |
8d347a33 |
13 | fun conn () = C.conn "dbname='hcoop'" |
14 | val close = C.close |
15 | |
5146e435 |
16 | type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp, |
17 | app : int} |
8d347a33 |
18 | |
19 | val db = ref (NONE : C.conn option) |
20 | val user = ref (NONE : user option) |
21 | |
369e1577 |
22 | fun fromSql v = |
23 | if C.isNull v then |
24 | "NULL" |
25 | else |
26 | C.stringFromSql v |
27 | |
28 | fun rowError (tab, vs) = raise Fail ("Bad " ^ tab ^ "row: " ^ makeSet fromSql vs) |
29 | |
8d347a33 |
30 | fun getDb () = valOf (!db) |
31 | |
5146e435 |
32 | fun mkUserRow [id, name, rname, bal, joined, app] = |
8d347a33 |
33 | {id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname, |
5146e435 |
34 | bal = C.intFromSql bal, joined = C.timestampFromSql joined, |
35 | app = C.intFromSql app} |
369e1577 |
36 | | mkUserRow row = rowError ("user", row) |
8d347a33 |
37 | |
38 | fun init () = |
39 | let |
78304862 |
40 | val _ = Util.init () |
41 | |
8d347a33 |
42 | val c = conn () |
43 | in |
5146e435 |
44 | db := SOME c; |
8d347a33 |
45 | C.dml c "BEGIN"; |
46 | case Web.getCgi "REMOTE_USER" of |
47 | NONE => raise Fail "Not logged in" |
48 | | SOME name => |
5146e435 |
49 | (case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined, app |
8d347a33 |
50 | FROM WebUser |
51 | WHERE name=^(C.stringToSql name)`) of |
52 | NONE => raise Fail "User not found" |
5146e435 |
53 | | SOME r => |
54 | let |
55 | val r = mkUserRow r |
56 | in |
57 | user := SOME r; |
58 | case C.oneOrNoRows c ($`SELECT ipaddr |
59 | FROM MemberApp |
60 | WHERE id = ^(C.intToSql (#app r)) |
61 | AND ipaddr IS NOT NULL`) of |
62 | NONE => |
63 | if Web.getParam "agree" = "on" then |
64 | (case Web.getCgi "REMOTE_ADDR" of |
65 | NONE => raise Fail "REMOTE_ADDR not set" |
66 | | SOME ra => |
67 | ignore (C.dml c ($`UPDATE MemberApp |
68 | SET ipaddr = ^(C.stringToSql ra), |
69 | applied = CURRENT_TIMESTAMP |
70 | WHERE id = ^(C.intToSql (#app r))`))) |
71 | else |
72 | raise NeedTos |
73 | | _ => () |
74 | end) |
8d347a33 |
75 | end |
76 | |
77 | fun done () = |
78 | let |
79 | val db = getDb () |
80 | in |
81 | C.dml db "COMMIT"; |
82 | close db |
83 | end |
84 | |
85 | fun getUser () = valOf (!user) |
86 | fun getUserId () = #id (getUser ()) |
87 | fun getUserName () = #name (getUser ()) |
88 | |
89 | fun lookupUser id = |
5146e435 |
90 | mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined, app |
8d347a33 |
91 | FROM WebUser |
92 | WHERE id = ^(C.intToSql id)`)) |
93 | |
94 | fun listUsers () = |
5146e435 |
95 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app |
8d347a33 |
96 | FROM WebUser |
97 | ORDER BY name`) |
98 | |
99 | fun nextSeq (db, seq) = |
100 | case C.oneRow db ($`SELECT nextval('^(seq)')`) of |
369e1577 |
101 | [id] => C.intFromSql id |
8d347a33 |
102 | | _ => raise Fail "Bad next sequence val" |
103 | |
5146e435 |
104 | fun addUser (name, rname, bal, app) = |
8d347a33 |
105 | let |
106 | val db = getDb () |
107 | val id = nextSeq (db, "WebUserSeq") |
108 | in |
5146e435 |
109 | C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined, app) |
110 | VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal), CURRENT_TIMESTAMP, ^(C.intToSql app))`); |
369e1577 |
111 | id |
8d347a33 |
112 | end |
113 | |
114 | fun modUser (user : user) = |
115 | let |
116 | val db = getDb () |
117 | in |
118 | ignore (C.dml db ($`UPDATE WebUser SET |
119 | name = ^(C.stringToSql (#name user)), rname = ^(C.stringToSql (#rname user)), |
5146e435 |
120 | bal = ^(C.intToSql (#bal user)), app = ^(C.intToSql (#app user)) |
8d347a33 |
121 | WHERE id = ^(C.intToSql (#id user))`)) |
122 | end |
123 | |
124 | fun deleteUser id = |
125 | C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`) |
126 | |
127 | fun validUsername name = |
128 | size name <= 10 |
129 | andalso CharVector.all Char.isAlpha name |
130 | |
131 | fun userNameToId name = |
132 | case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebUser WHERE name = ^(C.stringToSql name)`) of |
133 | SOME [id] => SOME (C.intFromSql id) |
134 | | _ => NONE |
135 | |
4b8df0b1 |
136 | fun dateString () = |
137 | case C.oneRow (getDb ()) "SELECT CURRENT_DATE" of |
138 | [d] => C.stringFromSql d |
139 | | r => rowError ("dateString", r) |
140 | |
5146e435 |
141 | fun grandfatherUsers () = |
142 | let |
143 | val db = getDb () |
144 | |
145 | fun mkApp [id, name, rname] = |
146 | let |
147 | val id = C.intFromSql id |
148 | val name = C.stringFromSql name |
149 | val rname = C.stringFromSql rname |
150 | |
151 | val aid = nextSeq (db, "MemberAppSeq") |
152 | in |
153 | ignore (C.dml db ($`INSERT INTO MemberApp (id, name, rname, gname, email, forward, uses, other, |
154 | passwd, status, applied, confirmed, decided, msg) |
155 | VALUES (^(C.intToSql aid), ^(C.stringToSql name), ^(C.stringToSql rname), |
156 | NULL, '^name@hcoop.net', FALSE, 'GRANDFATHERED', 'GRANDFATHERED', |
157 | 'GRANDFATHERED', 4, CURRENT_TIMESTAMP, CURRENT_TIMESTAMP, |
158 | CURRENT_TIMESTAMP, 'GRANDFATHERED')`)); |
159 | ignore (C.dml db ($`UPDATE WebUser SET app = ^(C.intToSql aid) WHERE id = ^(C.intToSql id)`)) |
160 | end |
161 | in |
162 | C.app db mkApp "SELECT id, name, rname FROM WebUser WHERE app IS NULL" |
163 | end |
8d347a33 |
164 | end |