21 | _
=> raise C
.Sql
"Bad status"
31 fun statusFromSql v
= statusFromInt (C
.intFromSql v
)
32 fun statusToSql s
= C
.intToSql (statusToInt s
)
34 type app
= { id
: int, name
: string, rname
: string, gname
: string option
, email
: string,
35 forward
: bool, uses
: string, other
: string,
36 passwd
: string, status
: status
, applied
: C
.timestamp
, ipaddr
: string option
,
37 confirmed
: C
.timestamp option
, decided
: C
.timestamp option
,
38 msg
: string, unix_passwd
: string,
39 paypal
: string option
, checkout
: string option
}
41 fun mkAppRow
[id
, name
, rname
, gname
, email
, forward
, uses
, other
, passwd
, status
,
42 applied
, ipaddr
, confirmed
, decided
, msg
, unix_passwd
, paypal
, checkout
] =
43 { id
= C
.intFromSql id
, name
= C
.stringFromSql name
, rname
= C
.stringFromSql rname
,
44 gname
= Init
.nullableFromSql C
.stringFromSql gname
,
45 email
= C
.stringFromSql email
, forward
= C
.boolFromSql forward
,
46 uses
= C
.stringFromSql uses
, other
= C
.stringFromSql other
, passwd
= C
.stringFromSql passwd
,
47 status
= statusFromSql status
, applied
= C
.timestampFromSql applied
,
48 ipaddr
= Init
.nullableFromSql C
.stringFromSql ipaddr
,
49 confirmed
= Init
.nullableFromSql C
.timestampFromSql confirmed
,
50 decided
= Init
.nullableFromSql C
.timestampFromSql decided
,
51 msg
= C
.stringFromSql msg
, unix_passwd
= C
.stringFromSql unix_passwd
,
52 paypal
= Init
.nullableFromSql C
.stringFromSql paypal
,
53 checkout
= Init
.nullableFromSql C
.stringFromSql checkout
}
54 | mkAppRow r
= rowError ("app", r
)
57 case C
.oneOrNoRows (getDb ()) ($`SELECT id
, name
, rname
, gname
, email
, forward
, uses
, other
, passwd
, status
, applied
, ipaddr
, confirmed
, decided
,
58 msg
, unix_passwd
, paypal
, checkout
60 WHERE id
= ^
(C
.intToSql id
)`
) of
61 SOME row
=> mkAppRow row
62 | NONE
=> raise Fail
"Membership application not found"
64 fun listApps statuses
=
65 C
.map (getDb ()) mkAppRow ($`SELECT id
, name
, rname
, gname
, email
, forward
, uses
, other
, passwd
, status
, applied
, ipaddr
, confirmed
, decided
,
66 msg
, unix_passwd
, paypal
, checkout
68 WHERE status
IN (^
(String.concatWith
"," (map statusToSql statuses
)))
69 AND
NOT (status
= 2 AND decided
< CURRENT_TIMESTAMP
- INTERVAL
'1 MONTH
')
72 fun mkVoteRow
[id
, name
] = (C
.intFromSql id
, C
.stringFromSql name
)
73 | mkVoteRow row
= rowError ("app.vote", row
)
75 fun votes id
= C
.map (getDb ()) mkVoteRow ($`SELECT usr
, name
76 FROM AppVote JOIN WebUser ON usr
= id
77 WHERE AppVote
.app
= ^
(C
.intToSql id
)
80 fun vote (usr
, app
) = ignore (C
.dml (getDb ()) ($`INSERT INTO
AppVote (app
, usr
)
81 VALUES (^
(C
.intToSql app
), ^
(C
.intToSql usr
))`
))
83 fun unvote (usr
, app
) = ignore (C
.dml (getDb ()) ($`DELETE FROM AppVote WHERE app
= ^
(C
.intToSql app
) AND usr
= ^
(C
.intToSql usr
)`
))
87 val entry
= lookupApp app
88 val _
= C
.dml (getDb ()) ($`UPDATE MemberApp
89 SET status
= 3, msg
= ^
(C
.stringToSql msg
), decided
= CURRENT_TIMESTAMP
90 WHERE id
= ^
(C
.intToSql app
)`
)
92 val mail
= Mail
.mopen ()
94 Mail
.mwrite (mail
, "From: Hcoop Application System <join");
95 Mail
.mwrite (mail
, emailSuffix
);
96 Mail
.mwrite (mail
, ">\nTo: ");
97 Mail
.mwrite (mail
, #email entry
);
98 Mail
.mwrite (mail
, "\nCc: ");
99 Mail
.mwrite (mail
, boardEmail
);
100 Mail
.mwrite (mail
, "\nSubject: Application denied\n\nYour application for membership has been denied. Reason:\n\n");
101 Mail
.mwrite (mail
, msg
);
102 OS
.Process
.isSuccess (Mail
.mclose mail
)
105 fun approve (app
, msg
) =
107 val entry
= lookupApp app
108 val _
= C
.dml (getDb ()) ($`UPDATE MemberApp
109 SET status
= 2, msg
= ^
(C
.stringToSql msg
), decided
= CURRENT_TIMESTAMP
110 WHERE id
= ^
(C
.intToSql app
)`
)
112 val mail
= Mail
.mopen ()
114 Mail
.mwrite (mail
, "To: ");
115 Mail
.mwrite (mail
, #email entry
);
116 Mail
.mwrite (mail
, "\n");
117 Mail
.mwrite (mail
, Util
.readFile
"/home/hcoop/portal/welcome.txt");
118 Mail
.mwrite (mail
, msg
);
119 OS
.Process
.isSuccess (Mail
.mclose mail
)
124 val _
= C
.dml (getDb ()) ($`UPDATE MemberApp
126 WHERE id
= ^
(C
.intToSql app
)`
)
128 val app
= lookupApp app
130 val outf
= TextIO.openOut (Config
.passwordFiles ^ #name app
)
132 TextIO.output (outf
, #unix_passwd app
);
133 TextIO.output1 (outf
, #
"\n");
139 val appR
= lookupApp app
141 ignore (C
.dml (getDb ()) ($`UPDATE MemberApp
143 WHERE id
= ^
(C
.intToSql app
)`
));
144 OS
.FileSys
.remove (Config
.passwordFiles ^ #name appR
)
149 val app
= lookupApp app
151 val mail
= Mail
.mopen ()
153 Mail
.mwrite (mail
, "To: ");
154 Mail
.mwrite (mail
, #email app
);
155 Mail
.mwrite (mail
, "\n");
156 Mail
.mwrite (mail
, Util
.readFile
"/home/hcoop/portal/paid.txt");
157 ignore (Mail
.mclose mail
)
161 ignore (C
.dml (getDb ()) ($`UPDATE MemberApp
163 WHERE id
= ^
(C
.intToSql app
)`
))
167 val inf
= TextIO.openIn fname
169 fun readLines lines
=
170 case TextIO.inputLine inf
of
171 NONE
=> String.concat (List.rev lines
)
172 | SOME line
=> readLines (line
:: lines
)
175 before TextIO.closeIn inf
178 fun readTosBody () = readFile
"/home/hcoop/public_html/tos.body.html"
179 fun readTosAgree () = readFile
"/home/hcoop/public_html/tos.agree.html"
180 fun readTosMinorAgree () = readFile
"/home/hcoop/public_html/tos.agree.minor.html"
182 fun searchPaypal paypal
=
183 C
.map (getDb ()) mkAppRow ($`SELECT id
, name
, rname
, gname
, email
, forward
, uses
, other
, passwd
, status
, applied
, ipaddr
, confirmed
, decided
,
184 msg
, unix_passwd
, paypal
, checkout
186 WHERE paypal
= ^
(C
.stringToSql (normEmail paypal
))
188 AND decided
>= CURRENT_TIMESTAMP
- INTERVAL
'1 MONTH
'
191 fun searchCheckout checkout
=
192 C
.map (getDb ()) mkAppRow ($`SELECT id
, name
, rname
, gname
, email
, forward
, uses
, other
, passwd
, status
, applied
, ipaddr
, confirmed
, decided
,
193 msg
, unix_passwd
, paypal
, checkout
195 WHERE checkout
= ^
(C
.stringToSql (normEmail checkout
))
197 AND decided
>= CURRENT_TIMESTAMP
- INTERVAL
'1 MONTH
'