Commit | Line | Data |
---|---|---|
e68ddb80 AC |
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} | |
ee587f7f | 12 | | mkPollRow row = Init.rowError ("poll", row) |
e68ddb80 AC |
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 | |
56dbfc30 AC |
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`) | |
e68ddb80 AC |
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) | |
ee587f7f | 45 | VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.stringToSql title), ^(C.stringToSql descr), |
e68ddb80 | 46 | ^(C.stringToSql starts), ^(C.stringToSql ends), ^(C.intToSql votes))`); |
ee587f7f | 47 | id |
e68ddb80 AC |
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} | |
ee587f7f | 73 | | mkChoiceRow row = Init.rowError ("choice", row) |
e68ddb80 AC |
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 | ||
56dbfc30 | 88 | val mkChoiceRow' = |
ee587f7f AC |
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) | |
56dbfc30 AC |
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'' = | |
ee587f7f AC |
101 | fn (yours :: rest) => (not (C.isNull yours) andalso C.intFromSql yours <> 0, |
102 | mkChoiceRow rest) | |
103 | | row => Init.rowError ("choice''", row) | |
56dbfc30 AC |
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 | ||
e68ddb80 AC |
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) | |
ee587f7f AC |
118 | VALUES (^(C.intToSql id), ^(C.intToSql pol), ^(C.realToSql seq), ^(C.stringToSql descr))`); |
119 | id | |
e68ddb80 AC |
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 | |
ee587f7f | 155 | | row => Init.rowError ("dateLe", row) |
e68ddb80 AC |
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 | |
ee587f7f | 160 | | row => Init.rowError ("dateGeNow", row) |
e68ddb80 | 161 | |
56dbfc30 AC |
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 | |
ee587f7f | 165 | | row => Init.rowError ("dateLeNow", row) |
56dbfc30 | 166 | |
e68ddb80 AC |
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 | |
ee587f7f | 170 | | row => Init.rowError ("dateLtNow", row) |
e68ddb80 AC |
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 | |
ee587f7f | 188 | | row => Init.rowError ("nextSeq", row) |
e68ddb80 | 189 | |
56dbfc30 AC |
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 | |
200 | FROM WebUser, Vote | |
201 | WHERE usr = id | |
202 | AND cho = ^(C.intToSql cho) | |
203 | ORDER BY name`) | |
204 | ||
e68ddb80 | 205 | end |