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
,
37 fun mkAppRow
[id
, name
, rname
, gname
, email
, forward
, uses
, other
, passwd
, status
,
38 applied
, ipaddr
, confirmed
, decided
, msg
] =
39 { id
= C
.intFromSql id
, name
= C
.stringFromSql name
, rname
= C
.stringFromSql rname
,
40 gname
= (if C
.isNull gname
then NONE
else SOME (C
.stringFromSql gname
)),
41 email
= C
.stringFromSql email
, forward
= C
.boolFromSql forward
,
42 uses
= C
.stringFromSql uses
, other
= C
.stringFromSql other
, passwd
= C
.stringFromSql passwd
,
43 status
= statusFromSql status
, applied
= C
.timestampFromSql applied
,
44 ipaddr
= (if C
.isNull ipaddr
then NONE
else SOME (C
.stringFromSql ipaddr
)),
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
),
47 msg
= C
.stringFromSql msg
}
48 | mkAppRow r
= rowError ("app", r
)
51 case C
.oneOrNoRows (getDb ()) ($`SELECT id
, name
, rname
, gname
, email
, forward
, uses
, other
, passwd
, status
, applied
, ipaddr
, confirmed
, decided
, msg
53 WHERE id
= ^
(C
.intToSql id
)`
) of
54 SOME row
=> mkAppRow row
55 | NONE
=> raise Fail
"Membership application not found"
58 C
.map (getDb ()) mkAppRow ($`SELECT id
, name
, rname
, gname
, email
, forward
, uses
, other
, passwd
, status
, applied
, ipaddr
, confirmed
, decided
, msg
60 WHERE status
= ^
(statusToSql status
)
61 AND
NOT (status
= 2 AND decided
< CURRENT_TIMESTAMP
- INTERVAL
'1 MONTH
')
64 fun mkVoteRow
[id
, name
] = (C
.intFromSql id
, C
.stringFromSql name
)
65 | mkVoteRow row
= rowError ("app.vote", row
)
67 fun votes id
= C
.map (getDb ()) mkVoteRow ($`SELECT usr
, name
68 FROM AppVote JOIN WebUser ON usr
= id
69 WHERE AppVote
.app
= ^
(C
.intToSql id
)
72 fun vote (usr
, app
) = ignore (C
.dml (getDb ()) ($`INSERT INTO
AppVote (app
, usr
)
73 VALUES (^
(C
.intToSql app
), ^
(C
.intToSql usr
))`
))
75 fun unvote (usr
, app
) = ignore (C
.dml (getDb ()) ($`DELETE FROM AppVote WHERE app
= ^
(C
.intToSql app
) AND usr
= ^
(C
.intToSql usr
)`
))
79 val entry
= lookupApp app
80 val _
= C
.dml (getDb ()) ($`UPDATE MemberApp
81 SET status
= 3, msg
= ^
(C
.stringToSql msg
), decided
= CURRENT_TIMESTAMP
82 WHERE id
= ^
(C
.intToSql app
)`
)
84 val mail
= Mail
.mopen ()
86 Mail
.mwrite (mail
, "From: Hcoop Application System <join");
87 Mail
.mwrite (mail
, emailSuffix
);
88 Mail
.mwrite (mail
, ">\nTo: ");
89 Mail
.mwrite (mail
, #email entry
);
90 Mail
.mwrite (mail
, "\nCc: ");
91 Mail
.mwrite (mail
, boardEmail
);
92 Mail
.mwrite (mail
, "\nSubject: Application denied\n\nYour application for membership has been denied. Reason:\n\n");
93 Mail
.mwrite (mail
, msg
);
94 OS
.Process
.isSuccess (Mail
.mclose mail
)
97 fun approve (app
, msg
) =
99 val entry
= lookupApp app
100 val _
= C
.dml (getDb ()) ($`UPDATE MemberApp
101 SET status
= 2, msg
= ^
(C
.stringToSql msg
), decided
= CURRENT_TIMESTAMP
102 WHERE id
= ^
(C
.intToSql app
)`
)
104 val mail
= Mail
.mopen ()
106 Mail
.mwrite (mail
, "To: ");
107 Mail
.mwrite (mail
, #email entry
);
108 Mail
.mwrite (mail
, "\n");
109 Mail
.mwrite (mail
, Util
.readFile
"/home/hcoop/portal/welcome.txt");
110 Mail
.mwrite (mail
, msg
);
111 OS
.Process
.isSuccess (Mail
.mclose mail
)
115 ignore (C
.dml (getDb ()) ($`UPDATE MemberApp
117 WHERE id
= ^
(C
.intToSql app
)`
))
120 ignore (C
.dml (getDb ()) ($`UPDATE MemberApp
122 WHERE id
= ^
(C
.intToSql app
)`
))
126 val inf
= TextIO.openIn fname
128 fun readLines lines
=
129 case TextIO.inputLine inf
of
130 NONE
=> String.concat (List.rev lines
)
131 | SOME line
=> readLines (line
:: lines
)
134 before TextIO.closeIn inf
137 fun readTosBody () = readFile
"/home/hcoop/public_html/tos.body.html"
138 fun readTosAgree () = readFile
"/home/hcoop/public_html/tos.agree.html"
139 fun readTosMinorAgree () = readFile
"/home/hcoop/public_html/tos.agree.minor.html"