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, email : string,
  32              forward : bool, uses : string, other : string,
  33              passwd : string, status : status, applied : C.timestamp,
  34              confirmed : C.timestamp option, decided : C.timestamp option,
  35              msg : string}
  36
  37 fun mkAppRow [id, name, rname, email, forward, uses, other, passwd, status, applied, confirmed, decided, msg] =
  38     { id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname,
  39       email = C.stringFromSql email, forward = C.boolFromSql forward,
  40       uses = C.stringFromSql uses, other = C.stringFromSql other, passwd = C.stringFromSql passwd,
  41       status = statusFromSql status, applied = C.timestampFromSql applied,
  42       confirmed = if C.isNull confirmed then NONE else SOME (C.timestampFromSql confirmed),
  43       decided = if C.isNull decided then NONE else SOME (C.timestampFromSql decided),
  44       msg = C.stringFromSql msg}
  45   | mkAppRow r = rowError ("app", r)
  46
  47 fun lookupApp id =
  48     case C.oneOrNoRows (getDb ()) ($`SELECT id, name, rname, email, forward, uses, other, passwd, status, applied, confirmed, decided, msg
  49                                      FROM MemberApp
  50                                      WHERE id = ^(C.intToSql id)`) of
  51         SOME row => mkAppRow row
  52       | NONE => raise Fail "Membership application not found"
  53
  54 fun listPending () =
  55     C.map (getDb ()) mkAppRow ($`SELECT id, name, rname, email, forward, uses, other, passwd, status, applied, confirmed, decided, msg
  56                                  FROM MemberApp
  57                                  WHERE status = 1
  58                                  ORDER BY applied`)
  59
  60 fun mkVoteRow [id, name] = (C.intFromSql id, C.stringFromSql name)
  61   | mkVoteRow row = rowError ("app.vote", row)
  62
  63 fun votes id = C.map (getDb ()) mkVoteRow ($`SELECT usr, name
  64                                              FROM AppVote JOIN WebUser ON usr = id
  65                                              WHERE app = ^(C.intToSql id)
  66                                              ORDER BY name`)
  67
  68 fun vote (usr, app) = ignore (C.dml (getDb ()) ($`INSERT INTO AppVote (app, usr)
  69                                                   VALUES (^(C.intToSql app), ^(C.intToSql usr))`))
  70
  71 fun unvote (usr, app) = ignore (C.dml (getDb ()) ($`DELETE FROM AppVote WHERE app = ^(C.intToSql app) AND usr = ^(C.intToSql usr)`))
  72
  73 fun deny (app, msg) =
  74     let
  75         val entry = lookupApp app
  76         val _ =  C.dml (getDb ()) ($`UPDATE MemberApp
  77                                      SET status = 3, msg = ^(C.stringToSql msg), decided = CURRENT_TIMESTAMP
  78                                      WHERE id = ^(C.intToSql app)`)
  79
  80         val mail = Mail.mopen ()
  81     in
  82         Mail.mwrite (mail, "From: Hcoop Application System <join@hcoop.net>\nTo: ");
  83         Mail.mwrite (mail, #email entry);
  84         Mail.mwrite (mail, "\nCc: ");
  85         Mail.mwrite (mail, boardEmail);
  86         Mail.mwrite (mail, "\nSubject: Application denied\n\nYour application for membership has been denied.  Reason:\n\n");
  87         Mail.mwrite (mail, msg);
  88         OS.Process.isSuccess (Mail.mclose mail)
  89     end
  90
  91 fun approve (app, msg) =
  92     let
  93         val entry = lookupApp app
  94         val _ =  C.dml (getDb ()) ($`UPDATE MemberApp
  95                                      SET status = 2, msg = ^(C.stringToSql msg), decided = CURRENT_TIMESTAMP
  96                                      WHERE id = ^(C.intToSql app)`)
  97
  98         val mail = Mail.mopen ()
  99     in
 100         Mail.mwrite (mail, "From: Hcoop Application System <join@hcoop.net>\nTo: ");
 101         Mail.mwrite (mail, #email entry);
 102         Mail.mwrite (mail, "\nCc: ");
 103         Mail.mwrite (mail, boardEmail);
 104         Mail.mwrite (mail, "\nSubject: Application approved\n\nYour application for membership has been approved!  Welcome to hcoop!\n\n");
 105         Mail.mwrite (mail, msg);
 106         OS.Process.isSuccess (Mail.mclose mail)
 107     end
 108
 109 end