cvsimport

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

structure App :> APP =
struct

open Init Sql Util

datatype status =
	 CONFIRMING
       | PENDING
       | ACCEPTED
       | REJECTED
       | ADDED

val statusFromInt =
    fn 0 => CONFIRMING
     | 1 => PENDING
     | 2 => ACCEPTED
     | 3 => REJECTED
     | 4 => ADDED
     | _ => raise C.Sql "Bad status"

val statusToInt =
    fn CONFIRMING => 0
     | PENDING => 1
     | ACCEPTED => 2
     | REJECTED => 3
     | ADDED => 4

fun statusFromSql v = statusFromInt (C.intFromSql v)
fun statusToSql s = C.intToSql (statusToInt s)

type app = { id : int, name : string, rname : string, gname : string option, email : string,
	     forward : bool, uses : string, other : string,
	     passwd : string, status : status, applied : C.timestamp, ipaddr : string option,
	     confirmed : C.timestamp option, decided : C.timestamp option,
	     msg : string, unix_passwd : string,
	     paypal : string option, checkout : string option }

fun mkAppRow [id, name, rname, gname, email, forward, uses, other, passwd, status,
	      applied, ipaddr, confirmed, decided, msg, unix_passwd, paypal, checkout] =
    { id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname,
      gname = Init.nullableFromSql C.stringFromSql gname,
      email = C.stringFromSql email, forward = C.boolFromSql forward,
      uses = C.stringFromSql uses, other = C.stringFromSql other, passwd = C.stringFromSql passwd,
      status = statusFromSql status, applied = C.timestampFromSql applied,
      ipaddr = Init.nullableFromSql C.stringFromSql ipaddr,
      confirmed = Init.nullableFromSql C.timestampFromSql confirmed,
      decided = Init.nullableFromSql C.timestampFromSql decided,
      msg = C.stringFromSql msg, unix_passwd = C.stringFromSql unix_passwd,
      paypal = Init.nullableFromSql C.stringFromSql paypal,
      checkout = Init.nullableFromSql C.stringFromSql checkout}
  | mkAppRow r = rowError ("app", r)

fun lookupApp id =
    case C.oneOrNoRows (getDb ()) ($`SELECT id, name, rname, gname, email, forward, uses, other, passwd, status, applied, ipaddr, confirmed, decided,
				            msg, unix_passwd, paypal, checkout
				     FROM MemberApp
				     WHERE id = ^(C.intToSql id)`) of
	SOME row => mkAppRow row
      | NONE => raise Fail "Membership application not found"

fun listApps status =
    C.map (getDb ()) mkAppRow ($`SELECT id, name, rname, gname, email, forward, uses, other, passwd, status, applied, ipaddr, confirmed, decided,
			                msg, unix_passwd, paypal, checkout
			         FROM MemberApp
			         WHERE status = ^(statusToSql status)
				   AND NOT (status = 2 AND decided < CURRENT_TIMESTAMP - INTERVAL '1 MONTH')
			         ORDER BY applied`)

fun mkVoteRow [id, name] = (C.intFromSql id, C.stringFromSql name)
  | mkVoteRow row = rowError ("app.vote", row)

fun votes id = C.map (getDb ()) mkVoteRow ($`SELECT usr, name
					     FROM AppVote JOIN WebUser ON usr = id
					     WHERE AppVote.app = ^(C.intToSql id)
					     ORDER BY name`)

fun vote (usr, app) = ignore (C.dml (getDb ()) ($`INSERT INTO AppVote (app, usr)
						  VALUES (^(C.intToSql app), ^(C.intToSql usr))`))

fun unvote (usr, app) = ignore (C.dml (getDb ()) ($`DELETE FROM AppVote WHERE app = ^(C.intToSql app) AND usr = ^(C.intToSql usr)`))

fun deny (app, msg) =
    let
	val entry = lookupApp app
	val _ =  C.dml (getDb ()) ($`UPDATE MemberApp
			             SET status = 3, msg = ^(C.stringToSql msg), decided = CURRENT_TIMESTAMP
				     WHERE id = ^(C.intToSql app)`)

	val mail = Mail.mopen ()
    in
	Mail.mwrite (mail, "From: Hcoop Application System <join");
	Mail.mwrite (mail, emailSuffix);
	Mail.mwrite (mail, ">\nTo: ");
	Mail.mwrite (mail, #email entry);
	Mail.mwrite (mail, "\nCc: ");
	Mail.mwrite (mail, boardEmail);
	Mail.mwrite (mail, "\nSubject: Application denied\n\nYour application for membership has been denied.  Reason:\n\n");
	Mail.mwrite (mail, msg);
	OS.Process.isSuccess (Mail.mclose mail)
    end

fun approve (app, msg) =
    let
	val entry = lookupApp app
	val _ =  C.dml (getDb ()) ($`UPDATE MemberApp
			             SET status = 2, msg = ^(C.stringToSql msg), decided = CURRENT_TIMESTAMP
				     WHERE id = ^(C.intToSql app)`)

	val mail = Mail.mopen ()
    in
	Mail.mwrite (mail, "To: ");
	Mail.mwrite (mail, #email entry);
	Mail.mwrite (mail, "\n");
	Mail.mwrite (mail, Util.readFile "/home/hcoop/portal/welcome.txt");
	Mail.mwrite (mail, msg);
	OS.Process.isSuccess (Mail.mclose mail)
    end

fun add app =
    let
	val _ = C.dml (getDb ()) ($`UPDATE MemberApp
				    SET status = 3
				    WHERE id = ^(C.intToSql app)`)

	val app = lookupApp app

	val outf = TextIO.openOut (Config.passwordFiles ^ #name app)
    in
	TextIO.output (outf, #unix_passwd app);
	TextIO.output1 (outf, #"\n");
	TextIO.closeOut outf
    end

fun welcome app =
    let
    	val app = lookupApp app

	val mail = Mail.mopen ()
    in
	Mail.mwrite (mail, "To: ");
	Mail.mwrite (mail, #email app);
	Mail.mwrite (mail, "\n");
	Mail.mwrite (mail, Util.readFile "/home/hcoop/portal/paid.txt");
	ignore (Mail.mclose mail)
    end

fun abortAdd app =
    ignore (C.dml (getDb ()) ($`UPDATE MemberApp
				SET status = 2
			        WHERE id = ^(C.intToSql app)`))

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 searchPaypal paypal =
    C.map (getDb ()) mkAppRow ($`SELECT id, name, rname, gname, email, forward, uses, other, passwd, status, applied, ipaddr, confirmed, decided,
			                msg, unix_passwd, paypal, checkout
			         FROM MemberApp
			         WHERE paypal = ^(C.stringToSql (normEmail paypal))
				   AND status = 2
				   AND decided >= CURRENT_TIMESTAMP - INTERVAL '1 MONTH'
			         ORDER BY applied`)

fun searchCheckout checkout =
    C.map (getDb ()) mkAppRow ($`SELECT id, name, rname, gname, email, forward, uses, other, passwd, status, applied, ipaddr, confirmed, decided,
			                msg, unix_passwd, paypal, checkout
			         FROM MemberApp
			         WHERE checkout = ^(C.stringToSql (normEmail checkout))
				   AND status = 2
				   AND decided >= CURRENT_TIMESTAMP - INTERVAL '1 MONTH'
			         ORDER BY applied`)

end