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