app/app.sml

   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
  36 fun sendMail (to, subj, intro, footer, id) =
  37     let
  38         val (name, rname, forward, uses, other) =
  39             case C.oneOrNoRows (getDb ()) ($`SELECT name, rname, forward, uses, other FROM MemberApp WHERE id = ^(C.intToSql id)`) of
  40                 SOME [name, rname, forward, uses, other] => (C.stringFromSql name, C.stringFromSql rname,
  41                                                              C.boolFromSql forward, C.stringFromSql uses,
  42                                                              C.stringFromSql other)
  43               | _ => raise Fail "Bad sendMail row"
  44
  45         val proc = Unix.execute ("/usr/sbin/exim4", ["-t"])
  46         fun mwrite s = TextIO.output (Unix.textOutstreamOf proc, s)
  47     in
  48         mwrite ("From: Hcoop Application System <join@hcoop.net>\nTo: ");
  49         mwrite (to);
  50         mwrite ("\nSubject: ");
  51         mwrite subj;
  52         mwrite ("\n\n");
  53         mwrite intro;
  54         mwrite ("\n\nUsername: ");
  55         mwrite (name);
  56         mwrite ("\nReal name: ");
  57         mwrite (rname);
  58         mwrite ("\nForward e-mail: ");
  59         mwrite (if forward then "yes" else "no");
  60         mwrite ("\n\nDesired uses:\n");
  61         mwrite (uses);
  62         mwrite ("\n\nOther information:\n");
  63         mwrite (other);
  64         mwrite ("\n\n");
  65         footer mwrite;
  66         OS.Process.isSuccess (Unix.reap proc)
  67     end
  68
  69 type application = { name : string, rname : string, email : string,
  70                      forward : bool, uses : string, other : string }
  71
  72 fun apply {name, rname, email, forward, uses, other} =
  73     let
  74         val db = getDb ()
  75     in
  76         case C.oneRow db ($`SELECT nextval('MemberAppSeq')`) of
  77             [id] =>
  78             let
  79                 val id = C.intFromSql id
  80                 val passwd = Int.toString (Int.abs (Random.randInt (!rnd)))
  81             in
  82                 C.dml db ($`INSERT INTO MemberApp (id, name, rname, email, forward, uses, other, passwd, status, applied, msg)
  83                             VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname),
  84                                     ^(C.stringToSql email), ^(C.boolToSql forward), ^(C.stringToSql uses),
  85                                     ^(C.stringToSql other), ^(C.stringToSql passwd), 0, CURRENT_TIMESTAMP, '')`);
  86                 sendMail (email, "Confirm membership application",
  87                           "We've received a request to join the Internet Hosting Cooperative (hcoop.net) with this e-mail address.",
  88                           fn mwrite => (mwrite ("To confirm this application, visit ");
  89                                         mwrite (baseUrl);
  90                                         mwrite ("confirm?id=");
  91                                         mwrite (Int.toString id);
  92                                         mwrite ("&p=");
  93                                         mwrite (passwd);
  94                                         mwrite ("\n")),
  95                           id)
  96             end
  97       | _ => raise Fail "Bad next sequence val"
  98     end
  99
 100 fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
 101
 102 fun validHost s =
 103     size s > 0 andalso size s < 20 andalso List.all isIdent (String.explode s)
 104
 105 fun validDomain s =
 106     size s > 0 andalso size s < 100 andalso List.all validHost (String.fields (fn ch => ch = #".") s)
 107
 108 fun validUser s =
 109     size s > 0 andalso size s < 50 andalso List.all
 110                                                (fn ch => isIdent ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-" orelse ch = #"+")
 111                                                (String.explode s)
 112
 113 fun validEmailUser s =
 114     size s > 0 andalso size s < 50 andalso List.all
 115                                                (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-" orelse ch = #"+")
 116                                                (String.explode s)
 117
 118 fun validEmail s =
 119     (case String.fields (fn ch => ch = #"@") s of
 120          [user, host] => validEmailUser user andalso validDomain host
 121        | _ => false)
 122
 123 fun userExists name =
 124     (Posix.SysDB.getpwnam name; true) handle OS.SysErr _ => false
 125
 126 fun confirm (id, passwd) =
 127     let
 128         val db = getDb ()
 129     in
 130         case C.oneOrNoRows db ($`SELECT id FROM MemberApp WHERE id = ^(C.intToSql id) AND passwd = ^(C.stringToSql passwd) AND status = 0`) of
 131             SOME _ =>
 132             (C.dml db ($`UPDATE MemberApp SET status = 1, confirmed = CURRENT_TIMESTAMP WHERE id = ^(C.intToSql id)`);
 133              sendMail ("board.fake@hcoop.net",
 134                        "New membership application",
 135                        "We've received a new request to join hcoop.",
 136                        fn mwrite => (mwrite ("Open applications: ");
 137                                      mwrite (portalUrl);
 138                                      mwrite ("apps")),
 139                        id))
 140           | NONE => false
 141     end
 142
 143 end