1 structure Poll
:> POLL
=
6 type poll
= {id
: int, usr
: int, title
: string, descr
: string, starts
: string, ends
: string, votes
: int, official
: bool, ready
: bool}
8 fun mkPollRow
[id
, usr
, title
, descr
, starts
, ends
, votes
, official
, ready
] =
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 ready
= C
.boolFromSql ready
}
13 | mkPollRow row
= Init
.rowError ("poll", row
)
16 case C
.oneOrNoRows (getDb ()) ($`SELECT id
, usr
, title
, descr
, starts
, ends
, votes
, official
, ready
18 WHERE id
= ^
(C
.intToSql id
)`
) of
19 NONE
=> raise Fail
"Poll not found"
20 | SOME row
=> mkPollRow row
23 C
.map (getDb ()) mkPollRow ($`SELECT id
, usr
, title
, descr
, starts
, ends
, votes
, official
, ready
26 ORDER BY ends
, starts DESC
, title`
)
28 fun listCurrentPolls () =
29 C
.map (getDb ()) mkPollRow ($`SELECT id
, usr
, title
, descr
, starts
, ends
, votes
, official
, ready
31 WHERE
EXTRACT(EPOCH FROM starts
) <= EXTRACT(EPOCH FROM CURRENT_DATE
)
32 AND
EXTRACT(EPOCH FROM ends
) >= EXTRACT(EPOCH FROM CURRENT_DATE
)
33 AND (ready OR usr
= ^
(C
.intToSql (Init
.getUserId ())))
34 ORDER BY ends
, starts DESC
, title`
)
36 fun listPollsLimit lim
=
37 C
.map (getDb ()) mkPollRow ($`SELECT id
, usr
, title
, descr
, starts
, ends
, votes
, official
, ready
39 ORDER BY starts DESC
, ends
, title
40 WHERE (ready OR usr
= ^
(C
.intToSql (Init
.getUserId ())))
41 LIMIT ^
(C
.intToSql lim
)`
)
43 fun addPoll (usr
, title
, descr
, starts
, ends
, votes
, official
, ready
) =
46 val id
= nextSeq (db
, "PollSeq")
48 C
.dml
db ($`INSERT INTO
Poll (id
, usr
, title
, descr
, starts
, ends
, votes
, official
, ready
)
49 VALUES (^
(C
.intToSql id
), ^
(C
.intToSql usr
), ^
(C
.stringToSql title
), ^
(C
.stringToSql descr
),
50 ^
(C
.stringToSql starts
), ^
(C
.stringToSql ends
), ^
(C
.intToSql votes
), ^
(C
.boolToSql official
),
51 ^
(C
.boolToSql ready
))`
);
55 fun modPoll (poll
: poll
) =
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
)),
63 votes
= ^
(C
.intToSql (#votes poll
)), official
= ^
(C
.boolToSql (#official poll
)),
64 ready
= ^
(C
.boolToSql (#ready poll
))
65 WHERE id
= ^
(C
.intToSql (#id poll
))`
))
69 ignore (C
.dml (getDb ()) ($`DELETE FROM Poll WHERE id
= ^
(C
.intToSql id
)`
))
74 type choice
= {id
: int, pol
: int, seq
: real, descr
: string}
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
}
79 | mkChoiceRow row
= Init
.rowError ("choice", row
)
82 case C
.oneOrNoRows (getDb ()) ($`SELECT id
, pol
, seq
, descr
84 WHERE id
= ^
(C
.intToSql id
)`
) of
85 NONE
=> raise Fail
"Poll choice not found"
86 | SOME row
=> mkChoiceRow row
89 C
.map (getDb ()) mkChoiceRow ($`SELECT id
, pol
, seq
, descr
91 WHERE pol
= ^
(C
.intToSql pol
)
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
)
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
103 WHERE pol
= ^
(C
.intToSql pol
)
104 ORDER BY total DESC
, seq`
)
107 fn (yours
:: rest
) => (not (C
.isNull yours
) andalso C
.intFromSql yours
<> 0,
109 | row
=> Init
.rowError ("choice''", row
)
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 ()))),
115 WHERE pol
= ^
(C
.intToSql pol
)
118 fun addChoice (pol
, seq
, descr
) =
121 val id
= nextSeq (db
, "PollChoiceSeq")
123 C
.dml
db ($`INSERT INTO
PollChoice (id
, pol
, seq
, descr
)
124 VALUES (^
(C
.intToSql id
), ^
(C
.intToSql pol
), ^
(C
.realToSql seq
), ^
(C
.stringToSql descr
))`
);
128 fun modChoice (choice
: choice
) =
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
))`
))
138 fun deleteChoice id
=
139 ignore (C
.dml (getDb ()) ($`DELETE FROM PollChoice WHERE id
= ^
(C
.intToSql id
)`
))
144 fun vote (usr
, pol
, chos
) =
149 ignore (C
.dml
db ($`INSERT INTO
Vote (usr
, cho
) VALUES (^
(C
.intToSql usr
), ^
(C
.intToSql cho
))`
))
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
)`
));
156 (* Date comparison
*)
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
161 | row
=> Init
.rowError ("dateLe", row
)
164 case C
.oneRow (getDb ()) ($`
SELECT (EXTRACT(EPOCH FROM CURRENT_DATE
) <= EXTRACT(EPOCH FROM DATE ^
(C
.stringToSql d
)))`
) of
165 [res
] => C
.boolFromSql res
166 | row
=> Init
.rowError ("dateGeNow", row
)
169 case C
.oneRow (getDb ()) ($`
SELECT (EXTRACT(EPOCH FROM CURRENT_DATE
) >= EXTRACT(EPOCH FROM DATE ^
(C
.stringToSql d
)))`
) of
170 [res
] => C
.boolFromSql res
171 | row
=> Init
.rowError ("dateLeNow", row
)
174 case C
.oneRow (getDb ()) ($`
SELECT (EXTRACT(EPOCH FROM CURRENT_DATE
) > EXTRACT(EPOCH FROM DATE ^
(C
.stringToSql d
)))`
) of
175 [res
] => C
.boolFromSql res
176 | row
=> Init
.rowError ("dateLtNow", row
)
178 fun canModify (poll
: poll
) =
179 Group
.inGroupName
"poll"
180 orelse ((#usr poll
= Init
.getUserId()
181 andalso (dateLtNow (#starts poll
)
182 orelse not (#ready poll
))))
184 fun requireCanModify poll
=
185 if canModify poll
then
188 raise Init
.Access
"Not authorized to edit that poll"
191 case C
.oneRow (getDb ()) ($`SELECT
MAX(seq
)+1
193 WHERE pol
= ^
(C
.intToSql pol
)`
) of
194 [max
] => if C
.isNull max
then 1.0 else C
.realFromSql max
195 | row
=> Init
.rowError ("nextSeq", row
)
197 fun takingVotes (poll
: poll
) =
198 #ready poll
andalso dateLeNow (#starts poll
) andalso dateGeNow (#ends poll
)
203 | h
::t
=> List.all (fn x
=> x
<> h
) t
andalso noDupes t
206 C
.map (getDb ()) mkUserRow ($`SELECT id
, name
, rname
, bal
, joined
, app
, shares
, paypal
, checkout
209 AND cho
= ^
(C
.intToSql cho
)
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
)
218 fun listPollVoters pol
=
219 C
.map (getDb ()) mkUserRow ($`SELECT DISTINCT WebUser
.id
, name
, rname
, bal
, joined
, app
, shares
, paypal
, checkout
220 FROM WebUser
, Vote JOIN PollChoice ON cho
= PollChoice
.id
221 WHERE pol
= ^
(C
.intToSql pol
)
225 val votingMembershipRequirement
= 45
227 fun membershipLength id
=
228 case C
.oneRow (getDb ()) ($`SELECT
EXTRACT(DAY
FROM (CURRENT_TIMESTAMP
- joined
))
230 WHERE id
= ^
(C
.intToSql id
)`
) of
231 [days
] => C
.intFromSql days
232 | row
=> Init
.rowError ("membershipLength", row
)