poll.sml

   1 structure Poll :> POLL =
   2 struct
   3
   4 open Util Sql Init
   5
   6 type poll = {id : int, usr : int, title : string, descr : string, starts : string, ends : string, votes : int, official : bool}
   7
   8 fun mkPollRow [id, usr, title, descr, starts, ends, votes, official] =
   9     {id = C.intFromSql id, usr = C.intFromSql usr, title = C.stringFromSql title,
  10      descr = C.stringFromSql descr, starts = C.stringFromSql starts,
  11      ends = C.stringFromSql ends, votes = C.intFromSql votes, official = C.boolFromSql official}
  12   | mkPollRow row = Init.rowError ("poll", row)
  13
  14 fun lookupPoll id =
  15     case C.oneOrNoRows (getDb ()) ($`SELECT id, usr, title, descr, starts, ends, votes, official
  16                                      FROM Poll
  17                                      WHERE id = ^(C.intToSql id)`) of
  18         NONE => raise Fail "Poll not found"
  19       | SOME row => mkPollRow row
  20
  21 fun listPolls () =
  22     C.map (getDb ()) mkPollRow ($`SELECT id, usr, title, descr, starts, ends, votes, official
  23                                   FROM Poll
  24                                   ORDER BY ends, starts DESC, title`)
  25
  26 fun listCurrentPolls () =
  27     C.map (getDb ()) mkPollRow ($`SELECT id, usr, title, descr, starts, ends, votes, official
  28                                   FROM Poll
  29                                   WHERE EXTRACT(EPOCH FROM starts) <= EXTRACT(EPOCH FROM CURRENT_DATE)
  30                                      AND EXTRACT(EPOCH FROM ends) >= EXTRACT(EPOCH FROM CURRENT_DATE)
  31                                   ORDER BY ends, starts DESC, title`)
  32
  33 fun listPollsLimit lim =
  34     C.map (getDb ()) mkPollRow ($`SELECT id, usr, title, descr, starts, ends, votes, official
  35                                   FROM Poll
  36                                   ORDER BY starts DESC, ends, title
  37                                   LIMIT ^(C.intToSql lim)`)
  38
  39 fun addPoll (usr, title, descr, starts, ends, votes, official) =
  40     let
  41         val db = getDb ()
  42         val id = nextSeq (db, "PollSeq")
  43     in
  44         C.dml db ($`INSERT INTO Poll (id, usr, title, descr, starts, ends, votes, official)
  45                     VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.stringToSql title), ^(C.stringToSql descr),
  46                             ^(C.stringToSql starts), ^(C.stringToSql ends), ^(C.intToSql votes), ^(C.boolToSql official))`);
  47         id
  48     end
  49
  50 fun modPoll (poll : poll) =
  51     let
  52         val db = getDb ()
  53     in
  54         ignore (C.dml db ($`UPDATE Poll SET
  55                             usr = ^(C.intToSql (#usr poll)), title = ^(C.stringToSql (#title poll)),
  56                             descr = ^(C.stringToSql (#descr poll)),
  57                             starts = ^(C.stringToSql (#starts poll)), ends = ^(C.stringToSql (#ends poll)),
  58                             votes = ^(C.intToSql (#votes poll)), official = ^(C.boolToSql (#official poll))
  59                             WHERE id = ^(C.intToSql (#id poll))`))
  60     end
  61
  62 fun deletePoll id =
  63     ignore (C.dml (getDb ()) ($`DELETE FROM Poll WHERE id = ^(C.intToSql id)`))
  64
  65
  66 (* Poll choices *)
  67
  68 type choice = {id : int, pol : int, seq : real, descr : string}
  69
  70 fun mkChoiceRow [id, pol, seq, descr] =
  71     {id = C.intFromSql id, pol = C.intFromSql pol,
  72      seq = C.realFromSql seq, descr = C.stringFromSql descr}
  73   | mkChoiceRow row = Init.rowError ("choice", row)
  74
  75 fun lookupChoice id =
  76     case C.oneOrNoRows (getDb ()) ($`SELECT id, pol, seq, descr
  77                                      FROM PollChoice
  78                                      WHERE id = ^(C.intToSql id)`) of
  79         NONE => raise Fail "Poll choice not found"
  80       | SOME row => mkChoiceRow row
  81
  82 fun listChoices pol =
  83     C.map (getDb ()) mkChoiceRow ($`SELECT id, pol, seq, descr
  84                                     FROM PollChoice
  85                                     WHERE pol = ^(C.intToSql pol)
  86                                     ORDER BY seq`)
  87
  88 val mkChoiceRow' =
  89     fn (yours :: total :: rest) => (not (C.isNull yours) andalso C.intFromSql yours <> 0,
  90                                     if C.isNull total then 0 else C.intFromSql total, mkChoiceRow rest)
  91      | row => Init.rowError ("choice'", row)
  92
  93 fun listChoicesWithVotes pol =
  94     C.map (getDb ()) mkChoiceRow' ($`SELECT (SELECT COUNT( * ) FROM Vote V WHERE V.cho = id AND V.usr = ^(C.intToSql (Init.getUserId ()))),
  95                                         (SELECT COUNT( * ) FROM Vote V WHERE V.cho = id) AS total, id, pol, seq, descr
  96                                      FROM PollChoice
  97                                      WHERE pol = ^(C.intToSql pol)
  98                                      ORDER BY total DESC, seq`)
  99
 100 val mkChoiceRow'' =
 101     fn (yours :: rest) => (not (C.isNull yours) andalso C.intFromSql yours <> 0,
 102                            mkChoiceRow rest)
 103      | row => Init.rowError ("choice''", row)
 104
 105 fun listChoicesWithMyVotes pol =
 106     C.map (getDb ()) mkChoiceRow'' ($`SELECT (SELECT COUNT( * ) FROM Vote V WHERE V.cho = id AND V.usr = ^(C.intToSql (Init.getUserId ()))),
 107                                          id, pol, seq, descr
 108                                       FROM PollChoice
 109                                       WHERE pol = ^(C.intToSql pol)
 110                                       ORDER BY seq`)
 111
 112 fun addChoice (pol, seq, descr) =
 113     let
 114         val db = getDb ()
 115         val id = nextSeq (db, "PollChoiceSeq")
 116     in
 117         C.dml db ($`INSERT INTO PollChoice (id, pol, seq, descr)
 118                     VALUES (^(C.intToSql id), ^(C.intToSql pol), ^(C.realToSql seq), ^(C.stringToSql descr))`);
 119         id
 120     end
 121
 122 fun modChoice (choice : choice) =
 123     let
 124         val db = getDb ()
 125     in
 126         ignore (C.dml db ($`UPDATE PollChoice SET
 127                             pol = ^(C.intToSql (#pol choice)), seq = ^(C.realToSql (#seq choice)),
 128                             descr = ^(C.stringToSql (#descr choice))
 129                             WHERE id = ^(C.intToSql (#id choice))`))
 130     end
 131
 132 fun deleteChoice id =
 133     ignore (C.dml (getDb ()) ($`DELETE FROM PollChoice WHERE id = ^(C.intToSql id)`))
 134
 135
 136 (* Member voting *)
 137
 138 fun vote (usr, pol, chos) =
 139     let
 140         val db = getDb ()
 141
 142         fun voteOnce cho =
 143             ignore (C.dml db ($`INSERT INTO Vote (usr, cho) VALUES (^(C.intToSql usr), ^(C.intToSql cho))`))
 144     in
 145         ignore (C.dml db ($`DELETE FROM Vote WHERE cho IN (SELECT id FROM PollChoice WHERE pol = ^(C.intToSql pol)) AND usr = ^(C.intToSql usr)`));
 146         app voteOnce chos
 147     end
 148
 149
 150 (* Date comparison *)
 151
 152 fun dateLe (d1, d2) =
 153     case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM DATE ^(C.stringToSql d1)) <= EXTRACT(EPOCH FROM DATE ^(C.stringToSql d2)))`) of
 154         [res] => C.boolFromSql res
 155       | row => Init.rowError ("dateLe", row)
 156
 157 fun dateGeNow d =
 158     case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM CURRENT_DATE) <= EXTRACT(EPOCH FROM DATE ^(C.stringToSql d)))`) of
 159         [res] => C.boolFromSql res
 160       | row => Init.rowError ("dateGeNow", row)
 161
 162 fun dateLeNow d =
 163     case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM CURRENT_DATE) >= EXTRACT(EPOCH FROM DATE ^(C.stringToSql d)))`) of
 164         [res] => C.boolFromSql res
 165       | row => Init.rowError ("dateLeNow", row)
 166
 167 fun dateLtNow d =
 168     case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM CURRENT_DATE) > EXTRACT(EPOCH FROM DATE ^(C.stringToSql d)))`) of
 169         [res] => C.boolFromSql res
 170       | row => Init.rowError ("dateLtNow", row)
 171
 172 fun canModify (poll : poll) =
 173     Group.inGroupName "poll"
 174     orelse (#usr poll = Init.getUserId()
 175             andalso dateLtNow (#starts poll))
 176
 177 fun requireCanModify poll =
 178     if canModify poll then
 179         ()
 180     else
 181         raise Init.Access "Not authorized to edit that poll"
 182
 183 fun nextSeq pol =
 184     case C.oneRow (getDb ()) ($`SELECT MAX(seq)+1
 185                                 FROM PollChoice
 186                                 WHERE pol = ^(C.intToSql pol)`) of
 187         [max] => if C.isNull max then 1.0 else C.realFromSql max
 188       | row => Init.rowError ("nextSeq", row)
 189
 190 fun takingVotes (poll : poll) =
 191     dateLeNow (#starts poll) andalso dateGeNow (#ends poll)
 192
 193 fun noDupes l =
 194     case l of
 195         [] => true
 196       | h::t => List.all (fn x => x <> h) t andalso noDupes t
 197
 198 fun listVoters cho =
 199     C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
 200                                   FROM WebUser, Vote
 201                                   WHERE usr = id
 202                                      AND cho = ^(C.intToSql cho)
 203                                   ORDER BY name`)
 204
 205 fun countVoters pol =
 206     case C.oneRow (getDb ()) ($`SELECT COUNT(DISTINCT usr)
 207                                 FROM Vote JOIN PollChoice ON id = cho AND pol = ^(C.intToSql pol)`) of
 208         [count] => C.intFromSql count
 209       | row => Init.rowError ("countVoters", row)
 210
 211 fun listPollVoters pol =
 212     C.map (getDb ()) mkUserRow ($`SELECT DISTINCT WebUser.id, name, rname, bal, joined, app, shares, paypal, checkout
 213                                   FROM WebUser, Vote JOIN PollChoice ON cho = PollChoice.id
 214                                   WHERE pol = ^(C.intToSql pol)
 215                                      AND usr = WebUser.id
 216                                   ORDER BY name`)
 217
 218 val votingMembershipRequirement = 45
 219
 220 fun membershipLength id =
 221     case C.oneRow (getDb ()) ($`SELECT EXTRACT(DAY FROM (CURRENT_TIMESTAMP - joined))
 222                                 FROM WebUser
 223                                 WHERE id = ^(C.intToSql id)`) of
 224         [days] => C.intFromSql days
 225       | row => Init.rowError ("membershipLength", row)
 226
 227 end