1 structure Poll
:> POLL
=
6 type poll
= {id
: int, usr
: int, title
: string, descr
: string, starts
: string, ends
: string, votes
: int}
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
= Init
.rowError ("poll", row
)
15 case C
.oneOrNoRows (getDb ()) ($`SELECT id
, usr
, title
, descr
, starts
, ends
, votes
17 WHERE id
= ^
(C
.intToSql id
)`
) of
18 NONE
=> raise Fail
"Poll not found"
19 | SOME row
=> mkPollRow row
22 C
.map (getDb ()) mkPollRow ($`SELECT id
, usr
, title
, descr
, starts
, ends
, votes
24 ORDER BY ends
, starts DESC
, title`
)
26 fun listCurrentPolls () =
27 C
.map (getDb ()) mkPollRow ($`SELECT id
, usr
, title
, descr
, starts
, ends
, votes
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`
)
33 fun listPollsLimit lim
=
34 C
.map (getDb ()) mkPollRow ($`SELECT id
, usr
, title
, descr
, starts
, ends
, votes
36 ORDER BY starts DESC
, ends
, title
37 LIMIT ^
(C
.intToSql lim
)`
)
39 fun addPoll (usr
, title
, descr
, starts
, ends
, votes
) =
42 val id
= nextSeq (db
, "PollSeq")
44 C
.dml
db ($`INSERT INTO
Poll (id
, usr
, title
, descr
, starts
, ends
, votes
)
45 VALUES (^
(C
.intToSql id
), ^
(C
.intToSql usr
), ^
(C
.stringToSql title
), ^
(C
.stringToSql descr
),
46 ^
(C
.stringToSql starts
), ^
(C
.stringToSql ends
), ^
(C
.intToSql votes
))`
);
50 fun modPoll (poll
: poll
) =
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
))`
))
63 ignore (C
.dml (getDb ()) ($`DELETE FROM Poll WHERE id
= ^
(C
.intToSql id
)`
))
68 type choice
= {id
: int, pol
: int, seq
: real, descr
: string}
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
= Init
.rowError ("choice", row
)
76 case C
.oneOrNoRows (getDb ()) ($`SELECT id
, pol
, seq
, descr
78 WHERE id
= ^
(C
.intToSql id
)`
) of
79 NONE
=> raise Fail
"Poll choice not found"
80 | SOME row
=> mkChoiceRow row
83 C
.map (getDb ()) mkChoiceRow ($`SELECT id
, pol
, seq
, descr
85 WHERE pol
= ^
(C
.intToSql pol
)
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
)
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
97 WHERE pol
= ^
(C
.intToSql pol
)
98 ORDER BY total DESC
, seq`
)
101 fn (yours
:: rest
) => (not (C
.isNull yours
) andalso C
.intFromSql yours
<> 0,
103 | row
=> Init
.rowError ("choice''", row
)
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 ()))),
109 WHERE pol
= ^
(C
.intToSql pol
)
112 fun addChoice (pol
, seq
, descr
) =
115 val id
= nextSeq (db
, "PollChoiceSeq")
117 C
.dml
db ($`INSERT INTO
PollChoice (id
, pol
, seq
, descr
)
118 VALUES (^
(C
.intToSql id
), ^
(C
.intToSql pol
), ^
(C
.realToSql seq
), ^
(C
.stringToSql descr
))`
);
122 fun modChoice (choice
: choice
) =
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
))`
))
132 fun deleteChoice id
=
133 ignore (C
.dml (getDb ()) ($`DELETE FROM PollChoice WHERE id
= ^
(C
.intToSql id
)`
))
138 fun vote (usr
, pol
, chos
) =
143 ignore (C
.dml
db ($`INSERT INTO
Vote (usr
, cho
) VALUES (^
(C
.intToSql usr
), ^
(C
.intToSql cho
))`
))
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
)`
));
150 (* Date comparison
*)
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
155 | row
=> Init
.rowError ("dateLe", row
)
158 case C
.oneRow (getDb ()) ($`
SELECT (EXTRACT(EPOCH FROM CURRENT_DATE
) <= EXTRACT(EPOCH FROM DATE ^
(C
.stringToSql d
)))`
) of
159 [res
] => C
.boolFromSql res
160 | row
=> Init
.rowError ("dateGeNow", row
)
163 case C
.oneRow (getDb ()) ($`
SELECT (EXTRACT(EPOCH FROM CURRENT_DATE
) >= EXTRACT(EPOCH FROM DATE ^
(C
.stringToSql d
)))`
) of
164 [res
] => C
.boolFromSql res
165 | row
=> Init
.rowError ("dateLeNow", row
)
168 case C
.oneRow (getDb ()) ($`
SELECT (EXTRACT(EPOCH FROM CURRENT_DATE
) > EXTRACT(EPOCH FROM DATE ^
(C
.stringToSql d
)))`
) of
169 [res
] => C
.boolFromSql res
170 | row
=> Init
.rowError ("dateLtNow", row
)
172 fun canModify (poll
: poll
) =
173 Group
.inGroupName
"poll"
174 orelse (#usr poll
= Init
.getUserId()
175 andalso dateLtNow (#starts poll
))
177 fun requireCanModify poll
=
178 if canModify poll
then
181 raise Init
.Access
"Not authorized to edit that poll"
184 case C
.oneRow (getDb ()) ($`SELECT
MAX(seq
)+1
186 WHERE pol
= ^
(C
.intToSql pol
)`
) of
187 [max
] => if C
.isNull max
then 1.0 else C
.realFromSql max
188 | row
=> Init
.rowError ("nextSeq", row
)
190 fun takingVotes (poll
: poll
) =
191 dateLeNow (#starts poll
) andalso dateGeNow (#ends poll
)
196 | h
::t
=> List.all (fn x
=> x
<> h
) t
andalso noDupes t
199 C
.map (getDb ()) mkUserRow ($`SELECT id
, name
, rname
, bal
, joined
202 AND cho
= ^
(C
.intToSql cho
)