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