57c305c1 |
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} |
7 | |
8 | fun mkPollRow [id, usr, title, descr, starts, ends, votes] = |
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} |
369e1577 |
12 | | mkPollRow row = Init.rowError ("poll", row) |
57c305c1 |
13 | |
14 | fun lookupPoll id = |
15 | case C.oneOrNoRows (getDb ()) ($`SELECT id, usr, title, descr, starts, ends, votes |
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 |
23 | FROM Poll |
7f97ec97 |
24 | ORDER BY ends, starts DESC, title`) |
25 | |
26 | fun listCurrentPolls () = |
27 | C.map (getDb ()) mkPollRow ($`SELECT id, usr, title, descr, starts, ends, votes |
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`) |
57c305c1 |
32 | |
33 | fun listPollsLimit lim = |
34 | C.map (getDb ()) mkPollRow ($`SELECT id, usr, title, descr, starts, ends, votes |
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) = |
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) |
369e1577 |
45 | VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.stringToSql title), ^(C.stringToSql descr), |
57c305c1 |
46 | ^(C.stringToSql starts), ^(C.stringToSql ends), ^(C.intToSql votes))`); |
369e1577 |
47 | id |
57c305c1 |
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)) |
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} |
369e1577 |
73 | | mkChoiceRow row = Init.rowError ("choice", row) |
57c305c1 |
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 | |
7f97ec97 |
88 | val mkChoiceRow' = |
369e1577 |
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) |
7f97ec97 |
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'' = |
369e1577 |
101 | fn (yours :: rest) => (not (C.isNull yours) andalso C.intFromSql yours <> 0, |
102 | mkChoiceRow rest) |
103 | | row => Init.rowError ("choice''", row) |
7f97ec97 |
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 | |
57c305c1 |
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) |
369e1577 |
118 | VALUES (^(C.intToSql id), ^(C.intToSql pol), ^(C.realToSql seq), ^(C.stringToSql descr))`); |
119 | id |
57c305c1 |
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 |
369e1577 |
155 | | row => Init.rowError ("dateLe", row) |
57c305c1 |
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 |
369e1577 |
160 | | row => Init.rowError ("dateGeNow", row) |
57c305c1 |
161 | |
7f97ec97 |
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 |
369e1577 |
165 | | row => Init.rowError ("dateLeNow", row) |
7f97ec97 |
166 | |
57c305c1 |
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 |
369e1577 |
170 | | row => Init.rowError ("dateLtNow", row) |
57c305c1 |
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 |
369e1577 |
188 | | row => Init.rowError ("nextSeq", row) |
57c305c1 |
189 | |
7f97ec97 |
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 = |
20acb925 |
199 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
7f97ec97 |
200 | FROM WebUser, Vote |
201 | WHERE usr = id |
202 | AND cho = ^(C.intToSql cho) |
203 | ORDER BY name`) |
204 | |
fd650826 |
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 = |
20acb925 |
212 | C.map (getDb ()) mkUserRow ($`SELECT DISTINCT WebUser.id, name, rname, bal, joined, app, shares, paypal, checkout |
fd650826 |
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 | end |