Forum: Make anonymity typesafe

‘username’ and ‘usernameOrAnonymous’ are now separate types.

4 files changed, 105 insertions, 38 deletions

diff --git a/forum/author.ur b/forum/author.ur
index e0b1989..f58d4cf 100644
--- a/forum/author.ur
+++ b/forum/author.ur
@@ -1,26 +1,65 @@
-type author = option string
+(********************************** A user ***********************************)
 
-val eq_author = Option.eq
+type usernameOrAnonymous = option string
 
-val show_author =
+
+(*** Instances ***)
+
+val eq_usernameOrAnonymous = Option.eq
+
+val show_usernameOrAnonymous =
     mkShow (
         fn nameOpt =>
-	    case nameOpt of
-        	None => "Anonymous"
-              | Some nam => nam
-    )
+           case nameOpt of
+               None => "Anonymous"
+             | Some nam => nam)
 
 val read_author =
     let fun parse text =
-	    case text of
-		"Anonymous" => None
-	      | nam => Some nam
+           case text of
+               "Anonymous" => None
+             | nam => Some nam
     in
-	mkRead parse (compose Some parse)
+       mkRead parse (compose Some parse)
     end
 
-val sql_author = sql_option_prim
+val sql_usernameOrAnonymous = sql_option_prim
+
+
+(*** Getting the username ***)
+
+val current =
+    addressOpt <- getenv (blessEnvVar "SSL_CLIENT_S_DN_Email");
+    (* SSL_CLIENT_EMAIL contains the user's entire e-mail address, including
+    the "@MIT.EDU" part.  Get rid of the domain name. *)
+    return (address <- addressOpt;
+    	    usernameAndDomain <- String.split address #"@";
+    	    return usernameAndDomain.1)
+
+
+(******************************* A named user ********************************)
+
+type username = string
+
+
+(*** Instances ***)
+
+val eq_username = eq_string
+
+val show_username = show_string
+
+val read_username = read_string
+
+val sql_username = sql_prim
+
+
+(******************************** Converting *********************************)
+
+fun name uOrA = uOrA
 
-val anonymous = None
+val orAnonymous = Some
 
-val namedAuthor = Some
+fun toOptionTag [_use] uOrA =
+    case uOrA of
+	None => <xml/>
+      | Some u => <xml><option>{[u]}</option></xml>
diff --git a/forum/author.urs b/forum/author.urs
index 619aced..1f394f0 100644
--- a/forum/author.urs
+++ b/forum/author.urs
@@ -1,17 +1,51 @@
-type author
+(********************************** A user ***********************************)
 
-val anonymous : author
-val namedAuthor : string -> author
+type usernameOrAnonymous
 
 
-(********************************* Instances *********************************)
+(*** Instances **)
 
-val eq_author : eq author
+val eq_usernameOrAnonymous : eq usernameOrAnonymous
 
-val show_author : show author
+val show_usernameOrAnonymous : show usernameOrAnonymous
 
-(* 'read' producing an 'author' is guaranteed to never fail, so you can use
+(* 'read' producing a 'usernameOrAnonymous' is guaranteed to never fail, so you
+can use 'readError' with impunity. *)
+val read_usernameOrAnonymous : read usernameOrAnonymous
+
+val sql_usernameOrAnonymous : sql_injectable usernameOrAnonymous
+
+
+(*** Getting the username ***)
+
+(* Grabs username out of MIT certificate. *)
+val current : transaction usernameOrAnonymous
+
+
+(******************************* A named user ********************************)
+
+type username
+
+
+(*** Instances **)
+
+val eq_username : eq username
+
+val show_username : show username
+
+(* 'read' producing a 'username' is guaranteed to never fail, so you can use
 'readError' with impunity. *)
-val read_author : read author
+val read_username : read username
+
+val sql_username : sql_injectable username
+
+
+(******************************** Converting *********************************)
+
+val name : usernameOrAnonymous -> option username
+
+val orAnonymous : username -> usernameOrAnonymous
 
-val sql_author : sql_injectable author
+(* 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.ur b/forum/forum.ur
index e1bf577..c43befe 100644
--- a/forum/forum.ur
+++ b/forum/forum.ur
@@ -21,7 +21,6 @@ functor Make(Template : sig
 end) = struct
 
 open Styles
-open Author
 
 style entryList
 style entryMetadata
@@ -33,19 +32,15 @@ table entry : { Id : int,
 		Class : EntryClass.entryClass,
 		Title : option string,
 		Body : string,
-		Author : author
+		Author : Author.usernameOrAnonymous
 	      } PRIMARY KEY Id
 sequence entryIdS
 
 table vote : { QuestionId : int,
-	       Author : author,
+	       Author : Author.username,
 	       Value : Score.score
 	     }
 
-(* Grabs real name out of MIT certificate. *)
-val getName : transaction (option string) =
-    getenv (blessEnvVar "SSL_CLIENT_S_DN_CN")
-
 (* Like query1', but automatically dereferences the field *)
 fun queryColumn [tab ::: Name] [field ::: Name] [state ::: Type]
 		(q : sql_query [] [] [tab = [field = state]] [])
@@ -64,7 +59,7 @@ fun getScore (questionId : int) : transaction Score.score =
 (***************************** Single questions ******************************)
 
 fun detail (id : int) : transaction page =
-    authorOpt <- getName;
+    authorOpt <- Author.current;
     question <- oneRow1 (SELECT * FROM entry
 				  WHERE Entry.Class = {[EntryClass.question]}
 				    AND Entry.Id = {[id]});
@@ -90,9 +85,7 @@ fun detail (id : int) : transaction page =
              <textarea {#Body} class={entryBody} /><br />
              Answering as:
              <select {#Author}>
-               {case authorOpt of
-                    None => <xml/>
-                  | Some nam => <xml><option>{[nam]}</option></xml>}
+               {Author.toOptionTag authorOpt}
                <option>Anonymous</option>
              </select>
              <submit action={reply id} value="Answer" />
@@ -144,7 +137,7 @@ fun main () : transaction page =
 					  ORDER BY Entry.Id DESC
 					  LIMIT 5)
 				prettyPrintQuestion;
-    askerOpt <- getName;
+    askerOpt <- Author.current;
     return (
         Template.generic (Some "Forum") <xml>
 	  <div class={content}>
@@ -160,9 +153,7 @@ fun main () : transaction page =
 	      <textarea {#Body} class={entryBody} /><br />
 	      Asking as:
 	      <select {#Author}>
-	        {case askerOpt of
-		     None => <xml/>
-		   | Some nam => <xml><option>{[nam]}</option></xml>}
+	        {Author.toOptionTag askerOpt}
 		<option>Anonymous</option>
 	      </select>
 	      <submit action={ask} value="Ask" />
diff --git a/forum/lib.urp b/forum/lib.urp
index 6593a1d..77d7073 100644
--- a/forum/lib.urp
+++ b/forum/lib.urp
@@ -1,9 +1,12 @@
 allow url //bbaren.scripts.mit.edu/urweb/6.947-static/forum/forum.css
 allow env SSL_CLIENT_S_DN_CN
+allow env SSL_CLIENT_S_DN_Email
+allow env *
 rewrite style Main/Forum/* Forum/
 rewrite style Main/Forum/ Forum/
 
 $/option
+$/string
 ../styles
 author
 entryClass