19 | _
=> raise C
.Sql
"Bad status"
28 fun statusFromSql v
= statusFromInt (C
.intFromSql v
)
29 fun statusToSql s
= C
.intToSql (statusToInt s
)
31 type app
= { id
: int, name
: string, rname
: string, gname
: string option
, email
: string,
32 forward
: bool, uses
: string, other
: string,
33 passwd
: string, status
: status
, applied
: C
.timestamp
, ipaddr
: string option
,
34 confirmed
: C
.timestamp option
, decided
: C
.timestamp option
,
35 msg
: string, unix_passwd
: string,
36 paypal
: string option
, checkout
: string option
}
38 fun mkAppRow
[id
, name
, rname
, gname
, email
, forward
, uses
, other
, passwd
, status
,
39 applied
, ipaddr
, confirmed
, decided
, msg
, unix_passwd
, paypal
, checkout
] =
40 { id
= C
.intFromSql id
, name
= C
.stringFromSql name
, rname
= C
.stringFromSql rname
,
41 gname
= Init
.nullableFromSql C
.stringFromSql gname
,
42 email
= C
.stringFromSql email
, forward
= C
.boolFromSql forward
,
43 uses
= C
.stringFromSql uses
, other
= C
.stringFromSql other
, passwd
= C
.stringFromSql passwd
,
44 status
= statusFromSql status
, applied
= C
.timestampFromSql applied
,
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
}
51 | mkAppRow r
= rowError ("app", r
)
54 case C
.oneOrNoRows (getDb ()) ($`SELECT id
, name
, rname
, gname
, email
, forward
, uses
, other
, passwd
, status
, applied
, ipaddr
, confirmed
, decided
,
55 msg
, unix_passwd
, paypal
, checkout
57 WHERE id
= ^
(C
.intToSql id
)`
) of
58 SOME row
=> mkAppRow row
59 | NONE
=> raise Fail
"Membership application not found"
62 C
.map (getDb ()) mkAppRow ($`SELECT id
, name
, rname
, gname
, email
, forward
, uses
, other
, passwd
, status
, applied
, ipaddr
, confirmed
, decided
,
63 msg
, unix_passwd
, paypal
, checkout
65 WHERE status
= ^
(statusToSql status
)
66 AND
NOT (status
= 2 AND decided
< CURRENT_TIMESTAMP
- INTERVAL
'1 MONTH
')
69 fun mkVoteRow
[id
, name
] = (C
.intFromSql id
, C
.stringFromSql name
)
70 | mkVoteRow row
= rowError ("app.vote", row
)
72 fun votes id
= C
.map (getDb ()) mkVoteRow ($`SELECT usr
, name
73 FROM AppVote JOIN WebUser ON usr
= id
74 WHERE AppVote
.app
= ^
(C
.intToSql id
)
77 fun vote (usr
, app
) = ignore (C
.dml (getDb ()) ($`INSERT INTO
AppVote (app
, usr
)
78 VALUES (^
(C
.intToSql app
), ^
(C
.intToSql usr
))`
))
80 fun unvote (usr
, app
) = ignore (C
.dml (getDb ()) ($`DELETE FROM AppVote WHERE app
= ^
(C
.intToSql app
) AND usr
= ^
(C
.intToSql usr
)`
))
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
)`
)
89 val mail
= Mail
.mopen ()
91 Mail
.mwrite (mail
, "From: Hcoop Application System <join");
92 Mail
.mwrite (mail
, emailSuffix
);
93 Mail
.mwrite (mail
, ">\nTo: ");
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
)
102 fun approve (app
, msg
) =
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
)`
)
109 val mail
= Mail
.mopen ()
111 Mail
.mwrite (mail
, "To: ");
112 Mail
.mwrite (mail
, #email entry
);
113 Mail
.mwrite (mail
, "\n");
114 Mail
.mwrite (mail
, Util
.readFile
"/home/hcoop/portal/welcome.txt");
115 Mail
.mwrite (mail
, msg
);
116 OS
.Process
.isSuccess (Mail
.mclose mail
)
121 val _
= C
.dml (getDb ()) ($`UPDATE MemberApp
123 WHERE id
= ^
(C
.intToSql app
)`
)
125 val app
= lookupApp app
127 val outf
= TextIO.openOut (Config
.passwordFiles ^ #name app
)
129 TextIO.output (outf
, #unix_passwd app
);
130 TextIO.output1 (outf
, #
"\n");
136 val app
= lookupApp app
138 val mail
= Mail
.mopen ()
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
)
148 ignore (C
.dml (getDb ()) ($`UPDATE MemberApp
150 WHERE id
= ^
(C
.intToSql app
)`
))
154 val inf
= TextIO.openIn fname
156 fun readLines lines
=
157 case TextIO.inputLine inf
of
158 NONE
=> String.concat (List.rev lines
)
159 | SOME line
=> readLines (line
:: lines
)
162 before TextIO.closeIn inf
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"
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
173 WHERE paypal
= ^
(C
.stringToSql (normEmail paypal
))
175 AND decided
>= CURRENT_TIMESTAMP
- INTERVAL
'1 MONTH
'
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
182 WHERE checkout
= ^
(C
.stringToSql (normEmail checkout
))
184 AND decided
>= CURRENT_TIMESTAMP
- INTERVAL
'1 MONTH
'