Poll administration

[hcoop/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 = raise Fail ("Bad poll row : " ^ makeSet id 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 starts DESC, ends, 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 (^id, ^(C.intToSql usr), ^(C.stringToSql title), ^(C.stringToSql descr),
			    ^(C.stringToSql starts), ^(C.stringToSql ends), ^(C.intToSql votes))`);
	C.intFromSql 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 = raise Fail ("Bad choice row : " ^ makeSet id 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`)

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 (^id, ^(C.intToSql pol), ^(C.realToSql seq), ^(C.stringToSql descr))`);
	C.intFromSql 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 => raise Fail ("Bad dateLe row: " ^ makeSet id 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 => raise Fail ("Bad dateGeNow row: " ^ makeSet id 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 => raise Fail ("Bad dateLtNow row: " ^ makeSet id 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 => raise Fail ("Bad nextSeq row: " ^ makeSet id row)

end