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