Commit | Line | Data |
---|---|---|
a90da8b1 AC |
1 | structure App :> APP = |
2 | struct | |
3 | ||
4 | open Init Sql Util | |
5 | ||
6 | datatype status = | |
7 | CONFIRMING | |
8 | | PENDING | |
9 | | ACCEPTED | |
10 | | REJECTED | |
6f91863c | 11 | | ADDED |
a90da8b1 AC |
12 | |
13 | val statusFromInt = | |
14 | fn 0 => CONFIRMING | |
15 | | 1 => PENDING | |
16 | | 2 => ACCEPTED | |
17 | | 3 => REJECTED | |
6f91863c | 18 | | 4 => ADDED |
a90da8b1 AC |
19 | | _ => raise C.Sql "Bad status" |
20 | ||
21 | val statusToInt = | |
22 | fn CONFIRMING => 0 | |
23 | | PENDING => 1 | |
24 | | ACCEPTED => 2 | |
25 | | REJECTED => 3 | |
6f91863c | 26 | | ADDED => 4 |
a90da8b1 AC |
27 | |
28 | fun statusFromSql v = statusFromInt (C.intFromSql v) | |
29 | fun statusToSql s = C.intToSql (statusToInt s) | |
30 | ||
f3f3ad24 | 31 | type app = { id : int, name : string, rname : string, gname : string option, email : string, |
a90da8b1 | 32 | forward : bool, uses : string, other : string, |
f3f3ad24 | 33 | passwd : string, status : status, applied : C.timestamp, ipaddr : string option, |
6f91863c | 34 | confirmed : C.timestamp option, decided : C.timestamp option, |
a2d53da2 | 35 | msg : string, unix_passwd : string} |
a90da8b1 | 36 | |
f3f3ad24 | 37 | fun mkAppRow [id, name, rname, gname, email, forward, uses, other, passwd, status, |
a2d53da2 | 38 | applied, ipaddr, confirmed, decided, msg, unix_passwd] = |
a90da8b1 | 39 | { id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname, |
f3f3ad24 | 40 | gname = (if C.isNull gname then NONE else SOME (C.stringFromSql gname)), |
a90da8b1 AC |
41 | email = C.stringFromSql email, forward = C.boolFromSql forward, |
42 | uses = C.stringFromSql uses, other = C.stringFromSql other, passwd = C.stringFromSql passwd, | |
6f91863c | 43 | status = statusFromSql status, applied = C.timestampFromSql applied, |
f3f3ad24 | 44 | ipaddr = (if C.isNull ipaddr then NONE else SOME (C.stringFromSql ipaddr)), |
6f91863c AC |
45 | confirmed = if C.isNull confirmed then NONE else SOME (C.timestampFromSql confirmed), |
46 | decided = if C.isNull decided then NONE else SOME (C.timestampFromSql decided), | |
a2d53da2 | 47 | msg = C.stringFromSql msg, unix_passwd = C.stringFromSql unix_passwd} |
a90da8b1 AC |
48 | | mkAppRow r = rowError ("app", r) |
49 | ||
50 | fun lookupApp id = | |
a2d53da2 AC |
51 | case C.oneOrNoRows (getDb ()) ($`SELECT id, name, rname, gname, email, forward, uses, other, passwd, status, applied, ipaddr, confirmed, decided, |
52 | msg, unix_passwd | |
6f91863c AC |
53 | FROM MemberApp |
54 | WHERE id = ^(C.intToSql id)`) of | |
a90da8b1 AC |
55 | SOME row => mkAppRow row |
56 | | NONE => raise Fail "Membership application not found" | |
57 | ||
98a5f121 | 58 | fun listApps status = |
a2d53da2 AC |
59 | C.map (getDb ()) mkAppRow ($`SELECT id, name, rname, gname, email, forward, uses, other, passwd, status, applied, ipaddr, confirmed, decided, |
60 | msg, unix_passwd | |
6f91863c | 61 | FROM MemberApp |
98a5f121 | 62 | WHERE status = ^(statusToSql status) |
38bfcd20 | 63 | AND NOT (status = 2 AND decided < CURRENT_TIMESTAMP - INTERVAL '1 MONTH') |
6f91863c AC |
64 | ORDER BY applied`) |
65 | ||
66 | fun mkVoteRow [id, name] = (C.intFromSql id, C.stringFromSql name) | |
67 | | mkVoteRow row = rowError ("app.vote", row) | |
68 | ||
69 | fun votes id = C.map (getDb ()) mkVoteRow ($`SELECT usr, name | |
70 | FROM AppVote JOIN WebUser ON usr = id | |
f3f3ad24 | 71 | WHERE AppVote.app = ^(C.intToSql id) |
6f91863c AC |
72 | ORDER BY name`) |
73 | ||
74 | fun vote (usr, app) = ignore (C.dml (getDb ()) ($`INSERT INTO AppVote (app, usr) | |
75 | VALUES (^(C.intToSql app), ^(C.intToSql usr))`)) | |
76 | ||
77 | fun unvote (usr, app) = ignore (C.dml (getDb ()) ($`DELETE FROM AppVote WHERE app = ^(C.intToSql app) AND usr = ^(C.intToSql usr)`)) | |
78 | ||
79 | fun deny (app, msg) = | |
80 | let | |
81 | val entry = lookupApp app | |
82 | val _ = C.dml (getDb ()) ($`UPDATE MemberApp | |
83 | SET status = 3, msg = ^(C.stringToSql msg), decided = CURRENT_TIMESTAMP | |
84 | WHERE id = ^(C.intToSql app)`) | |
85 | ||
86 | val mail = Mail.mopen () | |
87 | in | |
93f77ca7 AC |
88 | Mail.mwrite (mail, "From: Hcoop Application System <join"); |
89 | Mail.mwrite (mail, emailSuffix); | |
90 | Mail.mwrite (mail, ">\nTo: "); | |
6f91863c AC |
91 | Mail.mwrite (mail, #email entry); |
92 | Mail.mwrite (mail, "\nCc: "); | |
93 | Mail.mwrite (mail, boardEmail); | |
94 | Mail.mwrite (mail, "\nSubject: Application denied\n\nYour application for membership has been denied. Reason:\n\n"); | |
95 | Mail.mwrite (mail, msg); | |
96 | OS.Process.isSuccess (Mail.mclose mail) | |
97 | end | |
98 | ||
99 | fun approve (app, msg) = | |
100 | let | |
101 | val entry = lookupApp app | |
102 | val _ = C.dml (getDb ()) ($`UPDATE MemberApp | |
103 | SET status = 2, msg = ^(C.stringToSql msg), decided = CURRENT_TIMESTAMP | |
104 | WHERE id = ^(C.intToSql app)`) | |
105 | ||
106 | val mail = Mail.mopen () | |
107 | in | |
b90b0980 | 108 | Mail.mwrite (mail, "To: "); |
6f91863c | 109 | Mail.mwrite (mail, #email entry); |
b90b0980 AC |
110 | Mail.mwrite (mail, "\n"); |
111 | Mail.mwrite (mail, Util.readFile "/home/hcoop/portal/welcome.txt"); | |
6f91863c AC |
112 | Mail.mwrite (mail, msg); |
113 | OS.Process.isSuccess (Mail.mclose mail) | |
114 | end | |
115 | ||
98a5f121 AC |
116 | fun add app = |
117 | ignore (C.dml (getDb ()) ($`UPDATE MemberApp | |
118 | SET status = 3 | |
119 | WHERE id = ^(C.intToSql app)`)) | |
120 | ||
121 | fun abortAdd app = | |
122 | ignore (C.dml (getDb ()) ($`UPDATE MemberApp | |
123 | SET status = 2 | |
124 | WHERE id = ^(C.intToSql app)`)) | |
125 | ||
f3f3ad24 AC |
126 | fun readFile fname = |
127 | let | |
128 | val inf = TextIO.openIn fname | |
129 | ||
130 | fun readLines lines = | |
131 | case TextIO.inputLine inf of | |
132 | NONE => String.concat (List.rev lines) | |
133 | | SOME line => readLines (line :: lines) | |
134 | in | |
135 | readLines [] | |
136 | before TextIO.closeIn inf | |
137 | end | |
138 | ||
37cec107 AC |
139 | fun readTosBody () = readFile "/home/hcoop/public_html/tos.body.html" |
140 | fun readTosAgree () = readFile "/home/hcoop/public_html/tos.agree.html" | |
141 | fun readTosMinorAgree () = readFile "/home/hcoop/public_html/tos.agree.minor.html" | |
f3f3ad24 | 142 | |
93f77ca7 | 143 | end |