4 val baseUrl
= "https://join.hcoop.net/join/"
5 val portalUrl
= "https://members2.hcoop.net/portal/"
11 val db
= ref (NONE
: C
.conn option
)
13 val rnd
= ref (Random
.rand (0, 0))
17 val c
= C
.conn
"dbname='hcoop_hcoop'"
21 rnd
:= Random
.rand (SysWord
.toInt (Posix
.Process
.pidToWord (Posix
.ProcEnv
.getpid ())),
22 SysWord
.toInt (Posix
.Process
.pidToWord (Posix
.ProcEnv
.getpid ())))
25 fun getDb () = valOf (!db
)
38 val inf
= TextIO.openIn fname
41 case TextIO.inputLine inf
of
42 NONE
=> String.concat (List.rev lines
)
43 | SOME line
=> readLines (line
:: lines
)
46 before TextIO.closeIn inf
49 fun readTosBody () = readFile
"/home/hcoop/public_html/tos.body.html"
50 fun readTosAgree () = readFile
"/home/hcoop/public_html/tos.agree.html"
51 fun readTosMinorAgree () = readFile
"/home/hcoop/public_html/tos.agree.minor.html"
53 fun sendMail (to
, subj
, intro
, footer
, id
) =
55 val (name
, rname
, gname
, email
, forward
, uses
, other
) =
56 case C
.oneOrNoRows (getDb ()) ($`SELECT name
, rname
, gname
, email
, forward
, uses
, other FROM MemberApp WHERE id
= ^
(C
.intToSql id
)`
) of
57 SOME
[name
, rname
, gname
, email
, forward
, uses
, other
] =>
58 (C
.stringFromSql name
, C
.stringFromSql rname
,
59 if C
.isNull gname
then NONE
else SOME (C
.stringFromSql gname
),
60 C
.stringFromSql email
,
61 C
.boolFromSql forward
, C
.stringFromSql uses
,
62 C
.stringFromSql other
)
63 | _
=> raise Fail
"Bad sendMail row"
65 val proc
= Unix
.execute ("/usr/sbin/exim4", ["-t"])
66 fun mwrite s
= TextIO.output (Unix
.textOutstreamOf proc
, s
)
68 mwrite ("From: Hcoop Application System <join@hcoop.net>\nTo: ");
70 mwrite ("\nSubject: ");
74 mwrite ("\n\nUsername: ");
76 mwrite ("\nMember real name: ");
80 | SOME gname
=> (mwrite
"\nLegal guardian name: ";
82 mwrite ("\nE-mail address: ");
84 mwrite ("\nForward e-mail: ");
85 mwrite (if forward
then "yes" else "no");
86 mwrite ("\n\nDesired uses:\n");
88 mwrite ("\n\nOther information:\n");
92 OS
.Process
.isSuccess (Unix
.reap proc
)
95 type application
= { name
: string, rname
: string, gname
: string option
, email
: string,
96 forward
: bool, uses
: string, other
: string,
97 paypal
: string option
, checkout
: string option
}
99 fun randomPassword () =
101 val proc
= Unix
.execute ("/usr/bin/pwgen", ["-cCnB", "8", "1"])
103 case TextIO.inputLine (Unix
.textInstreamOf proc
) of
104 NONE
=> raise Fail
"Couldn't execute pwgen"
106 case String.tokens
Char.isSpace line
of
108 | _
=> raise Fail
"Couldn't parse output of pwgen"
111 val allLower
= CharVector
.map
Char.toLower
116 | SOME s
=> C
.stringToSql (allLower s
)
118 fun apply
{name
, rname
, gname
, email
, forward
, uses
, other
, paypal
, checkout
} =
122 case C
.oneRow
db ($`SELECT
nextval('MemberAppSeq
')`
) of
125 val id
= C
.intFromSql id
126 val passwd
= Int.toString (Int.abs (Random
.randInt (!rnd
)))
127 val unix_passwd
= randomPassword ()
129 C
.dml
db ($`INSERT INTO
MemberApp (id
, name
, rname
, gname
, email
, forward
, uses
, other
, passwd
,
130 status
, applied
, msg
, unix_passwd
, paypal
, checkout
)
131 VALUES (^
(C
.intToSql id
), ^
(C
.stringToSql name
), ^
(C
.stringToSql rname
),
132 ^
(case gname
of NONE
=> "NULL" | SOME gname
=> C
.stringToSql gname
),
133 ^
(C
.stringToSql email
), ^
(C
.boolToSql forward
), ^
(C
.stringToSql uses
),
134 ^
(C
.stringToSql other
), ^
(C
.stringToSql passwd
), 0, CURRENT_TIMESTAMP
,
135 '', ^
(C
.stringToSql unix_passwd
),
136 ^
(emailToSql paypal
), ^
(emailToSql checkout
))`
);
137 if sendMail (email
, "Confirm membership application",
138 "We've received a request to join the Internet Hosting Cooperative (hcoop.net) with this e-mail address.",
139 fn mwrite
=> (mwrite ("To confirm this application, visit ");
141 mwrite ("confirm?id=");
142 mwrite (Int.toString id
);
151 | _
=> raise Fail
"Bad next sequence val"
154 fun isIdent ch
= Char.isLower ch
orelse Char.isDigit ch
orelse ch
= #
"-"
157 size s
> 0 andalso size s
< 20 andalso List.all
isIdent (String.explode s
)
160 size s
> 0 andalso size s
< 100 andalso List.all
validHost (String.fields (fn ch
=> ch
= #
".") s
)
163 size s
> 0 andalso size s
< 50 andalso List.all
164 (fn ch
=> isIdent ch
orelse ch
= #
"." orelse ch
= #
"_" orelse ch
= #
"-" orelse ch
= #
"+")
167 fun validEmailUser s
=
168 size s
> 0 andalso size s
< 50 andalso List.all
169 (fn ch
=> Char.isAlphaNum ch
orelse ch
= #
"." orelse ch
= #
"_" orelse ch
= #
"-" orelse ch
= #
"+")
173 (case String.fields (fn ch
=> ch
= #
"@") s
of
174 [user
, host
] => validEmailUser user
andalso validDomain host
177 fun userExists name
=
178 (Posix
.SysDB
.getpwnam name
; true) handle OS
.SysErr _
=> false
180 fun confirm (id
, passwd
) =
184 case C
.oneOrNoRows
db ($`SELECT unix_passwd FROM MemberApp WHERE id
= ^
(C
.intToSql id
) AND passwd
= ^
(C
.stringToSql passwd
) AND status
= 0`
) of
186 (C
.dml
db ($`UPDATE MemberApp SET status
= 1, confirmed
= CURRENT_TIMESTAMP WHERE id
= ^
(C
.intToSql id
)`
);
187 sendMail ("board@hcoop.net",
188 "New membership application",
189 "We've received a new request to join hcoop.",
190 fn mwrite
=> (mwrite ("Open applications: ");