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
= raise Fail ("Bad poll row : " ^ makeSet id 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 (^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
= raise Fail ("Bad choice row : " ^ makeSet id 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
) => (yours
<> "0", if C
.isNull total
then 0 else C
.intFromSql total
, mkChoiceRow rest
)
90 | row
=> raise Fail ("Bad choice' row: " ^ makeSet id row
)
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
96 WHERE pol
= ^
(C
.intToSql pol
)
97 ORDER BY total DESC
, seq`
)
100 fn (yours
:: rest
) => (yours
<> "0", mkChoiceRow rest
)
101 | row
=> raise Fail ("Bad choice'' row: " ^ makeSet id row
)
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 ()))),
107 WHERE pol
= ^
(C
.intToSql pol
)
110 fun addChoice (pol
, seq
, descr
) =
113 val id
= nextSeq (db
, "PollChoiceSeq")
115 C
.dml
db ($`INSERT INTO
PollChoice (id
, pol
, seq
, descr
)
116 VALUES (^id
, ^
(C
.intToSql pol
), ^
(C
.realToSql seq
), ^
(C
.stringToSql descr
))`
);
120 fun modChoice (choice
: choice
) =
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
))`
))
130 fun deleteChoice id
=
131 ignore (C
.dml (getDb ()) ($`DELETE FROM PollChoice WHERE id
= ^
(C
.intToSql id
)`
))
136 fun vote (usr
, pol
, chos
) =
141 ignore (C
.dml
db ($`INSERT INTO
Vote (usr
, cho
) VALUES (^
(C
.intToSql usr
), ^
(C
.intToSql cho
))`
))
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
)`
));
148 (* Date comparison
*)
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
)
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
)
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
)
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
)
170 fun canModify (poll
: poll
) =
171 Group
.inGroupName
"poll"
172 orelse (#usr poll
= Init
.getUserId()
173 andalso dateLtNow (#starts poll
))
175 fun requireCanModify poll
=
176 if canModify poll
then
179 raise Init
.Access
"Not authorized to edit that poll"
182 case C
.oneRow (getDb ()) ($`SELECT
MAX(seq
)+1
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
)
188 fun takingVotes (poll
: poll
) =
189 dateLeNow (#starts poll
) andalso dateGeNow (#ends poll
)
194 | h
::t
=> List.all (fn x
=> x
<> h
) t
andalso noDupes t
197 C
.map (getDb ()) mkUserRow ($`SELECT id
, name
, rname
, bal
, joined
200 AND cho
= ^
(C
.intToSql cho
)