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