| 1 | structure App :> APP = |
| 2 | struct |
| 3 | |
| 4 | open Init Sql Util |
| 5 | |
| 6 | datatype status = |
| 7 | CONFIRMING |
| 8 | | PENDING |
| 9 | | ACCEPTED |
| 10 | | REJECTED |
| 11 | | ADDED |
| 12 | |
| 13 | val statusFromInt = |
| 14 | fn 0 => CONFIRMING |
| 15 | | 1 => PENDING |
| 16 | | 2 => ACCEPTED |
| 17 | | 3 => REJECTED |
| 18 | | 4 => ADDED |
| 19 | | _ => raise C.Sql "Bad status" |
| 20 | |
| 21 | val statusToInt = |
| 22 | fn CONFIRMING => 0 |
| 23 | | PENDING => 1 |
| 24 | | ACCEPTED => 2 |
| 25 | | REJECTED => 3 |
| 26 | | ADDED => 4 |
| 27 | |
| 28 | fun statusFromSql v = statusFromInt (C.intFromSql v) |
| 29 | fun statusToSql s = C.intToSql (statusToInt s) |
| 30 | |
| 31 | type app = { id : int, name : string, rname : string, gname : string option, email : string, |
| 32 | forward : bool, uses : string, other : string, |
| 33 | passwd : string, status : status, applied : C.timestamp, ipaddr : string option, |
| 34 | confirmed : C.timestamp option, decided : C.timestamp option, |
| 35 | msg : string} |
| 36 | |
| 37 | fun mkAppRow [id, name, rname, gname, email, forward, uses, other, passwd, status, |
| 38 | applied, ipaddr, confirmed, decided, msg] = |
| 39 | { id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname, |
| 40 | gname = (if C.isNull gname then NONE else SOME (C.stringFromSql gname)), |
| 41 | email = C.stringFromSql email, forward = C.boolFromSql forward, |
| 42 | uses = C.stringFromSql uses, other = C.stringFromSql other, passwd = C.stringFromSql passwd, |
| 43 | status = statusFromSql status, applied = C.timestampFromSql applied, |
| 44 | ipaddr = (if C.isNull ipaddr then NONE else SOME (C.stringFromSql ipaddr)), |
| 45 | confirmed = if C.isNull confirmed then NONE else SOME (C.timestampFromSql confirmed), |
| 46 | decided = if C.isNull decided then NONE else SOME (C.timestampFromSql decided), |
| 47 | msg = C.stringFromSql msg} |
| 48 | | mkAppRow r = rowError ("app", r) |
| 49 | |
| 50 | fun lookupApp id = |
| 51 | case C.oneOrNoRows (getDb ()) ($`SELECT id, name, rname, gname, email, forward, uses, other, passwd, status, applied, ipaddr, confirmed, decided, msg |
| 52 | FROM MemberApp |
| 53 | WHERE id = ^(C.intToSql id)`) of |
| 54 | SOME row => mkAppRow row |
| 55 | | NONE => raise Fail "Membership application not found" |
| 56 | |
| 57 | fun listApps status = |
| 58 | C.map (getDb ()) mkAppRow ($`SELECT id, name, rname, gname, email, forward, uses, other, passwd, status, applied, ipaddr, confirmed, decided, msg |
| 59 | FROM MemberApp |
| 60 | WHERE status = ^(statusToSql status) |
| 61 | ORDER BY applied`) |
| 62 | |
| 63 | fun mkVoteRow [id, name] = (C.intFromSql id, C.stringFromSql name) |
| 64 | | mkVoteRow row = rowError ("app.vote", row) |
| 65 | |
| 66 | fun votes id = C.map (getDb ()) mkVoteRow ($`SELECT usr, name |
| 67 | FROM AppVote JOIN WebUser ON usr = id |
| 68 | WHERE AppVote.app = ^(C.intToSql id) |
| 69 | ORDER BY name`) |
| 70 | |
| 71 | fun vote (usr, app) = ignore (C.dml (getDb ()) ($`INSERT INTO AppVote (app, usr) |
| 72 | VALUES (^(C.intToSql app), ^(C.intToSql usr))`)) |
| 73 | |
| 74 | fun unvote (usr, app) = ignore (C.dml (getDb ()) ($`DELETE FROM AppVote WHERE app = ^(C.intToSql app) AND usr = ^(C.intToSql usr)`)) |
| 75 | |
| 76 | fun deny (app, msg) = |
| 77 | let |
| 78 | val entry = lookupApp app |
| 79 | val _ = C.dml (getDb ()) ($`UPDATE MemberApp |
| 80 | SET status = 3, msg = ^(C.stringToSql msg), decided = CURRENT_TIMESTAMP |
| 81 | WHERE id = ^(C.intToSql app)`) |
| 82 | |
| 83 | val mail = Mail.mopen () |
| 84 | in |
| 85 | Mail.mwrite (mail, "From: Hcoop Application System <join"); |
| 86 | Mail.mwrite (mail, emailSuffix); |
| 87 | Mail.mwrite (mail, ">\nTo: "); |
| 88 | Mail.mwrite (mail, #email entry); |
| 89 | Mail.mwrite (mail, "\nCc: "); |
| 90 | Mail.mwrite (mail, boardEmail); |
| 91 | Mail.mwrite (mail, "\nSubject: Application denied\n\nYour application for membership has been denied. Reason:\n\n"); |
| 92 | Mail.mwrite (mail, msg); |
| 93 | OS.Process.isSuccess (Mail.mclose mail) |
| 94 | end |
| 95 | |
| 96 | fun approve (app, msg) = |
| 97 | let |
| 98 | val entry = lookupApp app |
| 99 | val _ = C.dml (getDb ()) ($`UPDATE MemberApp |
| 100 | SET status = 2, msg = ^(C.stringToSql msg), decided = CURRENT_TIMESTAMP |
| 101 | WHERE id = ^(C.intToSql app)`) |
| 102 | |
| 103 | val mail = Mail.mopen () |
| 104 | in |
| 105 | Mail.mwrite (mail, "To: "); |
| 106 | Mail.mwrite (mail, #email entry); |
| 107 | Mail.mwrite (mail, "\n"); |
| 108 | Mail.mwrite (mail, Util.readFile "/home/hcoop/portal/welcome.txt"); |
| 109 | Mail.mwrite (mail, msg); |
| 110 | OS.Process.isSuccess (Mail.mclose mail) |
| 111 | end |
| 112 | |
| 113 | fun add app = |
| 114 | ignore (C.dml (getDb ()) ($`UPDATE MemberApp |
| 115 | SET status = 3 |
| 116 | WHERE id = ^(C.intToSql app)`)) |
| 117 | |
| 118 | fun abortAdd app = |
| 119 | ignore (C.dml (getDb ()) ($`UPDATE MemberApp |
| 120 | SET status = 2 |
| 121 | WHERE id = ^(C.intToSql app)`)) |
| 122 | |
| 123 | fun readFile fname = |
| 124 | let |
| 125 | val inf = TextIO.openIn fname |
| 126 | |
| 127 | fun readLines lines = |
| 128 | case TextIO.inputLine inf of |
| 129 | NONE => String.concat (List.rev lines) |
| 130 | | SOME line => readLines (line :: lines) |
| 131 | in |
| 132 | readLines [] |
| 133 | before TextIO.closeIn inf |
| 134 | end |
| 135 | |
| 136 | fun readTosBody () = readFile "/home/hcoop/public_html/tos.body.html" |
| 137 | fun readTosAgree () = readFile "/home/hcoop/public_html/tos.agree.html" |
| 138 | fun readTosMinorAgree () = readFile "/home/hcoop/public_html/tos.agree.minor.html" |
| 139 | |
| 140 | end |