Forum: Add upvote button

9 files changed, 81 insertions, 10 deletions

diff --git a/forum/author.ur b/forum/author.ur
index f58d4cf..5cbc136 100644
--- a/forum/author.ur
+++ b/forum/author.ur
@@ -57,8 +57,22 @@ val sql_username = sql_prim
 
 fun name uOrA = uOrA
 
+val nameError = MyOption.getError
+
 val orAnonymous = Some
 
+(* I can't express this in terms of whenIdentified'--I get a "substitution in
+constructor is blocked by a too-deep unification variable." *)
+fun whenIdentified [ctx] [use] uOrA text =
+    case uOrA of
+	None => <xml/>
+      | Some u => text
+
+fun whenIdentified' [ctx] [use] uOrA generator =
+    case uOrA of
+	None => <xml/>
+      | Some u => generator u
+
 fun toOptionTag [_use] uOrA =
     case uOrA of
 	None => <xml/>
diff --git a/forum/author.urs b/forum/author.urs
index 1f394f0..db6e7a8 100644
--- a/forum/author.urs
+++ b/forum/author.urs
@@ -43,9 +43,17 @@ val sql_username : sql_injectable username
 (******************************** Converting *********************************)
 
 val name : usernameOrAnonymous -> option username
+val nameError : usernameOrAnonymous -> username
 
 val orAnonymous : username -> usernameOrAnonymous
 
+val whenIdentified : ctx ::: {Unit} -> use ::: {Type} ->
+		     usernameOrAnonymous -> xml ctx use [] -> xml ctx use []
+
+val whenIdentified' : ctx ::: {Unit} -> use ::: {Type} ->
+		      usernameOrAnonymous -> (username -> xml ctx use [])
+		      -> xml ctx use []
+
 (* Converts a 'usernameOrAnonymous' to an 'option' tag.  If anonymous, produces
 empty XML. *)
 val toOptionTag : use ::: {Type} -> usernameOrAnonymous -> xml select use []
diff --git a/forum/forum.css b/forum/forum.css
index 4f7b7f2..9193de0 100644
--- a/forum/forum.css
+++ b/forum/forum.css
@@ -27,6 +27,7 @@
 }
 
 .Forum_entryMetadata {
+    display: inline;
     font-style: italic;
     color: hsl(0, 0%, 65%);
 }
@@ -44,3 +45,7 @@ li .Forum_entryMetadata {
 .Forum_entryBody {
     height: 15em;
 }
+
+.Forum_voting, .Forum_voting * {
+    display: inline;
+}
diff --git a/forum/forum.ur b/forum/forum.ur
index c43befe..85f3e19 100644
--- a/forum/forum.ur
+++ b/forum/forum.ur
@@ -26,6 +26,7 @@ style entryList
 style entryMetadata
 style entryTitle
 style entryBody
+style voting
 
 table entry : { Id : int,
 		References : option int,
@@ -40,6 +41,8 @@ table vote : { QuestionId : int,
 	       Author : Author.username,
 	       Value : Score.score
 	     }
+    CONSTRAINT OneVotePerEntry UNIQUE (QuestionId, Author),
+    CONSTRAINT RefersToEntry FOREIGN KEY QuestionId REFERENCES entry(Id)
 
 (* Like query1', but automatically dereferences the field *)
 fun queryColumn [tab ::: Name] [field ::: Name] [state ::: Type]
@@ -56,27 +59,51 @@ fun getScore (questionId : int) : transaction Score.score =
 		Score.update
 		Score.undecided
 
+fun recordVote (value : Score.score) (entryId : int) _formData : transaction page =
+    authorOpt <- Author.current;
+    (* If the user didn't exist, the user should not have been allowed to vote
+    in the first place. *)
+    let val author = Author.nameError authorOpt
+    in
+	dml (INSERT INTO vote (QuestionId, Author, Value)
+	     VALUES ({[entryId]}, {[author]}, {[value]}));
+	detail entryId
+    end
+
+and upvote entryId _formData = recordVote Score.insightful entryId _formData
+
+
+
 (***************************** Single questions ******************************)
 
-fun detail (id : int) : transaction page =
+and detail (id : int) : transaction page =
     authorOpt <- Author.current;
     question <- oneRow1 (SELECT * FROM entry
 				  WHERE Entry.Class = {[EntryClass.question]}
 				    AND Entry.Id = {[id]});
-    answerBlock <- queryX1 (SELECT * FROM entry
+    score <- getScore id;
+    answerBlock <- queryX1' (SELECT * FROM entry
 				     WHERE Entry.Class = {[EntryClass.answer]}
 				       AND Entry.References = {[Some id]})
 			   (fn answer =>
-        <xml><p>
-	  {[answer.Body]}
-	  <span class={entryMetadata}>&mdash;{[answer.Author]}</span>
-	</p></xml>);
+	score <- getScore answer.Id;
+	return (
+            <xml><p>
+	      {[answer.Body]}
+	      <span class={entryMetadata}>&mdash;{[answer.Author]} ({[Score.withUnits score "point"]})</span>
+	    </p></xml>));
     return (
         Template.generic (Some "Forum") <xml>
          <div class={content}>
            <h2>{[question.Title]}</h2>
            <p>{[question.Body]}</p>
-           <p class={entryMetadata}>Asked by {[question.Author]}</p>
+           <p class={entryMetadata}>
+	     Asked by {[question.Author]} ({[Score.withUnits score "point"]})
+	   </p>
+	   {Author.whenIdentified authorOpt
+		<xml>
+		  <form class={voting}><submit action={upvote id} value="⬆" /></form>
+		</xml>}
 
 	   <div>{answerBlock}</div>
 
@@ -85,7 +112,7 @@ fun detail (id : int) : transaction page =
              <textarea {#Body} class={entryBody} /><br />
              Answering as:
              <select {#Author}>
-               {Author.toOptionTag authorOpt}
+	       {Author.whenIdentified' authorOpt (fn u => <xml><option>{[u]}</option></xml>)}
                <option>Anonymous</option>
              </select>
              <submit action={reply id} value="Answer" />
@@ -113,7 +140,7 @@ fun prettyPrintQuestion entry : transaction xbody =
         <xml><li>
 	  <h3><a link={detail entry.Id}>{[entry.Title]}</a></h3>
 	  {[entry.Body]}
-	  <span class={entryMetadata}>Asked by {[entry.Author]}; score {[score]}</span>
+	  <span class={entryMetadata}>Asked by {[entry.Author]} ({[Score.withUnits score "point"]})</span>
 	</li></xml>)
 
 val allQuestions : transaction page =
@@ -153,7 +180,8 @@ fun main () : transaction page =
 	      <textarea {#Body} class={entryBody} /><br />
 	      Asking as:
 	      <select {#Author}>
-	        {Author.toOptionTag askerOpt}
+		{Author.whenIdentified' askerOpt (fn u =>
+		     <xml><option>{[u]}</option></xml>)}
 		<option>Anonymous</option>
 	      </select>
 	      <submit action={ask} value="Ask" />
diff --git a/forum/lib.urp b/forum/lib.urp
index 77d7073..d313fcd 100644
--- a/forum/lib.urp
+++ b/forum/lib.urp
@@ -6,6 +6,7 @@ rewrite style Main/Forum/* Forum/
 rewrite style Main/Forum/ Forum/
 
 $/option
+myOption
 $/string
 ../styles
 author
diff --git a/forum/myOption.ur b/forum/myOption.ur
new file mode 100644
index 0000000..e859454
--- /dev/null
+++ b/forum/myOption.ur
@@ -0,0 +1,4 @@
+fun getError [t] maybe =
+    case maybe of
+	None => error <xml>Attempted to extract a value out of a None</xml>
+      | Some v => v
diff --git a/forum/myOption.urs b/forum/myOption.urs
new file mode 100644
index 0000000..890c31b
--- /dev/null
+++ b/forum/myOption.urs
@@ -0,0 +1 @@
+val getError : t ::: Type -> option t -> t
diff --git a/forum/score.ur b/forum/score.ur
index 48bbc01..a966a4d 100644
--- a/forum/score.ur
+++ b/forum/score.ur
@@ -15,3 +15,8 @@ val undecided = 0
 val inane = -1
 
 fun toInt s = s
+
+fun withUnits s base =
+    show s ^ " " ^ (case s of
+			1 => base
+		      | _ => base ^ "s")
diff --git a/forum/score.urs b/forum/score.urs
index d3e3e18..616d1b6 100644
--- a/forum/score.urs
+++ b/forum/score.urs
@@ -24,3 +24,8 @@ val update : score -> score -> score
 (******************************** Conversion *********************************)
 
 val toInt : score -> int
+
+
+(****************************** Pretty-printing ******************************)
+
+val withUnits : score -> string -> string