diff options
author | Benjamin Barenblat <bbaren@mit.edu> | 2013-05-02 19:45:39 -0400 |
---|---|---|
committer | Benjamin Barenblat <bbaren@mit.edu> | 2013-05-02 19:45:39 -0400 |
commit | 53a2c4d4a18c2f5903961bce7bc61cf19336157f (patch) | |
tree | 9fdc0f4898d5faf2de9cf93d7334d692342b2bd5 /forum | |
parent | 5bc9450c1990b26133e34d7a8a8b9d43a7377d6c (diff) |
Forum: Make anonymity typesafe
‘username’ and ‘usernameOrAnonymous’ are now separate types.
Diffstat (limited to 'forum')
-rw-r--r-- | forum/author.ur | 67 | ||||
-rw-r--r-- | forum/author.urs | 52 | ||||
-rw-r--r-- | forum/forum.ur | 21 | ||||
-rw-r--r-- | forum/lib.urp | 3 |
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 |