| 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, unix_passwd : string, |
| 36 | paypal : string option, checkout : string option } |
| 37 | |
| 38 | fun mkAppRow [id, name, rname, gname, email, forward, uses, other, passwd, status, |
| 39 | applied, ipaddr, confirmed, decided, msg, unix_passwd, paypal, checkout] = |
| 40 | { id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname, |
| 41 | gname = Init.nullableFromSql C.stringFromSql gname, |
| 42 | email = C.stringFromSql email, forward = C.boolFromSql forward, |
| 43 | uses = C.stringFromSql uses, other = C.stringFromSql other, passwd = C.stringFromSql passwd, |
| 44 | status = statusFromSql status, applied = C.timestampFromSql applied, |
| 45 | ipaddr = Init.nullableFromSql C.stringFromSql ipaddr, |
| 46 | confirmed = Init.nullableFromSql C.timestampFromSql confirmed, |
| 47 | decided = Init.nullableFromSql C.timestampFromSql decided, |
| 48 | msg = C.stringFromSql msg, unix_passwd = C.stringFromSql unix_passwd, |
| 49 | paypal = Init.nullableFromSql C.stringFromSql paypal, |
| 50 | checkout = Init.nullableFromSql C.stringFromSql checkout} |
| 51 | | mkAppRow r = rowError ("app", r) |
| 52 | |
| 53 | fun lookupApp id = |
| 54 | case C.oneOrNoRows (getDb ()) ($`SELECT id, name, rname, gname, email, forward, uses, other, passwd, status, applied, ipaddr, confirmed, decided, |
| 55 | msg, unix_passwd, paypal, checkout |
| 56 | FROM MemberApp |
| 57 | WHERE id = ^(C.intToSql id)`) of |
| 58 | SOME row => mkAppRow row |
| 59 | | NONE => raise Fail "Membership application not found" |
| 60 | |
| 61 | fun listApps status = |
| 62 | C.map (getDb ()) mkAppRow ($`SELECT id, name, rname, gname, email, forward, uses, other, passwd, status, applied, ipaddr, confirmed, decided, |
| 63 | msg, unix_passwd, paypal, checkout |
| 64 | FROM MemberApp |
| 65 | WHERE status = ^(statusToSql status) |
| 66 | AND NOT (status = 2 AND decided < CURRENT_TIMESTAMP - INTERVAL '1 MONTH') |
| 67 | ORDER BY applied`) |
| 68 | |
| 69 | fun mkVoteRow [id, name] = (C.intFromSql id, C.stringFromSql name) |
| 70 | | mkVoteRow row = rowError ("app.vote", row) |
| 71 | |
| 72 | fun votes id = C.map (getDb ()) mkVoteRow ($`SELECT usr, name |
| 73 | FROM AppVote JOIN WebUser ON usr = id |
| 74 | WHERE AppVote.app = ^(C.intToSql id) |
| 75 | ORDER BY name`) |
| 76 | |
| 77 | fun vote (usr, app) = ignore (C.dml (getDb ()) ($`INSERT INTO AppVote (app, usr) |
| 78 | VALUES (^(C.intToSql app), ^(C.intToSql usr))`)) |
| 79 | |
| 80 | fun unvote (usr, app) = ignore (C.dml (getDb ()) ($`DELETE FROM AppVote WHERE app = ^(C.intToSql app) AND usr = ^(C.intToSql usr)`)) |
| 81 | |
| 82 | fun deny (app, msg) = |
| 83 | let |
| 84 | val entry = lookupApp app |
| 85 | val _ = C.dml (getDb ()) ($`UPDATE MemberApp |
| 86 | SET status = 3, msg = ^(C.stringToSql msg), decided = CURRENT_TIMESTAMP |
| 87 | WHERE id = ^(C.intToSql app)`) |
| 88 | |
| 89 | val mail = Mail.mopen () |
| 90 | in |
| 91 | Mail.mwrite (mail, "From: Hcoop Application System <join"); |
| 92 | Mail.mwrite (mail, emailSuffix); |
| 93 | Mail.mwrite (mail, ">\nTo: "); |
| 94 | Mail.mwrite (mail, #email entry); |
| 95 | Mail.mwrite (mail, "\nCc: "); |
| 96 | Mail.mwrite (mail, boardEmail); |
| 97 | Mail.mwrite (mail, "\nSubject: Application denied\n\nYour application for membership has been denied. Reason:\n\n"); |
| 98 | Mail.mwrite (mail, msg); |
| 99 | OS.Process.isSuccess (Mail.mclose mail) |
| 100 | end |
| 101 | |
| 102 | fun approve (app, msg) = |
| 103 | let |
| 104 | val entry = lookupApp app |
| 105 | val _ = C.dml (getDb ()) ($`UPDATE MemberApp |
| 106 | SET status = 2, msg = ^(C.stringToSql msg), decided = CURRENT_TIMESTAMP |
| 107 | WHERE id = ^(C.intToSql app)`) |
| 108 | |
| 109 | val mail = Mail.mopen () |
| 110 | in |
| 111 | Mail.mwrite (mail, "To: "); |
| 112 | Mail.mwrite (mail, #email entry); |
| 113 | Mail.mwrite (mail, "\n"); |
| 114 | Mail.mwrite (mail, Util.readFile "/home/hcoop/portal/welcome.txt"); |
| 115 | Mail.mwrite (mail, msg); |
| 116 | OS.Process.isSuccess (Mail.mclose mail) |
| 117 | end |
| 118 | |
| 119 | fun add app = |
| 120 | let |
| 121 | val _ = C.dml (getDb ()) ($`UPDATE MemberApp |
| 122 | SET status = 3 |
| 123 | WHERE id = ^(C.intToSql app)`) |
| 124 | |
| 125 | val app = lookupApp app |
| 126 | |
| 127 | val outf = TextIO.openOut (Config.passwordFiles ^ #name app) |
| 128 | in |
| 129 | TextIO.output (outf, #unix_passwd app); |
| 130 | TextIO.closeOut outf |
| 131 | end |
| 132 | |
| 133 | fun welcome app = |
| 134 | let |
| 135 | val app = lookupApp app |
| 136 | |
| 137 | val mail = Mail.mopen () |
| 138 | in |
| 139 | Mail.mwrite (mail, "To: "); |
| 140 | Mail.mwrite (mail, #email app); |
| 141 | Mail.mwrite (mail, "\n"); |
| 142 | Mail.mwrite (mail, Util.readFile "/home/hcoop/portal/paid.txt"); |
| 143 | ignore (Mail.mclose mail) |
| 144 | end |
| 145 | |
| 146 | fun abortAdd app = |
| 147 | ignore (C.dml (getDb ()) ($`UPDATE MemberApp |
| 148 | SET status = 2 |
| 149 | WHERE id = ^(C.intToSql app)`)) |
| 150 | |
| 151 | fun readFile fname = |
| 152 | let |
| 153 | val inf = TextIO.openIn fname |
| 154 | |
| 155 | fun readLines lines = |
| 156 | case TextIO.inputLine inf of |
| 157 | NONE => String.concat (List.rev lines) |
| 158 | | SOME line => readLines (line :: lines) |
| 159 | in |
| 160 | readLines [] |
| 161 | before TextIO.closeIn inf |
| 162 | end |
| 163 | |
| 164 | fun readTosBody () = readFile "/home/hcoop/public_html/tos.body.html" |
| 165 | fun readTosAgree () = readFile "/home/hcoop/public_html/tos.agree.html" |
| 166 | fun readTosMinorAgree () = readFile "/home/hcoop/public_html/tos.agree.minor.html" |
| 167 | |
| 168 | fun searchPaypal paypal = |
| 169 | C.map (getDb ()) mkAppRow ($`SELECT id, name, rname, gname, email, forward, uses, other, passwd, status, applied, ipaddr, confirmed, decided, |
| 170 | msg, unix_passwd, paypal, checkout |
| 171 | FROM MemberApp |
| 172 | WHERE paypal = ^(C.stringToSql (Util.allLower paypal)) |
| 173 | AND status = 2 |
| 174 | AND decided >= CURRENT_TIMESTAMP - INTERVAL '1 MONTH' |
| 175 | ORDER BY applied`) |
| 176 | |
| 177 | fun searchCheckout checkout = |
| 178 | C.map (getDb ()) mkAppRow ($`SELECT id, name, rname, gname, email, forward, uses, other, passwd, status, applied, ipaddr, confirmed, decided, |
| 179 | msg, unix_passwd, paypal, checkout |
| 180 | FROM MemberApp |
| 181 | WHERE checkout = ^(C.stringToSql (Util.allLower checkout)) |
| 182 | AND status = 2 |
| 183 | AND decided >= CURRENT_TIMESTAMP - INTERVAL '1 MONTH' |
| 184 | ORDER BY applied`) |
| 185 | |
| 186 | end |