Commit | Line | Data |
---|---|---|
a90da8b1 AC |
1 | structure App :> APP = |
2 | struct | |
3 | ||
4 | val baseUrl = "http://join.hcoop.net/join/" | |
5 | val portalUrl = "http://users.hcoop.net/portal/" | |
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 | |
17 | val c = C.conn "dbname='hcoop'" | |
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 | ||
49 | fun readTosBody () = readFile "/var/www/home/html/tos.body.html" | |
50 | fun readTosAgree () = readFile "/var/www/home/html/tos.agree.html" | |
51 | fun readTosMinorAgree () = readFile "/var/www/home/html/tos.agree.minor.html" | |
52 | ||
a90da8b1 AC |
53 | fun sendMail (to, subj, intro, footer, id) = |
54 | let | |
f3f3ad24 AC |
55 | val (name, rname, gname, forward, uses, other) = |
56 | case C.oneOrNoRows (getDb ()) ($`SELECT name, rname, gname, forward, uses, other FROM MemberApp WHERE id = ^(C.intToSql id)`) of | |
57 | SOME [name, rname, gname, forward, uses, other] => | |
58 | (C.stringFromSql name, C.stringFromSql rname, | |
59 | if C.isNull gname then NONE else SOME (C.stringFromSql gname), | |
60 | C.boolFromSql forward, C.stringFromSql uses, | |
61 | C.stringFromSql other) | |
a90da8b1 AC |
62 | | _ => raise Fail "Bad sendMail row" |
63 | ||
64 | val proc = Unix.execute ("/usr/sbin/exim4", ["-t"]) | |
65 | fun mwrite s = TextIO.output (Unix.textOutstreamOf proc, s) | |
66 | in | |
6f91863c | 67 | mwrite ("From: Hcoop Application System <join@hcoop.net>\nTo: "); |
a90da8b1 AC |
68 | mwrite (to); |
69 | mwrite ("\nSubject: "); | |
70 | mwrite subj; | |
71 | mwrite ("\n\n"); | |
72 | mwrite intro; | |
73 | mwrite ("\n\nUsername: "); | |
74 | mwrite (name); | |
f3f3ad24 | 75 | mwrite ("\nMember real name: "); |
a90da8b1 | 76 | mwrite (rname); |
f3f3ad24 AC |
77 | case gname of |
78 | NONE => () | |
79 | | SOME gname => (mwrite "\nLegal guardian name: "; | |
80 | mwrite gname); | |
a90da8b1 AC |
81 | mwrite ("\nForward e-mail: "); |
82 | mwrite (if forward then "yes" else "no"); | |
83 | mwrite ("\n\nDesired uses:\n"); | |
84 | mwrite (uses); | |
85 | mwrite ("\n\nOther information:\n"); | |
86 | mwrite (other); | |
87 | mwrite ("\n\n"); | |
88 | footer mwrite; | |
89 | OS.Process.isSuccess (Unix.reap proc) | |
90 | end | |
91 | ||
f3f3ad24 | 92 | type application = { name : string, rname : string, gname : string option, email : string, |
a90da8b1 AC |
93 | forward : bool, uses : string, other : string } |
94 | ||
f3f3ad24 | 95 | fun apply {name, rname, gname, email, forward, uses, other} = |
a90da8b1 AC |
96 | let |
97 | val db = getDb () | |
98 | in | |
99 | case C.oneRow db ($`SELECT nextval('MemberAppSeq')`) of | |
100 | [id] => | |
101 | let | |
102 | val id = C.intFromSql id | |
103 | val passwd = Int.toString (Int.abs (Random.randInt (!rnd))) | |
104 | in | |
f3f3ad24 | 105 | C.dml db ($`INSERT INTO MemberApp (id, name, rname, gname, email, forward, uses, other, passwd, status, applied, msg) |
a90da8b1 | 106 | VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), |
f3f3ad24 | 107 | ^(case gname of NONE => "NULL" | SOME gname => C.stringToSql gname), |
a90da8b1 | 108 | ^(C.stringToSql email), ^(C.boolToSql forward), ^(C.stringToSql uses), |
6f91863c | 109 | ^(C.stringToSql other), ^(C.stringToSql passwd), 0, CURRENT_TIMESTAMP, '')`); |
a90da8b1 AC |
110 | sendMail (email, "Confirm membership application", |
111 | "We've received a request to join the Internet Hosting Cooperative (hcoop.net) with this e-mail address.", | |
112 | fn mwrite => (mwrite ("To confirm this application, visit "); | |
113 | mwrite (baseUrl); | |
114 | mwrite ("confirm?id="); | |
115 | mwrite (Int.toString id); | |
116 | mwrite ("&p="); | |
117 | mwrite (passwd); | |
118 | mwrite ("\n")), | |
119 | id) | |
120 | end | |
121 | | _ => raise Fail "Bad next sequence val" | |
122 | end | |
123 | ||
124 | fun isIdent ch = Char.isLower ch orelse Char.isDigit ch | |
125 | ||
126 | fun validHost s = | |
127 | size s > 0 andalso size s < 20 andalso List.all isIdent (String.explode s) | |
128 | ||
129 | fun validDomain s = | |
130 | size s > 0 andalso size s < 100 andalso List.all validHost (String.fields (fn ch => ch = #".") s) | |
131 | ||
132 | fun validUser s = | |
133 | size s > 0 andalso size s < 50 andalso List.all | |
134 | (fn ch => isIdent ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-" orelse ch = #"+") | |
135 | (String.explode s) | |
136 | ||
137 | fun validEmailUser s = | |
138 | size s > 0 andalso size s < 50 andalso List.all | |
139 | (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-" orelse ch = #"+") | |
140 | (String.explode s) | |
141 | ||
142 | fun validEmail s = | |
143 | (case String.fields (fn ch => ch = #"@") s of | |
144 | [user, host] => validEmailUser user andalso validDomain host | |
145 | | _ => false) | |
146 | ||
147 | fun userExists name = | |
148 | (Posix.SysDB.getpwnam name; true) handle OS.SysErr _ => false | |
149 | ||
150 | fun confirm (id, passwd) = | |
151 | let | |
152 | val db = getDb () | |
153 | in | |
154 | case C.oneOrNoRows db ($`SELECT id FROM MemberApp WHERE id = ^(C.intToSql id) AND passwd = ^(C.stringToSql passwd) AND status = 0`) of | |
155 | SOME _ => | |
156 | (C.dml db ($`UPDATE MemberApp SET status = 1, confirmed = CURRENT_TIMESTAMP WHERE id = ^(C.intToSql id)`); | |
157 | sendMail ("board.fake@hcoop.net", | |
158 | "New membership application", | |
159 | "We've received a new request to join hcoop.", | |
160 | fn mwrite => (mwrite ("Open applications: "); | |
161 | mwrite (portalUrl); | |
162 | mwrite ("apps")), | |
163 | id)) | |
164 | | NONE => false | |
165 | end | |
166 | ||
167 | end |