| 1 | structure App :> APP = |
| 2 | struct |
| 3 | |
| 4 | val baseUrl = "https://join.hcoop.net/join/" |
| 5 | val portalUrl = "https://members2.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_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 | |
| 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 "/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" |
| 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 | |
| 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 | |
| 110 | fun apply {name, rname, gname, email, forward, uses, other} = |
| 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))) |
| 119 | val unix_passwd = randomPassword () |
| 120 | in |
| 121 | C.dml db ($`INSERT INTO MemberApp (id, name, rname, gname, email, forward, uses, other, passwd, status, applied, msg, unix_passwd) |
| 122 | VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), |
| 123 | ^(case gname of NONE => "NULL" | SOME gname => C.stringToSql gname), |
| 124 | ^(C.stringToSql email), ^(C.boolToSql forward), ^(C.stringToSql uses), |
| 125 | ^(C.stringToSql other), ^(C.stringToSql passwd), 0, CURRENT_TIMESTAMP, |
| 126 | '', ^(C.stringToSql unix_passwd))`); |
| 127 | sendMail (email, "Confirm membership application", |
| 128 | "We've received a request to join the Internet Hosting Cooperative (hcoop.net) with this e-mail address.", |
| 129 | fn mwrite => (mwrite ("To confirm this application, visit "); |
| 130 | mwrite (baseUrl); |
| 131 | mwrite ("confirm?id="); |
| 132 | mwrite (Int.toString id); |
| 133 | mwrite ("&p="); |
| 134 | mwrite passwd; |
| 135 | mwrite ("\n")), |
| 136 | id) |
| 137 | end |
| 138 | | _ => raise Fail "Bad next sequence val" |
| 139 | end |
| 140 | |
| 141 | fun isIdent ch = Char.isLower ch orelse Char.isDigit ch orelse ch = #"-" |
| 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 |
| 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] => |
| 173 | (C.dml db ($`UPDATE MemberApp SET status = 1, confirmed = CURRENT_TIMESTAMP WHERE id = ^(C.intToSql id)`); |
| 174 | if sendMail ("board@hcoop.net", |
| 175 | "New membership application", |
| 176 | "We've received a new request to join hcoop.", |
| 177 | fn mwrite => (mwrite ("Open applications: "); |
| 178 | mwrite (portalUrl); |
| 179 | mwrite ("apps")), |
| 180 | id) then |
| 181 | SOME (C.stringFromSql unix_passwd) |
| 182 | else |
| 183 | NONE) |
| 184 | | NONE => NONE |
| 185 | end |
| 186 | |
| 187 | end |