app.sml

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