| 1 | structure App :> APP = |
| 2 | struct |
| 3 | |
| 4 | val baseUrl = "https://join3.hcoop.net/join/" |
| 5 | val portalUrl = Config.urlPrefix |
| 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 Config.dbstring |
| 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 | |
| 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 (Config.staticFilesRoot ^ "tos.body.html") |
| 50 | fun readTosAgree () = readFile (Config.staticFilesRoot ^ "tos.agree.html") |
| 51 | fun readTosMinorAgree () = readFile (Config.staticFilesRoot ^ "tos.agree.minor.html") |
| 52 | |
| 53 | fun sendMail (to, subj, intro, footer, id) = |
| 54 | let |
| 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" |
| 64 | |
| 65 | val proc = Unix.execute ("/usr/sbin/exim4", ["-t"]) |
| 66 | fun mwrite s = TextIO.output (Unix.textOutstreamOf proc, s) |
| 67 | in |
| 68 | mwrite ("From: Hcoop Application System <join@hcoop.net>\nTo: "); |
| 69 | mwrite (to); |
| 70 | mwrite ("\nSubject: "); |
| 71 | mwrite subj; |
| 72 | mwrite ("\n\n"); |
| 73 | mwrite intro; |
| 74 | mwrite ("\n\nUsername: "); |
| 75 | mwrite (name); |
| 76 | mwrite ("\nMember real name: "); |
| 77 | mwrite (rname); |
| 78 | case gname of |
| 79 | NONE => () |
| 80 | | SOME gname => (mwrite "\nLegal guardian name: "; |
| 81 | mwrite gname); |
| 82 | mwrite ("\nE-mail address: "); |
| 83 | mwrite email; |
| 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 | |
| 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 } |
| 98 | |
| 99 | fun randomPassword () = |
| 100 | let |
| 101 | val proc = Unix.execute ("/usr/bin/pwgen", ["-cCnB", "8", "1"]) |
| 102 | in |
| 103 | case TextIO.inputLine (Unix.textInstreamOf proc) of |
| 104 | NONE => raise Fail "Couldn't execute pwgen" |
| 105 | | SOME line => |
| 106 | case String.tokens Char.isSpace line of |
| 107 | [s] => s |
| 108 | | _ => raise Fail "Couldn't parse output of pwgen" |
| 109 | end |
| 110 | |
| 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} = |
| 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))) |
| 127 | val unix_passwd = randomPassword () |
| 128 | in |
| 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 "); |
| 140 | mwrite (baseUrl); |
| 141 | mwrite ("confirm?id="); |
| 142 | mwrite (Int.toString id); |
| 143 | mwrite ("&p="); |
| 144 | mwrite passwd; |
| 145 | mwrite ("\n")), |
| 146 | id) then |
| 147 | SOME unix_passwd |
| 148 | else |
| 149 | NONE |
| 150 | end |
| 151 | | _ => raise Fail "Bad next sequence val" |
| 152 | end |
| 153 | |
| 154 | fun isIdent ch = Char.isLower ch orelse Char.isDigit ch orelse ch = #"-" |
| 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 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 |
| 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 = |
| 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 |
| 182 | |
| 183 | fun confirm (id, passwd) = |
| 184 | let |
| 185 | val db = getDb () |
| 186 | in |
| 187 | case C.oneOrNoRows db ($`SELECT unix_passwd FROM MemberApp WHERE id = ^(C.intToSql id) AND passwd = ^(C.stringToSql passwd) AND status = 0`) of |
| 188 | SOME [_] => |
| 189 | (C.dml db ($`UPDATE MemberApp SET status = 1, confirmed = CURRENT_TIMESTAMP WHERE id = ^(C.intToSql id)`); |
| 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 |
| 198 | end |
| 199 | |
| 200 | end |