app/app.sml

   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