20a679fc |
1 | structure App :> APP = |
2 | struct |
3 | |
8d550734 |
4 | val baseUrl = "https://join.hcoop.net/join/" |
aa6af22d |
5 | val portalUrl = "https://members2.hcoop.net/portal/" |
20a679fc |
6 | |
7 | open Sql |
8 | |
9 | structure C = PgClient |
10 | |
11 | val db = ref (NONE : C.conn option) |
12 | |
13 | val rnd = ref (Random.rand (0, 0)) |
14 | |
15 | fun init () = |
16 | let |
fd650826 |
17 | val c = C.conn "dbname='hcoop_hcoop'" |
20a679fc |
18 | in |
19 | db := SOME c; |
20 | C.dml c "BEGIN"; |
21 | rnd := Random.rand (SysWord.toInt (Posix.Process.pidToWord (Posix.ProcEnv.getpid ())), |
22 | SysWord.toInt (Posix.Process.pidToWord (Posix.ProcEnv.getpid ()))) |
23 | end |
24 | |
25 | fun getDb () = valOf (!db) |
26 | |
27 | fun done () = |
28 | let |
29 | val c = getDb () |
30 | in |
31 | C.dml c "COMMIT"; |
32 | C.close c; |
33 | db := NONE |
34 | end |
35 | |
5146e435 |
36 | fun readFile fname = |
37 | let |
38 | val inf = TextIO.openIn fname |
39 | |
40 | fun readLines lines = |
41 | case TextIO.inputLine inf of |
42 | NONE => String.concat (List.rev lines) |
43 | | SOME line => readLines (line :: lines) |
44 | in |
45 | readLines [] |
46 | before TextIO.closeIn inf |
47 | end |
48 | |
fd650826 |
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" |
5146e435 |
52 | |
20a679fc |
53 | fun sendMail (to, subj, intro, footer, id) = |
54 | let |
57215bc3 |
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] => |
5146e435 |
58 | (C.stringFromSql name, C.stringFromSql rname, |
59 | if C.isNull gname then NONE else SOME (C.stringFromSql gname), |
57215bc3 |
60 | C.stringFromSql email, |
5146e435 |
61 | C.boolFromSql forward, C.stringFromSql uses, |
62 | C.stringFromSql other) |
20a679fc |
63 | | _ => raise Fail "Bad sendMail row" |
64 | |
65 | val proc = Unix.execute ("/usr/sbin/exim4", ["-t"]) |
66 | fun mwrite s = TextIO.output (Unix.textOutstreamOf proc, s) |
67 | in |
453d7579 |
68 | mwrite ("From: Hcoop Application System <join@hcoop.net>\nTo: "); |
20a679fc |
69 | mwrite (to); |
70 | mwrite ("\nSubject: "); |
71 | mwrite subj; |
72 | mwrite ("\n\n"); |
73 | mwrite intro; |
74 | mwrite ("\n\nUsername: "); |
75 | mwrite (name); |
5146e435 |
76 | mwrite ("\nMember real name: "); |
20a679fc |
77 | mwrite (rname); |
5146e435 |
78 | case gname of |
79 | NONE => () |
80 | | SOME gname => (mwrite "\nLegal guardian name: "; |
81 | mwrite gname); |
57215bc3 |
82 | mwrite ("\nE-mail address: "); |
83 | mwrite email; |
20a679fc |
84 | mwrite ("\nForward e-mail: "); |
85 | mwrite (if forward then "yes" else "no"); |
86 | mwrite ("\n\nDesired uses:\n"); |
87 | mwrite (uses); |
88 | mwrite ("\n\nOther information:\n"); |
89 | mwrite (other); |
90 | mwrite ("\n\n"); |
91 | footer mwrite; |
92 | OS.Process.isSuccess (Unix.reap proc) |
93 | end |
94 | |
5146e435 |
95 | type application = { name : string, rname : string, gname : string option, email : string, |
20acb925 |
96 | forward : bool, uses : string, other : string, |
97 | paypal : string option, checkout : string option } |
20a679fc |
98 | |
8d550734 |
99 | fun randomPassword () = |
100 | let |
6a7def9a |
101 | val proc = Unix.execute ("/usr/bin/pwgen", ["-cCnB", "8", "1"]) |
8d550734 |
102 | in |
103 | case TextIO.inputLine (Unix.textInstreamOf proc) of |
6a7def9a |
104 | NONE => raise Fail "Couldn't execute pwgen" |
8d550734 |
105 | | SOME line => |
106 | case String.tokens Char.isSpace line of |
107 | [s] => s |
6a7def9a |
108 | | _ => raise Fail "Couldn't parse output of pwgen" |
8d550734 |
109 | end |
110 | |
20acb925 |
111 | val allLower = CharVector.map Char.toLower |
112 | |
113 | fun emailToSql so = |
114 | case so of |
115 | NONE => "NULL" |
116 | | SOME s => C.stringToSql (allLower s) |
117 | |
118 | fun apply {name, rname, gname, email, forward, uses, other, paypal, checkout} = |
20a679fc |
119 | let |
120 | val db = getDb () |
121 | in |
122 | case C.oneRow db ($`SELECT nextval('MemberAppSeq')`) of |
123 | [id] => |
124 | let |
125 | val id = C.intFromSql id |
126 | val passwd = Int.toString (Int.abs (Random.randInt (!rnd))) |
8d550734 |
127 | val unix_passwd = randomPassword () |
20a679fc |
128 | in |
20acb925 |
129 | C.dml db ($`INSERT INTO MemberApp (id, name, rname, gname, email, forward, uses, other, passwd, |
130 | status, applied, msg, unix_passwd, paypal, checkout) |
20a679fc |
131 | VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), |
5146e435 |
132 | ^(case gname of NONE => "NULL" | SOME gname => C.stringToSql gname), |
20a679fc |
133 | ^(C.stringToSql email), ^(C.boolToSql forward), ^(C.stringToSql uses), |
8d550734 |
134 | ^(C.stringToSql other), ^(C.stringToSql passwd), 0, CURRENT_TIMESTAMP, |
20acb925 |
135 | '', ^(C.stringToSql unix_passwd), |
136 | ^(emailToSql paypal), ^(emailToSql checkout))`); |
6d56b757 |
137 | if sendMail (email, "Confirm membership application", |
8d550734 |
138 | "We've received a request to join the Internet Hosting Cooperative (hcoop.net) with this e-mail address.", |
20a679fc |
139 | fn mwrite => (mwrite ("To confirm this application, visit "); |
140 | mwrite (baseUrl); |
141 | mwrite ("confirm?id="); |
142 | mwrite (Int.toString id); |
143 | mwrite ("&p="); |
8d550734 |
144 | mwrite passwd; |
20a679fc |
145 | mwrite ("\n")), |
6d56b757 |
146 | id) then |
2e72273e |
147 | SOME unix_passwd |
6d56b757 |
148 | else |
149 | NONE |
20a679fc |
150 | end |
151 | | _ => raise Fail "Bad next sequence val" |
152 | end |
153 | |
4e630cf8 |
154 | fun isIdent ch = Char.isLower ch orelse Char.isDigit ch orelse ch = #"-" |
20a679fc |
155 | |
156 | fun validHost s = |
157 | size s > 0 andalso size s < 20 andalso List.all isIdent (String.explode s) |
158 | |
159 | fun validDomain s = |
160 | size s > 0 andalso size s < 100 andalso List.all validHost (String.fields (fn ch => ch = #".") s) |
161 | |
162 | fun validUser 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 = #"+") |
165 | (String.explode s) |
166 | |
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 = #"+") |
170 | (String.explode s) |
171 | |
172 | fun validEmail s = |
173 | (case String.fields (fn ch => ch = #"@") s of |
174 | [user, host] => validEmailUser user andalso validDomain host |
175 | | _ => false) |
176 | |
177 | fun userExists name = |
178 | (Posix.SysDB.getpwnam name; true) handle OS.SysErr _ => false |
179 | |
180 | fun confirm (id, passwd) = |
181 | let |
182 | val db = getDb () |
183 | in |
8d550734 |
184 | case C.oneOrNoRows db ($`SELECT unix_passwd FROM MemberApp WHERE id = ^(C.intToSql id) AND passwd = ^(C.stringToSql passwd) AND status = 0`) of |
6d56b757 |
185 | SOME [_] => |
20a679fc |
186 | (C.dml db ($`UPDATE MemberApp SET status = 1, confirmed = CURRENT_TIMESTAMP WHERE id = ^(C.intToSql id)`); |
6d56b757 |
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: "); |
191 | mwrite (portalUrl); |
192 | mwrite ("apps")), |
193 | id)) |
194 | | NONE => false |
20a679fc |
195 | end |
196 | |
fd650826 |
197 | end |