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