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 (Config.staticFilesRoot ^ "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     in
 130         ()
 131     end
 132
 133 fun add app =
 134     let
 135         val appR = lookupApp app
 136     in
 137         ignore (C.dml (getDb ()) ($`UPDATE MemberApp
 138                                     SET status = 4
 139                                     WHERE id = ^(C.intToSql app)`))
 140     end
 141
 142 fun welcome app =
 143     let
 144         val app = lookupApp app
 145
 146         val mail = Mail.mopen ()
 147     in
 148         Mail.mwrite (mail, "To: ");
 149         Mail.mwrite (mail, #email app);
 150         Mail.mwrite (mail, "\n");
 151         Mail.mwrite (mail, Util.readFile (Config.staticFilesRoot ^ "paid.txt"));
 152         ignore (Mail.mclose mail)
 153     end
 154
 155 fun abortAdd app =
 156     ignore (C.dml (getDb ()) ($`UPDATE MemberApp
 157                                 SET status = 2
 158                                 WHERE id = ^(C.intToSql app)`))
 159
 160 fun readFile fname =
 161     let
 162         val inf = TextIO.openIn fname
 163
 164         fun readLines lines =
 165             case TextIO.inputLine inf of
 166                 NONE => String.concat (List.rev lines)
 167               | SOME line => readLines (line :: lines)
 168     in
 169         readLines []
 170         before TextIO.closeIn inf
 171     end
 172
 173 fun readTosBody () = readFile (Config.staticFilesRoot ^ "tos.body.html")
 174 fun readTosAgree () = readFile (Config.staticFilesRoot ^ "tos.agree.html")
 175 fun readTosMinorAgree () = readFile (Config.staticFilesRoot ^ "tos.agree.minor.html")
 176
 177 fun searchPaypal paypal =
 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 paypal = ^(C.stringToSql (normEmail paypal))
 182                                    AND status = 2
 183                                    AND decided >= CURRENT_TIMESTAMP - INTERVAL '1 MONTH'
 184                                  ORDER BY applied`)
 185
 186 fun searchCheckout checkout =
 187     C.map (getDb ()) mkAppRow ($`SELECT id, name, rname, gname, email, forward, uses, other, passwd, status, applied, ipaddr, confirmed, decided,
 188                                         msg, unix_passwd, paypal, checkout
 189                                  FROM MemberApp
 190                                  WHERE checkout = ^(C.stringToSql (normEmail checkout))
 191                                    AND status = 2
 192                                    AND decided >= CURRENT_TIMESTAMP - INTERVAL '1 MONTH'
 193                                  ORDER BY applied`)
 194
 195 end