New member applications

[bpt/portal.git] / app / app.sml

diff --git a/app/app.sml b/app/app.sml
new file mode 100644 (file)
index 0000000..0f4f83a
--- /dev/null
+++ b/app/app.sml
@@ -0,0 +1,143 @@
+structure App :> APP =
+struct
+
+val baseUrl = "http://join.hcoop.net/join/"
+val portalUrl = "http://users.hcoop.net/portal/"
+
+open Sql
+
+structure C = PgClient
+
+val db = ref (NONE : C.conn option)
+
+val rnd = ref (Random.rand (0, 0))
+
+fun init () = 
+    let
+       val c = C.conn "dbname='hcoop'"
+    in
+       db := SOME c;
+       C.dml c "BEGIN";
+       rnd := Random.rand (SysWord.toInt (Posix.Process.pidToWord (Posix.ProcEnv.getpid ())),
+                           SysWord.toInt (Posix.Process.pidToWord (Posix.ProcEnv.getpid ())))
+    end
+
+fun getDb () = valOf (!db)
+
+fun done () =
+    let
+       val c = getDb ()
+    in
+       C.dml c "COMMIT";
+       C.close c;
+       db := NONE
+    end
+
+fun sendMail (to, subj, intro, footer, id) =
+    let
+       val (name, rname, forward, uses, other) =
+           case C.oneOrNoRows (getDb ()) ($`SELECT name, rname, forward, uses, other FROM MemberApp WHERE id = ^(C.intToSql id)`) of
+               SOME [name, rname, forward, uses, other] => (C.stringFromSql name, C.stringFromSql rname,
+                                                            C.boolFromSql forward, C.stringFromSql uses,
+                                                            C.stringFromSql other)
+             | _ => raise Fail "Bad sendMail row"
+
+       val proc = Unix.execute ("/usr/sbin/exim4", ["-t"])
+       fun mwrite s = TextIO.output (Unix.textOutstreamOf proc, s)
+    in
+       mwrite ("From: Hcoop Application Confirmation <join@hcoop.net>\nTo: ");
+       mwrite (to);
+       mwrite ("\nSubject: ");
+       mwrite subj;
+       mwrite ("\n\n");
+       mwrite intro;
+       mwrite ("\n\nUsername: ");
+       mwrite (name);
+       mwrite ("\nReal name: ");
+       mwrite (rname);
+       mwrite ("\nForward e-mail: ");
+       mwrite (if forward then "yes" else "no");
+       mwrite ("\n\nDesired uses:\n");
+       mwrite (uses);
+       mwrite ("\n\nOther information:\n");
+       mwrite (other);
+       mwrite ("\n\n");
+       footer mwrite;
+       OS.Process.isSuccess (Unix.reap proc)
+    end
+
+type application = { name : string, rname : string, email : string,
+                    forward : bool, uses : string, other : string }
+
+fun apply {name, rname, email, forward, uses, other} =
+    let
+       val db = getDb ()
+    in
+       case C.oneRow db ($`SELECT nextval('MemberAppSeq')`) of
+           [id] =>
+           let
+               val id = C.intFromSql id
+               val passwd = Int.toString (Int.abs (Random.randInt (!rnd)))
+           in
+               C.dml db ($`INSERT INTO MemberApp (id, name, rname, email, forward, uses, other, passwd, status, applied)
+                           VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname),
+                                   ^(C.stringToSql email), ^(C.boolToSql forward), ^(C.stringToSql uses),
+                                   ^(C.stringToSql other), ^(C.stringToSql passwd), 0, CURRENT_TIMESTAMP)`);
+               sendMail (email, "Confirm membership application",
+                         "We've received a request to join the Internet Hosting Cooperative (hcoop.net) with this e-mail address.",
+                         fn mwrite => (mwrite ("To confirm this application, visit ");
+                                       mwrite (baseUrl);
+                                       mwrite ("confirm?id=");
+                                       mwrite (Int.toString id);
+                                       mwrite ("&p=");
+                                       mwrite (passwd);
+                                       mwrite ("\n")),
+                         id)
+           end
+      | _ => raise Fail "Bad next sequence val"
+    end
+
+fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
+
+fun validHost s =
+    size s > 0 andalso size s < 20 andalso List.all isIdent (String.explode s)
+                                                 
+fun validDomain s =
+    size s > 0 andalso size s < 100 andalso List.all validHost (String.fields (fn ch => ch = #".") s)
+
+fun validUser s =
+    size s > 0 andalso size s < 50 andalso List.all
+                                              (fn ch => isIdent ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-" orelse ch = #"+")
+                                              (String.explode s)
+
+fun validEmailUser s =
+    size s > 0 andalso size s < 50 andalso List.all
+                                              (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-" orelse ch = #"+")
+                                              (String.explode s)
+
+fun validEmail s =
+    (case String.fields (fn ch => ch = #"@") s of
+        [user, host] => validEmailUser user andalso validDomain host
+       | _ => false)
+
+fun userExists name =
+    (Posix.SysDB.getpwnam name; true) handle OS.SysErr _ => false
+
+fun confirm (id, passwd) =
+    let
+       val db = getDb ()
+    in
+       case C.oneOrNoRows db ($`SELECT id FROM MemberApp WHERE id = ^(C.intToSql id) AND passwd = ^(C.stringToSql passwd) AND status = 0`) of
+           SOME _ =>
+           (C.dml db ($`UPDATE MemberApp SET status = 1, confirmed = CURRENT_TIMESTAMP WHERE id = ^(C.intToSql id)`);
+            sendMail ("board.fake@hcoop.net",
+                      "New membership application",
+                      "We've received a new request to join hcoop.",
+                      fn mwrite => (mwrite ("Open applications: ");
+                                    mwrite (portalUrl);
+                                    mwrite ("apps")),
+                      id))
+         | NONE => false
+    end
+
+end
\ No newline at end of file