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