[hcoop/zz_old/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}

fun mkPollRow [id, usr, title, descr, starts, ends, votes] =
    {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}
  | mkPollRow row = Init.rowError ("poll", row)

fun lookupPoll id =
    case C.oneOrNoRows (getDb ()) ($`SELECT id, usr, title, descr, starts, ends, votes
			             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
			          FROM Poll
			      	  ORDER BY ends, starts DESC, title`)

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

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

fun addPoll (usr, title, descr, starts, ends, votes) =
    let
	val db = getDb ()
	val id = nextSeq (db, "PollSeq")
    in
	C.dml db ($`INSERT INTO Poll (id, usr, title, descr, starts, ends, votes)
		    VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.stringToSql title), ^(C.stringToSql descr),
			    ^(C.stringToSql starts), ^(C.stringToSql ends), ^(C.intToSql votes))`);
	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))
			    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))

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) =
    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`)

end
Commit	Line	Data
57c305c1	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}
369e1577	12	\| mkPollRow row = Init.rowError ("poll", row)
57c305c1	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
7f97ec97	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`)
57c305c1	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)
369e1577	45	VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.stringToSql title), ^(C.stringToSql descr),
57c305c1	46	^(C.stringToSql starts), ^(C.stringToSql ends), ^(C.intToSql votes))`);
369e1577	47	id
57c305c1	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}
369e1577	73	\| mkChoiceRow row = Init.rowError ("choice", row)
57c305c1	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
7f97ec97	88	val mkChoiceRow' =
369e1577	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)
7f97ec97	92
	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
	96	FROM PollChoice
	97	WHERE pol = ^(C.intToSql pol)
	98	ORDER BY total DESC, seq`)
	99
	100	val mkChoiceRow'' =
369e1577	101	fn (yours :: rest) => (not (C.isNull yours) andalso C.intFromSql yours <> 0,
	102	mkChoiceRow rest)
	103	\| row => Init.rowError ("choice''", row)
7f97ec97	104
	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 ()))),
	107	id, pol, seq, descr
	108	FROM PollChoice
	109	WHERE pol = ^(C.intToSql pol)
	110	ORDER BY seq`)
	111
57c305c1	112	fun addChoice (pol, seq, descr) =
	113	let
	114	val db = getDb ()
	115	val id = nextSeq (db, "PollChoiceSeq")
	116	in
	117	C.dml db ($`INSERT INTO PollChoice (id, pol, seq, descr)
369e1577	118	VALUES (^(C.intToSql id), ^(C.intToSql pol), ^(C.realToSql seq), ^(C.stringToSql descr))`);
369e1577	119	id
57c305c1	120	end
	121
	122	fun modChoice (choice : choice) =
	123	let
	124	val db = getDb ()
	125	in
	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))`))
	130	end
	131
	132	fun deleteChoice id =
	133	ignore (C.dml (getDb ()) ($`DELETE FROM PollChoice WHERE id = ^(C.intToSql id)`))
	134
	135
	136	(* Member voting *)
	137
	138	fun vote (usr, pol, chos) =
	139	let
	140	val db = getDb ()
	141
	142	fun voteOnce cho =
	143	ignore (C.dml db ($`INSERT INTO Vote (usr, cho) VALUES (^(C.intToSql usr), ^(C.intToSql cho))`))
	144	in
	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)`));
	146	app voteOnce chos
	147	end
	148
	149
	150	(* Date comparison *)
	151
	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
369e1577	155	\| row => Init.rowError ("dateLe", row)
57c305c1	156
	157	fun dateGeNow d =
	158	case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM CURRENT_DATE) <= EXTRACT(EPOCH FROM DATE ^(C.stringToSql d)))`) of
	159	[res] => C.boolFromSql res
369e1577	160	\| row => Init.rowError ("dateGeNow", row)
57c305c1	161
7f97ec97	162	fun dateLeNow d =
	163	case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM CURRENT_DATE) >= EXTRACT(EPOCH FROM DATE ^(C.stringToSql d)))`) of
	164	[res] => C.boolFromSql res
369e1577	165	\| row => Init.rowError ("dateLeNow", row)
7f97ec97	166
57c305c1	167	fun dateLtNow d =
	168	case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM CURRENT_DATE) > EXTRACT(EPOCH FROM DATE ^(C.stringToSql d)))`) of
	169	[res] => C.boolFromSql res
369e1577	170	\| row => Init.rowError ("dateLtNow", row)
57c305c1	171
	172	fun canModify (poll : poll) =
	173	Group.inGroupName "poll"
	174	orelse (#usr poll = Init.getUserId()
	175	andalso dateLtNow (#starts poll))
	176
	177	fun requireCanModify poll =
	178	if canModify poll then
	179	()
	180	else
	181	raise Init.Access "Not authorized to edit that poll"
	182
	183	fun nextSeq pol =
	184	case C.oneRow (getDb ()) ($`SELECT MAX(seq)+1
	185	FROM PollChoice
	186	WHERE pol = ^(C.intToSql pol)`) of
	187	[max] => if C.isNull max then 1.0 else C.realFromSql max
369e1577	188	\| row => Init.rowError ("nextSeq", row)
57c305c1	189
7f97ec97	190	fun takingVotes (poll : poll) =
	191	dateLeNow (#starts poll) andalso dateGeNow (#ends poll)
	192
	193	fun noDupes l =
	194	case l of
	195	[] => true
	196	\| h::t => List.all (fn x => x <> h) t andalso noDupes t
	197
	198	fun listVoters cho =
20acb925	199	C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
7f97ec97	200	FROM WebUser, Vote
	201	WHERE usr = id
	202	AND cho = ^(C.intToSql cho)
	203	ORDER BY name`)
	204
fd650826	205	fun countVoters pol =
	206	case C.oneRow (getDb ()) ($`SELECT COUNT(DISTINCT usr)
	207	FROM Vote JOIN PollChoice ON id = cho AND pol = ^(C.intToSql pol)`) of
	208	[count] => C.intFromSql count
	209	\| row => Init.rowError ("countVoters", row)
	210
	211	fun listPollVoters pol =
20acb925	212	C.map (getDb ()) mkUserRow ($`SELECT DISTINCT WebUser.id, name, rname, bal, joined, app, shares, paypal, checkout
fd650826	213	FROM WebUser, Vote JOIN PollChoice ON cho = PollChoice.id
	214	WHERE pol = ^(C.intToSql pol)
	215	AND usr = WebUser.id
	216	ORDER BY name`)
	217
	218	end