[bpt/portal.git] / poll.sml

structure Poll :> POLL =
struct

open Util Sql Init

type poll = {id : int, usr : int, title : string, descr : string, starts : string, ends : string, votes : int, official : bool, ready : bool}

fun mkPollRow [id, usr, title, descr, starts, ends, votes, official, ready] =
    {id = C.intFromSql id, usr = C.intFromSql usr, title = C.stringFromSql title,
     descr = C.stringFromSql descr, starts = C.stringFromSql starts,
     ends = C.stringFromSql ends, votes = C.intFromSql votes, official = C.boolFromSql official,
     ready = C.boolFromSql ready}
  | mkPollRow row = Init.rowError ("poll", row)

fun lookupPoll id =
    case C.oneOrNoRows (getDb ()) ($`SELECT id, usr, title, descr, starts, ends, votes, official, ready
			             FROM Poll
			      	     WHERE id = ^(C.intToSql id)`) of
	NONE => raise Fail "Poll not found"
      | SOME row => mkPollRow row

fun listPolls () =
    C.map (getDb ()) mkPollRow ($`SELECT id, usr, title, descr, starts, ends, votes, official, ready
			          FROM Poll
				  WHERE ready
			      	  ORDER BY ends, starts DESC, title`)

fun listCurrentPolls () =
    C.map (getDb ()) mkPollRow ($`SELECT id, usr, title, descr, starts, ends, votes, official, ready
			          FROM Poll
				  WHERE EXTRACT(EPOCH FROM starts) <= EXTRACT(EPOCH FROM CURRENT_DATE)
				     AND EXTRACT(EPOCH FROM ends) >= EXTRACT(EPOCH FROM CURRENT_DATE)
				     AND (ready OR usr = ^(C.intToSql (Init.getUserId ()))) 
			      	  ORDER BY ends, starts DESC, title`)

fun listPollsLimit lim =
    C.map (getDb ()) mkPollRow ($`SELECT id, usr, title, descr, starts, ends, votes, official, ready
			          FROM Poll
			      	  ORDER BY starts DESC, ends, title
				  WHERE (ready OR usr = ^(C.intToSql (Init.getUserId ())))
				  LIMIT ^(C.intToSql lim)`)

fun addPoll (usr, title, descr, starts, ends, votes, official, ready) =
    let
	val db = getDb ()
	val id = nextSeq (db, "PollSeq")
    in
	C.dml db ($`INSERT INTO Poll (id, usr, title, descr, starts, ends, votes, official, ready)
		    VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.stringToSql title), ^(C.stringToSql descr),
			    ^(C.stringToSql starts), ^(C.stringToSql ends), ^(C.intToSql votes), ^(C.boolToSql official),
			    ^(C.boolToSql ready))`);
	id
    end

fun modPoll (poll : poll) =
    let
	val db = getDb ()
    in
	ignore (C.dml db ($`UPDATE Poll SET
			    usr = ^(C.intToSql (#usr poll)), title = ^(C.stringToSql (#title poll)),
			    descr = ^(C.stringToSql (#descr poll)),
			    starts = ^(C.stringToSql (#starts poll)), ends = ^(C.stringToSql (#ends poll)),
			    votes = ^(C.intToSql (#votes poll)), official = ^(C.boolToSql (#official poll)),
			    ready = ^(C.boolToSql (#ready poll))
			    WHERE id = ^(C.intToSql (#id poll))`))
    end

fun deletePoll id =
    ignore (C.dml (getDb ()) ($`DELETE FROM Poll WHERE id = ^(C.intToSql id)`))


(* Poll choices *)

type choice = {id : int, pol : int, seq : real, descr : string}

fun mkChoiceRow [id, pol, seq, descr] =
    {id = C.intFromSql id, pol = C.intFromSql pol,
     seq = C.realFromSql seq, descr = C.stringFromSql descr}
  | mkChoiceRow row = Init.rowError ("choice", row)

fun lookupChoice id =
    case C.oneOrNoRows (getDb ()) ($`SELECT id, pol, seq, descr
			             FROM PollChoice
			      	     WHERE id = ^(C.intToSql id)`) of
	NONE => raise Fail "Poll choice not found"
      | SOME row => mkChoiceRow row

fun listChoices pol =
    C.map (getDb ()) mkChoiceRow ($`SELECT id, pol, seq, descr
			            FROM PollChoice
			      	    WHERE pol = ^(C.intToSql pol)
				    ORDER BY seq`)

val mkChoiceRow' =
    fn (yours :: total :: rest) => (not (C.isNull yours) andalso C.intFromSql yours <> 0,
				    if C.isNull total then 0 else C.intFromSql total, mkChoiceRow rest)
     | row => Init.rowError ("choice'", row)

fun listChoicesWithVotes pol =
    C.map (getDb ()) mkChoiceRow' ($`SELECT (SELECT COUNT( * ) FROM Vote V WHERE V.cho = id AND V.usr = ^(C.intToSql (Init.getUserId ()))),
				        (SELECT COUNT( * ) FROM Vote V WHERE V.cho = id) AS total, id, pol, seq, descr
			             FROM PollChoice
			      	     WHERE pol = ^(C.intToSql pol)
				     ORDER BY total DESC, seq`)

val mkChoiceRow'' =
    fn (yours :: rest) => (not (C.isNull yours) andalso C.intFromSql yours <> 0,
			   mkChoiceRow rest)
     | row => Init.rowError ("choice''", row)

fun listChoicesWithMyVotes pol =
    C.map (getDb ()) mkChoiceRow'' ($`SELECT (SELECT COUNT( * ) FROM Vote V WHERE V.cho = id AND V.usr = ^(C.intToSql (Init.getUserId ()))),
				         id, pol, seq, descr
			              FROM PollChoice
			      	      WHERE pol = ^(C.intToSql pol)
				      ORDER BY seq`)

fun addChoice (pol, seq, descr) =
    let
	val db = getDb ()
	val id = nextSeq (db, "PollChoiceSeq")
    in
	C.dml db ($`INSERT INTO PollChoice (id, pol, seq, descr)
		    VALUES (^(C.intToSql id), ^(C.intToSql pol), ^(C.realToSql seq), ^(C.stringToSql descr))`);
	id
    end

fun modChoice (choice : choice) =
    let
	val db = getDb ()
    in
	ignore (C.dml db ($`UPDATE PollChoice SET
			    pol = ^(C.intToSql (#pol choice)), seq = ^(C.realToSql (#seq choice)),
			    descr = ^(C.stringToSql (#descr choice))
			    WHERE id = ^(C.intToSql (#id choice))`))
    end

fun deleteChoice id =
    ignore (C.dml (getDb ()) ($`DELETE FROM PollChoice WHERE id = ^(C.intToSql id)`))


(* Member voting *)

fun vote (usr, pol, chos) =
    let
	val db = getDb ()

	fun voteOnce cho =
	    ignore (C.dml db ($`INSERT INTO Vote (usr, cho) VALUES (^(C.intToSql usr), ^(C.intToSql cho))`))
    in
	ignore (C.dml db ($`DELETE FROM Vote WHERE cho IN (SELECT id FROM PollChoice WHERE pol = ^(C.intToSql pol)) AND usr = ^(C.intToSql usr)`));
	app voteOnce chos
    end


(* Date comparison *)

fun dateLe (d1, d2) =
    case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM DATE ^(C.stringToSql d1)) <= EXTRACT(EPOCH FROM DATE ^(C.stringToSql d2)))`) of
	[res] => C.boolFromSql res
      | row => Init.rowError ("dateLe", row)

fun dateGeNow d =
    case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM CURRENT_DATE) <= EXTRACT(EPOCH FROM DATE ^(C.stringToSql d)))`) of
	[res] => C.boolFromSql res
      | row => Init.rowError ("dateGeNow", row)

fun dateLeNow d =
    case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM CURRENT_DATE) >= EXTRACT(EPOCH FROM DATE ^(C.stringToSql d)))`) of
	[res] => C.boolFromSql res
      | row => Init.rowError ("dateLeNow", row)

fun dateLtNow d =
    case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM CURRENT_DATE) > EXTRACT(EPOCH FROM DATE ^(C.stringToSql d)))`) of
	[res] => C.boolFromSql res
      | row => Init.rowError ("dateLtNow", row)

fun canModify (poll : poll) =
    Group.inGroupName "poll"
    orelse ((#usr poll = Init.getUserId()
	     andalso (dateLtNow (#starts poll)
		      orelse not (#ready poll))))

fun requireCanModify poll =
    if canModify poll then
	()
    else
	raise Init.Access "Not authorized to edit that poll"

fun nextSeq pol =
    case C.oneRow (getDb ()) ($`SELECT MAX(seq)+1
			        FROM PollChoice
				WHERE pol = ^(C.intToSql pol)`) of
	[max] => if C.isNull max then 1.0 else C.realFromSql max
      | row => Init.rowError ("nextSeq", row)

fun takingVotes (poll : poll) =
    #ready poll andalso dateLeNow (#starts poll) andalso dateGeNow (#ends poll)

fun noDupes l =
    case l of
	[] => true
      | h::t => List.all (fn x => x <> h) t andalso noDupes t

fun listVoters cho =
    C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
			          FROM WebUser, Vote
				  WHERE usr = id
				     AND cho = ^(C.intToSql cho)
			          ORDER BY name`)

fun countVoters pol =
    case C.oneRow (getDb ()) ($`SELECT COUNT(DISTINCT usr)
			        FROM Vote JOIN PollChoice ON id = cho AND pol = ^(C.intToSql pol)`) of
	[count] => C.intFromSql count
      | row => Init.rowError ("countVoters", row)

fun listPollVoters pol =
    C.map (getDb ()) mkUserRow ($`SELECT DISTINCT WebUser.id, name, rname, bal, joined, app, shares, paypal, checkout
			          FROM WebUser, Vote JOIN PollChoice ON cho = PollChoice.id
				  WHERE pol = ^(C.intToSql pol)
				     AND usr = WebUser.id
			          ORDER BY name`)

val votingMembershipRequirement = 45

fun membershipLength id =
    case C.oneRow (getDb ()) ($`SELECT EXTRACT(DAY FROM (CURRENT_TIMESTAMP - joined))
		                FROM WebUser
			        WHERE id = ^(C.intToSql id)`) of
	[days] => C.intFromSql days
      | row => Init.rowError ("membershipLength", row)

end
Commit	Line	Data
e68ddb80 AC	1	structure Poll :> POLL =
	2	struct
	3
	4	open Util Sql Init
	5
ed97a006	6	type poll = {id : int, usr : int, title : string, descr : string, starts : string, ends : string, votes : int, official : bool, ready : bool}
e68ddb80	7
ed97a006	8	fun mkPollRow [id, usr, title, descr, starts, ends, votes, official, ready] =
e68ddb80 AC	9	{id = C.intFromSql id, usr = C.intFromSql usr, title = C.stringFromSql title,
e68ddb80 AC	10	descr = C.stringFromSql descr, starts = C.stringFromSql starts,
ed97a006 AC	11	ends = C.stringFromSql ends, votes = C.intFromSql votes, official = C.boolFromSql official,
ed97a006 AC	12	ready = C.boolFromSql ready}
ee587f7f	13	\| mkPollRow row = Init.rowError ("poll", row)
e68ddb80 AC	14
e68ddb80 AC	15	fun lookupPoll id =
ed97a006	16	case C.oneOrNoRows (getDb ()) ($`SELECT id, usr, title, descr, starts, ends, votes, official, ready
e68ddb80 AC	17	FROM Poll
	18	WHERE id = ^(C.intToSql id)`) of
	19	NONE => raise Fail "Poll not found"
	20	\| SOME row => mkPollRow row
	21
	22	fun listPolls () =
ed97a006	23	C.map (getDb ()) mkPollRow ($`SELECT id, usr, title, descr, starts, ends, votes, official, ready
e68ddb80	24	FROM Poll
ed97a006	25	WHERE ready
56dbfc30 AC	26	ORDER BY ends, starts DESC, title`)
	27
	28	fun listCurrentPolls () =
ed97a006	29	C.map (getDb ()) mkPollRow ($`SELECT id, usr, title, descr, starts, ends, votes, official, ready
56dbfc30 AC	30	FROM Poll
	31	WHERE EXTRACT(EPOCH FROM starts) <= EXTRACT(EPOCH FROM CURRENT_DATE)
	32	AND EXTRACT(EPOCH FROM ends) >= EXTRACT(EPOCH FROM CURRENT_DATE)
ed97a006	33	AND (ready OR usr = ^(C.intToSql (Init.getUserId ())))
56dbfc30	34	ORDER BY ends, starts DESC, title`)
e68ddb80 AC	35
e68ddb80 AC	36	fun listPollsLimit lim =
ed97a006	37	C.map (getDb ()) mkPollRow ($`SELECT id, usr, title, descr, starts, ends, votes, official, ready
e68ddb80 AC	38	FROM Poll
e68ddb80 AC	39	ORDER BY starts DESC, ends, title
ed97a006	40	WHERE (ready OR usr = ^(C.intToSql (Init.getUserId ())))
e68ddb80 AC	41	LIMIT ^(C.intToSql lim)`)
e68ddb80 AC	42
ed97a006	43	fun addPoll (usr, title, descr, starts, ends, votes, official, ready) =
e68ddb80 AC	44	let
	45	val db = getDb ()
	46	val id = nextSeq (db, "PollSeq")
	47	in
ed97a006	48	C.dml db ($`INSERT INTO Poll (id, usr, title, descr, starts, ends, votes, official, ready)
ee587f7f	49	VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.stringToSql title), ^(C.stringToSql descr),
ed97a006 AC	50	^(C.stringToSql starts), ^(C.stringToSql ends), ^(C.intToSql votes), ^(C.boolToSql official),
ed97a006 AC	51	^(C.boolToSql ready))`);
ee587f7f	52	id
e68ddb80 AC	53	end
	54
	55	fun modPoll (poll : poll) =
	56	let
	57	val db = getDb ()
	58	in
	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)),
ed97a006 AC	63	votes = ^(C.intToSql (#votes poll)), official = ^(C.boolToSql (#official poll)),
ed97a006 AC	64	ready = ^(C.boolToSql (#ready poll))
e68ddb80 AC	65	WHERE id = ^(C.intToSql (#id poll))`))
	66	end
	67
	68	fun deletePoll id =
	69	ignore (C.dml (getDb ()) ($`DELETE FROM Poll WHERE id = ^(C.intToSql id)`))
	70
	71
	72	(* Poll choices *)
	73
	74	type choice = {id : int, pol : int, seq : real, descr : string}
	75
	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}
ee587f7f	79	\| mkChoiceRow row = Init.rowError ("choice", row)
e68ddb80 AC	80
	81	fun lookupChoice id =
	82	case C.oneOrNoRows (getDb ()) ($`SELECT id, pol, seq, descr
	83	FROM PollChoice
	84	WHERE id = ^(C.intToSql id)`) of
	85	NONE => raise Fail "Poll choice not found"
	86	\| SOME row => mkChoiceRow row
	87
	88	fun listChoices pol =
	89	C.map (getDb ()) mkChoiceRow ($`SELECT id, pol, seq, descr
	90	FROM PollChoice
	91	WHERE pol = ^(C.intToSql pol)
	92	ORDER BY seq`)
	93
56dbfc30	94	val mkChoiceRow' =
ee587f7f AC	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)
56dbfc30 AC	98
	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
	102	FROM PollChoice
	103	WHERE pol = ^(C.intToSql pol)
	104	ORDER BY total DESC, seq`)
	105
	106	val mkChoiceRow'' =
ee587f7f AC	107	fn (yours :: rest) => (not (C.isNull yours) andalso C.intFromSql yours <> 0,
	108	mkChoiceRow rest)
	109	\| row => Init.rowError ("choice''", row)
56dbfc30 AC	110
	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 ()))),
	113	id, pol, seq, descr
	114	FROM PollChoice
	115	WHERE pol = ^(C.intToSql pol)
	116	ORDER BY seq`)
	117
e68ddb80 AC	118	fun addChoice (pol, seq, descr) =
	119	let
	120	val db = getDb ()
	121	val id = nextSeq (db, "PollChoiceSeq")
	122	in
	123	C.dml db ($`INSERT INTO PollChoice (id, pol, seq, descr)
ee587f7f AC	124	VALUES (^(C.intToSql id), ^(C.intToSql pol), ^(C.realToSql seq), ^(C.stringToSql descr))`);
ee587f7f AC	125	id
e68ddb80 AC	126	end
	127
	128	fun modChoice (choice : choice) =
	129	let
	130	val db = getDb ()
	131	in
	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))`))
	136	end
	137
	138	fun deleteChoice id =
	139	ignore (C.dml (getDb ()) ($`DELETE FROM PollChoice WHERE id = ^(C.intToSql id)`))
	140
	141
	142	(* Member voting *)
	143
	144	fun vote (usr, pol, chos) =
	145	let
	146	val db = getDb ()
	147
	148	fun voteOnce cho =
	149	ignore (C.dml db ($`INSERT INTO Vote (usr, cho) VALUES (^(C.intToSql usr), ^(C.intToSql cho))`))
	150	in
	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)`));
	152	app voteOnce chos
	153	end
	154
	155
	156	(* Date comparison *)
	157
	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
ee587f7f	161	\| row => Init.rowError ("dateLe", row)
e68ddb80 AC	162
	163	fun dateGeNow d =
	164	case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM CURRENT_DATE) <= EXTRACT(EPOCH FROM DATE ^(C.stringToSql d)))`) of
	165	[res] => C.boolFromSql res
ee587f7f	166	\| row => Init.rowError ("dateGeNow", row)
e68ddb80	167
56dbfc30 AC	168	fun dateLeNow d =
	169	case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM CURRENT_DATE) >= EXTRACT(EPOCH FROM DATE ^(C.stringToSql d)))`) of
	170	[res] => C.boolFromSql res
ee587f7f	171	\| row => Init.rowError ("dateLeNow", row)
56dbfc30	172
e68ddb80 AC	173	fun dateLtNow d =
	174	case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM CURRENT_DATE) > EXTRACT(EPOCH FROM DATE ^(C.stringToSql d)))`) of
	175	[res] => C.boolFromSql res
ee587f7f	176	\| row => Init.rowError ("dateLtNow", row)
e68ddb80 AC	177
	178	fun canModify (poll : poll) =
	179	Group.inGroupName "poll"
6aa0cd21 AC	180	orelse ((#usr poll = Init.getUserId()
	181	andalso (dateLtNow (#starts poll)
	182	orelse not (#ready poll))))
e68ddb80 AC	183
	184	fun requireCanModify poll =
	185	if canModify poll then
	186	()
	187	else
	188	raise Init.Access "Not authorized to edit that poll"
	189
	190	fun nextSeq pol =
	191	case C.oneRow (getDb ()) ($`SELECT MAX(seq)+1
	192	FROM PollChoice
	193	WHERE pol = ^(C.intToSql pol)`) of
	194	[max] => if C.isNull max then 1.0 else C.realFromSql max
ee587f7f	195	\| row => Init.rowError ("nextSeq", row)
e68ddb80	196
56dbfc30	197	fun takingVotes (poll : poll) =
ed97a006	198	#ready poll andalso dateLeNow (#starts poll) andalso dateGeNow (#ends poll)
56dbfc30 AC	199
	200	fun noDupes l =
	201	case l of
	202	[] => true
	203	\| h::t => List.all (fn x => x <> h) t andalso noDupes t
	204
	205	fun listVoters cho =
d5f8418b	206	C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
56dbfc30 AC	207	FROM WebUser, Vote
	208	WHERE usr = id
	209	AND cho = ^(C.intToSql cho)
	210	ORDER BY name`)
	211
1d2cae17 AC	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)
	217
	218	fun listPollVoters pol =
d5f8418b	219	C.map (getDb ()) mkUserRow ($`SELECT DISTINCT WebUser.id, name, rname, bal, joined, app, shares, paypal, checkout
1d2cae17 AC	220	FROM WebUser, Vote JOIN PollChoice ON cho = PollChoice.id
	221	WHERE pol = ^(C.intToSql pol)
	222	AND usr = WebUser.id
	223	ORDER BY name`)
	224
a0a15865 AC	225	val votingMembershipRequirement = 45
	226
	227	fun membershipLength id =
	228	case C.oneRow (getDb ()) ($`SELECT EXTRACT(DAY FROM (CURRENT_TIMESTAMP - joined))
	229	FROM WebUser
	230	WHERE id = ^(C.intToSql id)`) of
	231	[days] => C.intFromSql days
	232	\| row => Init.rowError ("membershipLength", row)
	233
1d2cae17	234	end