Changes rolling out beta version

[bpt/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, email : string,
	     forward : bool, uses : string, other : string,
	     passwd : string, status : status, applied : C.timestamp,
	     confirmed : C.timestamp option, decided : C.timestamp option,
	     msg : string}

fun mkAppRow [id, name, rname, email, forward, uses, other, passwd, status, applied, confirmed, decided, msg] =
    { id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname,
      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,
      confirmed = if C.isNull confirmed then NONE else SOME (C.timestampFromSql confirmed),
      decided = if C.isNull decided then NONE else SOME (C.timestampFromSql decided),
      msg = C.stringFromSql msg}
  | mkAppRow r = rowError ("app", r)

fun lookupApp id =
    case C.oneOrNoRows (getDb ()) ($`SELECT id, name, rname, email, forward, uses, other, passwd, status, applied, confirmed, decided, msg
				     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, email, forward, uses, other, passwd, status, applied, confirmed, decided, msg
			         FROM MemberApp
			         WHERE status = ^(statusToSql status)
			         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 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@hcoop.net>\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, "From: Hcoop Application System <join@hcoop.net>\nTo: ");
	Mail.mwrite (mail, #email entry);
	Mail.mwrite (mail, "\nCc: ");
	Mail.mwrite (mail, boardEmail);
	Mail.mwrite (mail, "\nSubject: Application approved\n\nYour application for membership has been approved!  Welcome to hcoop!\n\n");
	Mail.mwrite (mail, msg);
	OS.Process.isSuccess (Mail.mclose mail)
    end

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

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

end