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} | |
12 | | mkPollRow row = raise Fail ("Bad poll row : " ^ makeSet id row) | |
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) | |
45 | VALUES (^id, ^(C.intToSql usr), ^(C.stringToSql title), ^(C.stringToSql descr), | |
46 | ^(C.stringToSql starts), ^(C.stringToSql ends), ^(C.intToSql votes))`); | |
47 | C.intFromSql 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)) | |
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 = raise Fail ("Bad choice row : " ^ makeSet id 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 | ||
56dbfc30 AC |
88 | val mkChoiceRow' = |
89 | fn (yours :: total :: rest) => (yours <> "0", if C.isNull total then 0 else C.intFromSql total, mkChoiceRow rest) | |
90 | | row => raise Fail ("Bad choice' row: " ^ makeSet id row) | |
91 | ||
92 | fun listChoicesWithVotes pol = | |
93 | C.map (getDb ()) mkChoiceRow' ($`SELECT (SELECT COUNT( * ) FROM Vote V WHERE V.cho = id AND V.usr = ^(C.intToSql (Init.getUserId ()))), | |
94 | (SELECT COUNT( * ) FROM Vote V WHERE V.cho = id) AS total, id, pol, seq, descr | |
95 | FROM PollChoice | |
96 | WHERE pol = ^(C.intToSql pol) | |
97 | ORDER BY total DESC, seq`) | |
98 | ||
99 | val mkChoiceRow'' = | |
100 | fn (yours :: rest) => (yours <> "0", mkChoiceRow rest) | |
101 | | row => raise Fail ("Bad choice'' row: " ^ makeSet id row) | |
102 | ||
103 | fun listChoicesWithMyVotes pol = | |
104 | C.map (getDb ()) mkChoiceRow'' ($`SELECT (SELECT COUNT( * ) FROM Vote V WHERE V.cho = id AND V.usr = ^(C.intToSql (Init.getUserId ()))), | |
105 | id, pol, seq, descr | |
106 | FROM PollChoice | |
107 | WHERE pol = ^(C.intToSql pol) | |
108 | ORDER BY seq`) | |
109 | ||
e68ddb80 AC |
110 | fun addChoice (pol, seq, descr) = |
111 | let | |
112 | val db = getDb () | |
113 | val id = nextSeq (db, "PollChoiceSeq") | |
114 | in | |
115 | C.dml db ($`INSERT INTO PollChoice (id, pol, seq, descr) | |
116 | VALUES (^id, ^(C.intToSql pol), ^(C.realToSql seq), ^(C.stringToSql descr))`); | |
117 | C.intFromSql id | |
118 | end | |
119 | ||
120 | fun modChoice (choice : choice) = | |
121 | let | |
122 | val db = getDb () | |
123 | in | |
124 | ignore (C.dml db ($`UPDATE PollChoice SET | |
125 | pol = ^(C.intToSql (#pol choice)), seq = ^(C.realToSql (#seq choice)), | |
126 | descr = ^(C.stringToSql (#descr choice)) | |
127 | WHERE id = ^(C.intToSql (#id choice))`)) | |
128 | end | |
129 | ||
130 | fun deleteChoice id = | |
131 | ignore (C.dml (getDb ()) ($`DELETE FROM PollChoice WHERE id = ^(C.intToSql id)`)) | |
132 | ||
133 | ||
134 | (* Member voting *) | |
135 | ||
136 | fun vote (usr, pol, chos) = | |
137 | let | |
138 | val db = getDb () | |
139 | ||
140 | fun voteOnce cho = | |
141 | ignore (C.dml db ($`INSERT INTO Vote (usr, cho) VALUES (^(C.intToSql usr), ^(C.intToSql cho))`)) | |
142 | in | |
143 | ignore (C.dml db ($`DELETE FROM Vote WHERE cho IN (SELECT id FROM PollChoice WHERE pol = ^(C.intToSql pol)) AND usr = ^(C.intToSql usr)`)); | |
144 | app voteOnce chos | |
145 | end | |
146 | ||
147 | ||
148 | (* Date comparison *) | |
149 | ||
150 | fun dateLe (d1, d2) = | |
151 | case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM DATE ^(C.stringToSql d1)) <= EXTRACT(EPOCH FROM DATE ^(C.stringToSql d2)))`) of | |
152 | [res] => C.boolFromSql res | |
153 | | row => raise Fail ("Bad dateLe row: " ^ makeSet id row) | |
154 | ||
155 | fun dateGeNow d = | |
156 | case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM CURRENT_DATE) <= EXTRACT(EPOCH FROM DATE ^(C.stringToSql d)))`) of | |
157 | [res] => C.boolFromSql res | |
158 | | row => raise Fail ("Bad dateGeNow row: " ^ makeSet id row) | |
159 | ||
56dbfc30 AC |
160 | fun dateLeNow d = |
161 | case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM CURRENT_DATE) >= EXTRACT(EPOCH FROM DATE ^(C.stringToSql d)))`) of | |
162 | [res] => C.boolFromSql res | |
163 | | row => raise Fail ("Bad dateLeNow row: " ^ makeSet id row) | |
164 | ||
e68ddb80 AC |
165 | fun dateLtNow d = |
166 | case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM CURRENT_DATE) > EXTRACT(EPOCH FROM DATE ^(C.stringToSql d)))`) of | |
167 | [res] => C.boolFromSql res | |
168 | | row => raise Fail ("Bad dateLtNow row: " ^ makeSet id row) | |
169 | ||
170 | fun canModify (poll : poll) = | |
171 | Group.inGroupName "poll" | |
172 | orelse (#usr poll = Init.getUserId() | |
173 | andalso dateLtNow (#starts poll)) | |
174 | ||
175 | fun requireCanModify poll = | |
176 | if canModify poll then | |
177 | () | |
178 | else | |
179 | raise Init.Access "Not authorized to edit that poll" | |
180 | ||
181 | fun nextSeq pol = | |
182 | case C.oneRow (getDb ()) ($`SELECT MAX(seq)+1 | |
183 | FROM PollChoice | |
184 | WHERE pol = ^(C.intToSql pol)`) of | |
185 | [max] => if C.isNull max then 1.0 else C.realFromSql max | |
186 | | row => raise Fail ("Bad nextSeq row: " ^ makeSet id row) | |
187 | ||
56dbfc30 AC |
188 | fun takingVotes (poll : poll) = |
189 | dateLeNow (#starts poll) andalso dateGeNow (#ends poll) | |
190 | ||
191 | fun noDupes l = | |
192 | case l of | |
193 | [] => true | |
194 | | h::t => List.all (fn x => x <> h) t andalso noDupes t | |
195 | ||
196 | fun listVoters cho = | |
197 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined | |
198 | FROM WebUser, Vote | |
199 | WHERE usr = id | |
200 | AND cho = ^(C.intToSql cho) | |
201 | ORDER BY name`) | |
202 | ||
e68ddb80 | 203 | end |