X-Git-Url: https://git.hcoop.net/bpt/portal.git/blobdiff_plain/e68ddb8014e01a51952aa8077fa1e85c4a1fa014..6aa0cd21ab8b74949d95d375e22dae72a9f35b8c:/poll.sml

diff --git a/poll.sml b/poll.sml
index a30d733..34868cf 100644
--- a/poll.sml
+++ b/poll.sml
@@ -3,41 +3,53 @@ struct
 
 open Util Sql Init
 
-type poll = {id : int, usr : int, title : string, descr : string, starts : string, ends : string, votes : int}
+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] =
+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}
-  | mkPollRow row = raise Fail ("Bad poll row : " ^ makeSet id row)
+     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
+    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
+    C.map (getDb ()) mkPollRow ($`SELECT id, usr, title, descr, starts, ends, votes, official, ready
 			          FROM Poll
-			      	  ORDER BY starts DESC, ends, title`)
+				  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
+    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) =
+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)
-		    VALUES (^id, ^(C.intToSql usr), ^(C.stringToSql title), ^(C.stringToSql descr),
-			    ^(C.stringToSql starts), ^(C.stringToSql ends), ^(C.intToSql votes))`);
-	C.intFromSql id
+	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) =
@@ -48,7 +60,8 @@ fun modPoll (poll : poll) =
 			    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))
+			    votes = ^(C.intToSql (#votes poll)), official = ^(C.boolToSql (#official poll)),
+			    ready = ^(C.boolToSql (#ready poll))
 			    WHERE id = ^(C.intToSql (#id poll))`))
     end
 
@@ -63,7 +76,7 @@ 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)
+  | mkChoiceRow row = Init.rowError ("choice", row)
 
 fun lookupChoice id =
     case C.oneOrNoRows (getDb ()) ($`SELECT id, pol, seq, descr
@@ -78,14 +91,38 @@ fun listChoices pol =
 			      	    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 (^id, ^(C.intToSql pol), ^(C.realToSql seq), ^(C.stringToSql descr))`);
-	C.intFromSql id
+		    VALUES (^(C.intToSql id), ^(C.intToSql pol), ^(C.realToSql seq), ^(C.stringToSql descr))`);
+	id
     end
 
 fun modChoice (choice : choice) =
@@ -121,22 +158,28 @@ fun vote (usr, pol, chos) =
 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)
+      | 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 => raise Fail ("Bad dateGeNow row: " ^ makeSet id row)
+      | 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 => raise Fail ("Bad dateLtNow row: " ^ makeSet id row)
+      | row => Init.rowError ("dateLtNow", row)
 
 fun canModify (poll : poll) =
     Group.inGroupName "poll"
-    orelse (#usr poll = Init.getUserId()
-	    andalso dateLtNow (#starts poll))
+    orelse ((#usr poll = Init.getUserId()
+	     andalso (dateLtNow (#starts poll)
+		      orelse not (#ready poll))))
 
 fun requireCanModify poll =
     if canModify poll then
@@ -149,6 +192,43 @@ fun nextSeq pol =
 			        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
\ No newline at end of file
+      | 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