Commit | Line | Data |
---|---|---|
a90da8b1 AC |
1 | structure App :> APP = |
2 | struct | |
3 | ||
a2d53da2 | 4 | val baseUrl = "https://join.hcoop.net/join/" |
cc171694 | 5 | val portalUrl = "https://members.hcoop.net/portal/" |
a90da8b1 AC |
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 | |
52a07965 | 17 | val c = C.conn "dbname='hcoop_hcoop' host='postgres'" |
a90da8b1 AC |
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 | ||
f3f3ad24 AC |
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 | ||
1d2cae17 AC |
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" | |
f3f3ad24 | 52 | |
a90da8b1 AC |
53 | fun sendMail (to, subj, intro, footer, id) = |
54 | let | |
d50a0cd7 AC |
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] => | |
f3f3ad24 AC |
58 | (C.stringFromSql name, C.stringFromSql rname, |
59 | if C.isNull gname then NONE else SOME (C.stringFromSql gname), | |
d50a0cd7 | 60 | C.stringFromSql email, |
f3f3ad24 AC |
61 | C.boolFromSql forward, C.stringFromSql uses, |
62 | C.stringFromSql other) | |
a90da8b1 AC |
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 | |
6f91863c | 68 | mwrite ("From: Hcoop Application System <join@hcoop.net>\nTo: "); |
a90da8b1 AC |
69 | mwrite (to); |
70 | mwrite ("\nSubject: "); | |
71 | mwrite subj; | |
72 | mwrite ("\n\n"); | |
73 | mwrite intro; | |
74 | mwrite ("\n\nUsername: "); | |
75 | mwrite (name); | |
f3f3ad24 | 76 | mwrite ("\nMember real name: "); |
a90da8b1 | 77 | mwrite (rname); |
f3f3ad24 AC |
78 | case gname of |
79 | NONE => () | |
80 | | SOME gname => (mwrite "\nLegal guardian name: "; | |
81 | mwrite gname); | |
d50a0cd7 AC |
82 | mwrite ("\nE-mail address: "); |
83 | mwrite email; | |
a90da8b1 AC |
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 | ||
f3f3ad24 | 95 | type application = { name : string, rname : string, gname : string option, email : string, |
d5f8418b AC |
96 | forward : bool, uses : string, other : string, |
97 | paypal : string option, checkout : string option } | |
a90da8b1 | 98 | |
a2d53da2 AC |
99 | fun randomPassword () = |
100 | let | |
442f54e7 | 101 | val proc = Unix.execute ("/usr/bin/pwgen", ["-cCnB", "8", "1"]) |
a2d53da2 AC |
102 | in |
103 | case TextIO.inputLine (Unix.textInstreamOf proc) of | |
442f54e7 | 104 | NONE => raise Fail "Couldn't execute pwgen" |
a2d53da2 AC |
105 | | SOME line => |
106 | case String.tokens Char.isSpace line of | |
107 | [s] => s | |
442f54e7 | 108 | | _ => raise Fail "Couldn't parse output of pwgen" |
a2d53da2 AC |
109 | end |
110 | ||
d5f8418b AC |
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} = | |
a90da8b1 AC |
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))) | |
a2d53da2 | 127 | val unix_passwd = randomPassword () |
a90da8b1 | 128 | in |
d5f8418b AC |
129 | C.dml db ($`INSERT INTO MemberApp (id, name, rname, gname, email, forward, uses, other, passwd, |
130 | status, applied, msg, unix_passwd, paypal, checkout) | |
a90da8b1 | 131 | VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), |
f3f3ad24 | 132 | ^(case gname of NONE => "NULL" | SOME gname => C.stringToSql gname), |
a90da8b1 | 133 | ^(C.stringToSql email), ^(C.boolToSql forward), ^(C.stringToSql uses), |
a2d53da2 | 134 | ^(C.stringToSql other), ^(C.stringToSql passwd), 0, CURRENT_TIMESTAMP, |
d5f8418b AC |
135 | '', ^(C.stringToSql unix_passwd), |
136 | ^(emailToSql paypal), ^(emailToSql checkout))`); | |
eea7b531 | 137 | if sendMail (email, "Confirm membership application", |
a2d53da2 | 138 | "We've received a request to join the Internet Hosting Cooperative (hcoop.net) with this e-mail address.", |
a90da8b1 AC |
139 | fn mwrite => (mwrite ("To confirm this application, visit "); |
140 | mwrite (baseUrl); | |
141 | mwrite ("confirm?id="); | |
142 | mwrite (Int.toString id); | |
143 | mwrite ("&p="); | |
a2d53da2 | 144 | mwrite passwd; |
a90da8b1 | 145 | mwrite ("\n")), |
eea7b531 | 146 | id) then |
efbc2606 | 147 | SOME unix_passwd |
eea7b531 AC |
148 | else |
149 | NONE | |
a90da8b1 AC |
150 | end |
151 | | _ => raise Fail "Bad next sequence val" | |
152 | end | |
153 | ||
ea8d5198 | 154 | fun isIdent ch = Char.isLower ch orelse Char.isDigit ch orelse ch = #"-" |
a90da8b1 AC |
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 | ||
96bd398e AC |
162 | fun validUsername name = |
163 | size name <= 12 | |
164 | andalso size name > 0 | |
165 | andalso Char.isLower (String.sub (name, 0)) | |
166 | andalso CharVector.all Char.isAlphaNum name | |
a90da8b1 AC |
167 | |
168 | fun validEmailUser s = | |
169 | size s > 0 andalso size s < 50 andalso List.all | |
170 | (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-" orelse ch = #"+") | |
171 | (String.explode s) | |
172 | ||
173 | fun validEmail s = | |
174 | (case String.fields (fn ch => ch = #"@") s of | |
175 | [user, host] => validEmailUser user andalso validDomain host | |
176 | | _ => false) | |
177 | ||
178 | fun userExists name = | |
1a386fa5 AC |
179 | case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebUser WHERE name = ^(C.stringToSql name)`) of |
180 | SOME _ => true | |
181 | | NONE => (Posix.SysDB.getpwnam name; true) handle OS.SysErr _ => false | |
a90da8b1 AC |
182 | |
183 | fun confirm (id, passwd) = | |
184 | let | |
185 | val db = getDb () | |
186 | in | |
a2d53da2 | 187 | case C.oneOrNoRows db ($`SELECT unix_passwd FROM MemberApp WHERE id = ^(C.intToSql id) AND passwd = ^(C.stringToSql passwd) AND status = 0`) of |
eea7b531 | 188 | SOME [_] => |
a90da8b1 | 189 | (C.dml db ($`UPDATE MemberApp SET status = 1, confirmed = CURRENT_TIMESTAMP WHERE id = ^(C.intToSql id)`); |
eea7b531 AC |
190 | sendMail ("board@hcoop.net", |
191 | "New membership application", | |
192 | "We've received a new request to join hcoop.", | |
193 | fn mwrite => (mwrite ("Open applications: "); | |
194 | mwrite (portalUrl); | |
195 | mwrite ("apps")), | |
196 | id)) | |
197 | | NONE => false | |
a90da8b1 AC |
198 | end |
199 | ||
1d2cae17 | 200 | end |