X-Git-Url: http://git.hcoop.net/hcoop/portal.git/blobdiff_plain/a90da8b1a537003cb21a3a4c0199cf3e88c510ad..0e737d9f261c698b705f5f388650ecb1d88f6749:/app.sml diff --git a/app.sml b/app.sml index 5e2c547..aa9fb15 100644 --- a/app.sml +++ b/app.sml @@ -8,12 +8,16 @@ datatype status = | 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 = @@ -21,26 +25,176 @@ 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 \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