From 53a2c4d4a18c2f5903961bce7bc61cf19336157f Mon Sep 17 00:00:00 2001 From: Benjamin Barenblat Date: Thu, 2 May 2013 19:45:39 -0400 Subject: Forum: Make anonymity typesafe MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit ‘username’ and ‘usernameOrAnonymous’ are now separate types. --- forum/author.ur | 67 ++++++++++++++++++++++++++++++++++++++++++++------------ forum/author.urs | 52 +++++++++++++++++++++++++++++++++++-------- forum/forum.ur | 21 +++++------------- 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 => + | Some u => 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 =