| 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, email : string, |
| 32 | forward : bool, uses : string, other : string, |
| 33 | passwd : string, status : status, applied : C.timestamp, |
| 34 | confirmed : C.timestamp option, decided : C.timestamp option, |
| 35 | msg : string} |
| 36 | |
| 37 | fun mkAppRow [id, name, rname, email, forward, uses, other, passwd, status, applied, confirmed, decided, msg] = |
| 38 | { id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname, |
| 39 | email = C.stringFromSql email, forward = C.boolFromSql forward, |
| 40 | uses = C.stringFromSql uses, other = C.stringFromSql other, passwd = C.stringFromSql passwd, |
| 41 | status = statusFromSql status, applied = C.timestampFromSql applied, |
| 42 | confirmed = if C.isNull confirmed then NONE else SOME (C.timestampFromSql confirmed), |
| 43 | decided = if C.isNull decided then NONE else SOME (C.timestampFromSql decided), |
| 44 | msg = C.stringFromSql msg} |
| 45 | | mkAppRow r = rowError ("app", r) |
| 46 | |
| 47 | fun lookupApp id = |
| 48 | case C.oneOrNoRows (getDb ()) ($`SELECT id, name, rname, email, forward, uses, other, passwd, status, applied, confirmed, decided, msg |
| 49 | FROM MemberApp |
| 50 | WHERE id = ^(C.intToSql id)`) of |
| 51 | SOME row => mkAppRow row |
| 52 | | NONE => raise Fail "Membership application not found" |
| 53 | |
| 54 | fun listApps status = |
| 55 | C.map (getDb ()) mkAppRow ($`SELECT id, name, rname, email, forward, uses, other, passwd, status, applied, confirmed, decided, msg |
| 56 | FROM MemberApp |
| 57 | WHERE status = ^(statusToSql status) |
| 58 | ORDER BY applied`) |
| 59 | |
| 60 | fun mkVoteRow [id, name] = (C.intFromSql id, C.stringFromSql name) |
| 61 | | mkVoteRow row = rowError ("app.vote", row) |
| 62 | |
| 63 | fun votes id = C.map (getDb ()) mkVoteRow ($`SELECT usr, name |
| 64 | FROM AppVote JOIN WebUser ON usr = id |
| 65 | WHERE app = ^(C.intToSql id) |
| 66 | ORDER BY name`) |
| 67 | |
| 68 | fun vote (usr, app) = ignore (C.dml (getDb ()) ($`INSERT INTO AppVote (app, usr) |
| 69 | VALUES (^(C.intToSql app), ^(C.intToSql usr))`)) |
| 70 | |
| 71 | fun unvote (usr, app) = ignore (C.dml (getDb ()) ($`DELETE FROM AppVote WHERE app = ^(C.intToSql app) AND usr = ^(C.intToSql usr)`)) |
| 72 | |
| 73 | fun deny (app, msg) = |
| 74 | let |
| 75 | val entry = lookupApp app |
| 76 | val _ = C.dml (getDb ()) ($`UPDATE MemberApp |
| 77 | SET status = 3, msg = ^(C.stringToSql msg), decided = CURRENT_TIMESTAMP |
| 78 | WHERE id = ^(C.intToSql app)`) |
| 79 | |
| 80 | val mail = Mail.mopen () |
| 81 | in |
| 82 | Mail.mwrite (mail, "From: Hcoop Application System <join@hcoop.net>\nTo: "); |
| 83 | Mail.mwrite (mail, #email entry); |
| 84 | Mail.mwrite (mail, "\nCc: "); |
| 85 | Mail.mwrite (mail, boardEmail); |
| 86 | Mail.mwrite (mail, "\nSubject: Application denied\n\nYour application for membership has been denied. Reason:\n\n"); |
| 87 | Mail.mwrite (mail, msg); |
| 88 | OS.Process.isSuccess (Mail.mclose mail) |
| 89 | end |
| 90 | |
| 91 | fun approve (app, msg) = |
| 92 | let |
| 93 | val entry = lookupApp app |
| 94 | val _ = C.dml (getDb ()) ($`UPDATE MemberApp |
| 95 | SET status = 2, msg = ^(C.stringToSql msg), decided = CURRENT_TIMESTAMP |
| 96 | WHERE id = ^(C.intToSql app)`) |
| 97 | |
| 98 | val mail = Mail.mopen () |
| 99 | in |
| 100 | Mail.mwrite (mail, "From: Hcoop Application System <join@hcoop.net>\nTo: "); |
| 101 | Mail.mwrite (mail, #email entry); |
| 102 | Mail.mwrite (mail, "\nCc: "); |
| 103 | Mail.mwrite (mail, boardEmail); |
| 104 | Mail.mwrite (mail, "\nSubject: Application approved\n\nYour application for membership has been approved! Welcome to hcoop!\n\n"); |
| 105 | Mail.mwrite (mail, msg); |
| 106 | OS.Process.isSuccess (Mail.mclose mail) |
| 107 | end |
| 108 | |
| 109 | fun add app = |
| 110 | ignore (C.dml (getDb ()) ($`UPDATE MemberApp |
| 111 | SET status = 3 |
| 112 | WHERE id = ^(C.intToSql app)`)) |
| 113 | |
| 114 | fun abortAdd app = |
| 115 | ignore (C.dml (getDb ()) ($`UPDATE MemberApp |
| 116 | SET status = 2 |
| 117 | WHERE id = ^(C.intToSql app)`)) |
| 118 | |
| 119 | end |