20a679fc |
1 | structure App :> APP = |
2 | struct |
3 | |
4 | open Init Sql Util |
5 | |
6 | datatype status = |
7 | CONFIRMING |
8 | | PENDING |
9 | | ACCEPTED |
10 | | REJECTED |
453d7579 |
11 | | ADDED |
20a679fc |
12 | |
13 | val statusFromInt = |
14 | fn 0 => CONFIRMING |
15 | | 1 => PENDING |
16 | | 2 => ACCEPTED |
17 | | 3 => REJECTED |
453d7579 |
18 | | 4 => ADDED |
20a679fc |
19 | | _ => raise C.Sql "Bad status" |
20 | |
21 | val statusToInt = |
22 | fn CONFIRMING => 0 |
23 | | PENDING => 1 |
24 | | ACCEPTED => 2 |
25 | | REJECTED => 3 |
453d7579 |
26 | | ADDED => 4 |
20a679fc |
27 | |
28 | fun statusFromSql v = statusFromInt (C.intFromSql v) |
29 | fun statusToSql s = C.intToSql (statusToInt s) |
30 | |
5146e435 |
31 | type app = { id : int, name : string, rname : string, gname : string option, email : string, |
20a679fc |
32 | forward : bool, uses : string, other : string, |
5146e435 |
33 | passwd : string, status : status, applied : C.timestamp, ipaddr : string option, |
453d7579 |
34 | confirmed : C.timestamp option, decided : C.timestamp option, |
20acb925 |
35 | msg : string, unix_passwd : string, |
36 | paypal : string option, checkout : string option } |
20a679fc |
37 | |
5146e435 |
38 | fun mkAppRow [id, name, rname, gname, email, forward, uses, other, passwd, status, |
20acb925 |
39 | applied, ipaddr, confirmed, decided, msg, unix_passwd, paypal, checkout] = |
20a679fc |
40 | { id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname, |
20acb925 |
41 | gname = Init.nullableFromSql C.stringFromSql gname, |
20a679fc |
42 | email = C.stringFromSql email, forward = C.boolFromSql forward, |
43 | uses = C.stringFromSql uses, other = C.stringFromSql other, passwd = C.stringFromSql passwd, |
453d7579 |
44 | status = statusFromSql status, applied = C.timestampFromSql applied, |
20acb925 |
45 | ipaddr = Init.nullableFromSql C.stringFromSql ipaddr, |
46 | confirmed = Init.nullableFromSql C.timestampFromSql confirmed, |
47 | decided = Init.nullableFromSql C.timestampFromSql decided, |
48 | msg = C.stringFromSql msg, unix_passwd = C.stringFromSql unix_passwd, |
49 | paypal = Init.nullableFromSql C.stringFromSql paypal, |
50 | checkout = Init.nullableFromSql C.stringFromSql checkout} |
20a679fc |
51 | | mkAppRow r = rowError ("app", r) |
52 | |
53 | fun lookupApp id = |
8d550734 |
54 | case C.oneOrNoRows (getDb ()) ($`SELECT id, name, rname, gname, email, forward, uses, other, passwd, status, applied, ipaddr, confirmed, decided, |
20acb925 |
55 | msg, unix_passwd, paypal, checkout |
453d7579 |
56 | FROM MemberApp |
57 | WHERE id = ^(C.intToSql id)`) of |
20a679fc |
58 | SOME row => mkAppRow row |
59 | | NONE => raise Fail "Membership application not found" |
60 | |
4b8df0b1 |
61 | fun listApps status = |
8d550734 |
62 | C.map (getDb ()) mkAppRow ($`SELECT id, name, rname, gname, email, forward, uses, other, passwd, status, applied, ipaddr, confirmed, decided, |
20acb925 |
63 | msg, unix_passwd, paypal, checkout |
453d7579 |
64 | FROM MemberApp |
4b8df0b1 |
65 | WHERE status = ^(statusToSql status) |
b45f26c9 |
66 | AND NOT (status = 2 AND decided < CURRENT_TIMESTAMP - INTERVAL '1 MONTH') |
453d7579 |
67 | ORDER BY applied`) |
68 | |
69 | fun mkVoteRow [id, name] = (C.intFromSql id, C.stringFromSql name) |
70 | | mkVoteRow row = rowError ("app.vote", row) |
71 | |
72 | fun votes id = C.map (getDb ()) mkVoteRow ($`SELECT usr, name |
73 | FROM AppVote JOIN WebUser ON usr = id |
5146e435 |
74 | WHERE AppVote.app = ^(C.intToSql id) |
453d7579 |
75 | ORDER BY name`) |
76 | |
77 | fun vote (usr, app) = ignore (C.dml (getDb ()) ($`INSERT INTO AppVote (app, usr) |
78 | VALUES (^(C.intToSql app), ^(C.intToSql usr))`)) |
79 | |
80 | fun unvote (usr, app) = ignore (C.dml (getDb ()) ($`DELETE FROM AppVote WHERE app = ^(C.intToSql app) AND usr = ^(C.intToSql usr)`)) |
81 | |
82 | fun deny (app, msg) = |
83 | let |
84 | val entry = lookupApp app |
85 | val _ = C.dml (getDb ()) ($`UPDATE MemberApp |
86 | SET status = 3, msg = ^(C.stringToSql msg), decided = CURRENT_TIMESTAMP |
87 | WHERE id = ^(C.intToSql app)`) |
88 | |
89 | val mail = Mail.mopen () |
90 | in |
646dca75 |
91 | Mail.mwrite (mail, "From: Hcoop Application System <join"); |
92 | Mail.mwrite (mail, emailSuffix); |
93 | Mail.mwrite (mail, ">\nTo: "); |
453d7579 |
94 | Mail.mwrite (mail, #email entry); |
95 | Mail.mwrite (mail, "\nCc: "); |
96 | Mail.mwrite (mail, boardEmail); |
97 | Mail.mwrite (mail, "\nSubject: Application denied\n\nYour application for membership has been denied. Reason:\n\n"); |
98 | Mail.mwrite (mail, msg); |
99 | OS.Process.isSuccess (Mail.mclose mail) |
100 | end |
101 | |
102 | fun approve (app, msg) = |
103 | let |
104 | val entry = lookupApp app |
105 | val _ = C.dml (getDb ()) ($`UPDATE MemberApp |
106 | SET status = 2, msg = ^(C.stringToSql msg), decided = CURRENT_TIMESTAMP |
107 | WHERE id = ^(C.intToSql app)`) |
108 | |
109 | val mail = Mail.mopen () |
110 | in |
ce7b516a |
111 | Mail.mwrite (mail, "To: "); |
453d7579 |
112 | Mail.mwrite (mail, #email entry); |
ce7b516a |
113 | Mail.mwrite (mail, "\n"); |
114 | Mail.mwrite (mail, Util.readFile "/home/hcoop/portal/welcome.txt"); |
453d7579 |
115 | Mail.mwrite (mail, msg); |
116 | OS.Process.isSuccess (Mail.mclose mail) |
117 | end |
118 | |
4b8df0b1 |
119 | fun add app = |
cee714e2 |
120 | let |
121 | val _ = C.dml (getDb ()) ($`UPDATE MemberApp |
122 | SET status = 3 |
123 | WHERE id = ^(C.intToSql app)`) |
124 | |
125 | val app = lookupApp app |
126 | |
127 | val outf = TextIO.openOut (Config.passwordFiles ^ #name app) |
128 | in |
129 | TextIO.output (outf, #unix_passwd app); |
627fc76e |
130 | TextIO.output1 (outf, #"\n"); |
cee714e2 |
131 | TextIO.closeOut outf |
132 | end |
133 | |
134 | fun welcome app = |
135 | let |
136 | val app = lookupApp app |
137 | |
138 | val mail = Mail.mopen () |
139 | in |
140 | Mail.mwrite (mail, "To: "); |
141 | Mail.mwrite (mail, #email app); |
142 | Mail.mwrite (mail, "\n"); |
143 | Mail.mwrite (mail, Util.readFile "/home/hcoop/portal/paid.txt"); |
144 | ignore (Mail.mclose mail) |
145 | end |
4b8df0b1 |
146 | |
147 | fun abortAdd app = |
148 | ignore (C.dml (getDb ()) ($`UPDATE MemberApp |
149 | SET status = 2 |
150 | WHERE id = ^(C.intToSql app)`)) |
151 | |
5146e435 |
152 | fun readFile fname = |
153 | let |
154 | val inf = TextIO.openIn fname |
155 | |
156 | fun readLines lines = |
157 | case TextIO.inputLine inf of |
158 | NONE => String.concat (List.rev lines) |
159 | | SOME line => readLines (line :: lines) |
160 | in |
161 | readLines [] |
162 | before TextIO.closeIn inf |
163 | end |
164 | |
f038f26c |
165 | fun readTosBody () = readFile "/home/hcoop/public_html/tos.body.html" |
166 | fun readTosAgree () = readFile "/home/hcoop/public_html/tos.agree.html" |
167 | fun readTosMinorAgree () = readFile "/home/hcoop/public_html/tos.agree.minor.html" |
5146e435 |
168 | |
20acb925 |
169 | fun searchPaypal paypal = |
170 | C.map (getDb ()) mkAppRow ($`SELECT id, name, rname, gname, email, forward, uses, other, passwd, status, applied, ipaddr, confirmed, decided, |
171 | msg, unix_passwd, paypal, checkout |
172 | FROM MemberApp |
6ff384e9 |
173 | WHERE paypal = ^(C.stringToSql (normEmail paypal)) |
20acb925 |
174 | AND status = 2 |
175 | AND decided >= CURRENT_TIMESTAMP - INTERVAL '1 MONTH' |
176 | ORDER BY applied`) |
177 | |
178 | fun searchCheckout checkout = |
179 | C.map (getDb ()) mkAppRow ($`SELECT id, name, rname, gname, email, forward, uses, other, passwd, status, applied, ipaddr, confirmed, decided, |
180 | msg, unix_passwd, paypal, checkout |
181 | FROM MemberApp |
6ff384e9 |
182 | WHERE checkout = ^(C.stringToSql (normEmail checkout)) |
20acb925 |
183 | AND status = 2 |
184 | AND decided >= CURRENT_TIMESTAMP - INTERVAL '1 MONTH' |
185 | ORDER BY applied`) |
186 | |
646dca75 |
187 | end |