Propagate domain validity check code to app

[hcoop/zz_old/portal.git] / app / app.sml

structure App :> APP =
struct

val baseUrl = "http://join.hcoop.net/join/"
val portalUrl = "https://members.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_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 readFile fname =
    let
	val inf = TextIO.openIn fname

	fun readLines lines =
	    case TextIO.inputLine inf of
		NONE => String.concat (List.rev lines)
	      | SOME line => readLines (line :: lines)
    in
	readLines []
	before TextIO.closeIn inf
    end

fun readTosBody () = readFile "/home/hcoop/public_html/tos.body.html"
fun readTosAgree () = readFile "/home/hcoop/public_html/tos.agree.html"
fun readTosMinorAgree () = readFile "/home/hcoop/public_html/tos.agree.minor.html"

fun sendMail (to, subj, intro, footer, id) =
    let
	val (name, rname, gname, email, forward, uses, other) =
	    case C.oneOrNoRows (getDb ()) ($`SELECT name, rname, gname, email, forward, uses, other FROM MemberApp WHERE id = ^(C.intToSql id)`) of
		SOME [name, rname, gname, email, forward, uses, other] =>
		(C.stringFromSql name, C.stringFromSql rname,
		 if C.isNull gname then NONE else SOME (C.stringFromSql gname),
		 C.stringFromSql email,
		 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 System <join@hcoop.net>\nTo: ");
	mwrite (to);
	mwrite ("\nSubject: ");
	mwrite subj;
	mwrite ("\n\n");
	mwrite intro;
	mwrite ("\n\nUsername: ");
	mwrite (name);
	mwrite ("\nMember real name: ");
	mwrite (rname);
	case gname of
	    NONE => ()
	  | SOME gname => (mwrite "\nLegal guardian name: ";
			   mwrite gname);
	mwrite ("\nE-mail address: ");
	mwrite email;
	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, gname : string option, email : string,
		     forward : bool, uses : string, other : string }

fun apply {name, rname, gname, 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, gname, email, forward, uses, other, passwd, status, applied, msg)
			    VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname),
				    ^(case gname of NONE => "NULL" | SOME gname => C.stringToSql gname),
				    ^(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 orelse 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@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