| PENDING
| ACCEPTED
| REJECTED
+ | ADDED
+ | BEING_ADDED
val statusFromInt =
fn 0 => CONFIRMING
| 1 => PENDING
| 2 => ACCEPTED
| 3 => REJECTED
+ | 4 => ADDED
+ | 5 => BEING_ADDED
| _ => raise C.Sql "Bad status"
val statusToInt =
| PENDING => 1
| ACCEPTED => 2
| REJECTED => 3
+ | ADDED => 4
+ | BEING_ADDED => 5
fun statusFromSql v = statusFromInt (C.intFromSql v)
fun statusToSql s = C.intToSql (statusToInt s)
-type app = { id : int, name : string, rname : string, email : string,
+type app = { id : int, name : string, rname : string, gname : string option, email : string,
forward : bool, uses : string, other : string,
- passwd : string, status : status, stamp : C.timestamp }
+ 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, email, forward, uses, other, passwd, status, stamp] =
+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, stamp = C.timestampFromSql stamp }
+ 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, email, forward, uses, other, passwd, status, stamp
- FROM MemberApp
- WHERE id = ^(C.intToSql id)`) of
+ 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"
-end
\ No newline at end of file
+fun listApps statuses =
+ 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 IN (^(String.concatWith "," (map statusToSql statuses)))
+ 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 preAdd app =
+ let
+ val _ = C.dml (getDb ()) ($`UPDATE MemberApp
+ SET status = 5
+ 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 add app =
+ let
+ val appR = lookupApp app
+ in
+ ignore (C.dml (getDb ()) ($`UPDATE MemberApp
+ SET status = 4
+ WHERE id = ^(C.intToSql app)`));
+ OS.FileSys.remove (Config.passwordFiles ^ #name appR)
+ 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
HCoop / bpt / portal.git / blobdiff