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, |
20a679fc |
96 | forward : bool, uses : string, other : string } |
97 | |
8d550734 |
98 | fun randomPassword () = |
99 | let |
100 | val proc = Unix.execute ("/usr/bin/apg", ["/usr/bin/apg", "-n", "1", "-m", "10"]) |
101 | in |
102 | case TextIO.inputLine (Unix.textInstreamOf proc) of |
103 | NONE => raise Fail "Couldn't execute apg" |
104 | | SOME line => |
105 | case String.tokens Char.isSpace line of |
106 | [s] => s |
107 | | _ => raise Fail "Couldn't parse output of apg" |
108 | end |
109 | |
5146e435 |
110 | fun apply {name, rname, gname, email, forward, uses, other} = |
20a679fc |
111 | let |
112 | val db = getDb () |
113 | in |
114 | case C.oneRow db ($`SELECT nextval('MemberAppSeq')`) of |
115 | [id] => |
116 | let |
117 | val id = C.intFromSql id |
118 | val passwd = Int.toString (Int.abs (Random.randInt (!rnd))) |
8d550734 |
119 | val unix_passwd = randomPassword () |
20a679fc |
120 | in |
8d550734 |
121 | C.dml db ($`INSERT INTO MemberApp (id, name, rname, gname, email, forward, uses, other, passwd, status, applied, msg, unix_passwd) |
20a679fc |
122 | VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), |
5146e435 |
123 | ^(case gname of NONE => "NULL" | SOME gname => C.stringToSql gname), |
20a679fc |
124 | ^(C.stringToSql email), ^(C.boolToSql forward), ^(C.stringToSql uses), |
8d550734 |
125 | ^(C.stringToSql other), ^(C.stringToSql passwd), 0, CURRENT_TIMESTAMP, |
126 | '', ^(C.stringToSql unix_passwd))`); |
20a679fc |
127 | sendMail (email, "Confirm membership application", |
8d550734 |
128 | "We've received a request to join the Internet Hosting Cooperative (hcoop.net) with this e-mail address.", |
20a679fc |
129 | fn mwrite => (mwrite ("To confirm this application, visit "); |
130 | mwrite (baseUrl); |
131 | mwrite ("confirm?id="); |
132 | mwrite (Int.toString id); |
133 | mwrite ("&p="); |
8d550734 |
134 | mwrite passwd; |
20a679fc |
135 | mwrite ("\n")), |
8d550734 |
136 | id) |
20a679fc |
137 | end |
138 | | _ => raise Fail "Bad next sequence val" |
139 | end |
140 | |
4e630cf8 |
141 | fun isIdent ch = Char.isLower ch orelse Char.isDigit ch orelse ch = #"-" |
20a679fc |
142 | |
143 | fun validHost s = |
144 | size s > 0 andalso size s < 20 andalso List.all isIdent (String.explode s) |
145 | |
146 | fun validDomain s = |
147 | size s > 0 andalso size s < 100 andalso List.all validHost (String.fields (fn ch => ch = #".") s) |
148 | |
149 | fun validUser s = |
150 | size s > 0 andalso size s < 50 andalso List.all |
151 | (fn ch => isIdent ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-" orelse ch = #"+") |
152 | (String.explode s) |
153 | |
154 | fun validEmailUser s = |
155 | size s > 0 andalso size s < 50 andalso List.all |
156 | (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-" orelse ch = #"+") |
157 | (String.explode s) |
158 | |
159 | fun validEmail s = |
160 | (case String.fields (fn ch => ch = #"@") s of |
161 | [user, host] => validEmailUser user andalso validDomain host |
162 | | _ => false) |
163 | |
164 | fun userExists name = |
165 | (Posix.SysDB.getpwnam name; true) handle OS.SysErr _ => false |
166 | |
167 | fun confirm (id, passwd) = |
168 | let |
169 | val db = getDb () |
170 | in |
8d550734 |
171 | case C.oneOrNoRows db ($`SELECT unix_passwd FROM MemberApp WHERE id = ^(C.intToSql id) AND passwd = ^(C.stringToSql passwd) AND status = 0`) of |
172 | SOME [unix_passwd] => |
20a679fc |
173 | (C.dml db ($`UPDATE MemberApp SET status = 1, confirmed = CURRENT_TIMESTAMP WHERE id = ^(C.intToSql id)`); |
8d550734 |
174 | if sendMail ("board@hcoop.net", |
175 | "New membership application", |
176 | "We've received a new request to join hcoop.", |
20a679fc |
177 | fn mwrite => (mwrite ("Open applications: "); |
178 | mwrite (portalUrl); |
179 | mwrite ("apps")), |
8d550734 |
180 | id) then |
181 | SOME (C.stringFromSql unix_passwd) |
182 | else |
183 | NONE) |
184 | | NONE => NONE |
20a679fc |
185 | end |
186 | |
fd650826 |
187 | end |