| REJECTED
| ADDED
- type app = { id : int, name : string, rname : string, email : string,
+ val readTosBody : unit -> string
+ val readTosAgree : unit -> string
+ val readTosMinorAgree : unit -> string
+
+ type app = { id : int, name : string, rname : string, gname : string option, email : string,
forward : bool, uses : string, other : string,
passwd : string, status : status, applied : Init.C.timestamp,
+ ipaddr : string option,
confirmed : Init.C.timestamp option, decided : Init.C.timestamp option,
msg : string }
fun statusFromSql v = statusFromInt (C.intFromSql v)
fun statusToSql s = C.intToSql (statusToInt s)
-type app = { id : int, name : string, rname : string, email : string,
+type app = { id : int, name : string, rname : string, gname : string option, email : string,
forward : bool, uses : string, other : string,
- passwd : string, status : status, applied : C.timestamp,
+ passwd : string, status : status, applied : C.timestamp, ipaddr : string option,
confirmed : C.timestamp option, decided : C.timestamp option,
msg : string}
-fun mkAppRow [id, name, rname, email, forward, uses, other, passwd, status, applied, confirmed, decided, msg] =
+fun mkAppRow [id, name, rname, gname, email, forward, uses, other, passwd, status,
+ applied, ipaddr, confirmed, decided, msg] =
{ id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname,
+ gname = (if C.isNull gname then NONE else SOME (C.stringFromSql gname)),
email = C.stringFromSql email, forward = C.boolFromSql forward,
uses = C.stringFromSql uses, other = C.stringFromSql other, passwd = C.stringFromSql passwd,
status = statusFromSql status, applied = C.timestampFromSql applied,
+ ipaddr = (if C.isNull ipaddr then NONE else SOME (C.stringFromSql ipaddr)),
confirmed = if C.isNull confirmed then NONE else SOME (C.timestampFromSql confirmed),
decided = if C.isNull decided then NONE else SOME (C.timestampFromSql decided),
msg = C.stringFromSql msg}
| mkAppRow r = rowError ("app", r)
fun lookupApp id =
- case C.oneOrNoRows (getDb ()) ($`SELECT id, name, rname, email, forward, uses, other, passwd, status, applied, confirmed, decided, msg
+ case C.oneOrNoRows (getDb ()) ($`SELECT id, name, rname, gname, email, forward, uses, other, passwd, status, applied, ipaddr, confirmed, decided, msg
FROM MemberApp
WHERE id = ^(C.intToSql id)`) of
SOME row => mkAppRow row
| NONE => raise Fail "Membership application not found"
fun listApps status =
- C.map (getDb ()) mkAppRow ($`SELECT id, name, rname, email, forward, uses, other, passwd, status, applied, confirmed, decided, msg
+ C.map (getDb ()) mkAppRow ($`SELECT id, name, rname, gname, email, forward, uses, other, passwd, status, applied, ipaddr, confirmed, decided, msg
FROM MemberApp
WHERE status = ^(statusToSql status)
ORDER BY applied`)
fun votes id = C.map (getDb ()) mkVoteRow ($`SELECT usr, name
FROM AppVote JOIN WebUser ON usr = id
- WHERE app = ^(C.intToSql id)
+ WHERE AppVote.app = ^(C.intToSql id)
ORDER BY name`)
fun vote (usr, app) = ignore (C.dml (getDb ()) ($`INSERT INTO AppVote (app, usr)
SET status = 2
WHERE id = ^(C.intToSql app)`))
+fun readFile fname =
+ let
+ val inf = TextIO.openIn fname
+
+ fun readLines lines =
+ case TextIO.inputLine inf of
+ NONE => String.concat (List.rev lines)
+ | SOME line => readLines (line :: lines)
+ in
+ readLines []
+ before TextIO.closeIn inf
+ end
+
+fun readTosBody () = readFile "/var/www/home/html/tos.body.html"
+fun readTosAgree () = readFile "/var/www/home/html/tos.agree.html"
+fun readTosMinorAgree () = readFile "/var/www/home/html/tos.agree.minor.html"
+
end
\ No newline at end of file
val init : unit -> unit
val done : unit -> unit
- type application = { name : string, rname : string, email : string,
+ val readTosBody : unit -> string
+ val readTosAgree : unit -> string
+ val readTosMinorAgree : unit -> string
+
+ type application = { name : string, rname : string, gname : string option, email : string,
forward : bool, uses : string, other : string }
val apply : application -> bool
db := NONE
end
+fun readFile fname =
+ let
+ val inf = TextIO.openIn fname
+
+ fun readLines lines =
+ case TextIO.inputLine inf of
+ NONE => String.concat (List.rev lines)
+ | SOME line => readLines (line :: lines)
+ in
+ readLines []
+ before TextIO.closeIn inf
+ end
+
+fun readTosBody () = readFile "/var/www/home/html/tos.body.html"
+fun readTosAgree () = readFile "/var/www/home/html/tos.agree.html"
+fun readTosMinorAgree () = readFile "/var/www/home/html/tos.agree.minor.html"
+
fun sendMail (to, subj, intro, footer, id) =
let
- val (name, rname, forward, uses, other) =
- case C.oneOrNoRows (getDb ()) ($`SELECT name, rname, forward, uses, other FROM MemberApp WHERE id = ^(C.intToSql id)`) of
- SOME [name, rname, forward, uses, other] => (C.stringFromSql name, C.stringFromSql rname,
- C.boolFromSql forward, C.stringFromSql uses,
- C.stringFromSql other)
+ val (name, rname, gname, forward, uses, other) =
+ case C.oneOrNoRows (getDb ()) ($`SELECT name, rname, gname, forward, uses, other FROM MemberApp WHERE id = ^(C.intToSql id)`) of
+ SOME [name, rname, gname, forward, uses, other] =>
+ (C.stringFromSql name, C.stringFromSql rname,
+ if C.isNull gname then NONE else SOME (C.stringFromSql gname),
+ C.boolFromSql forward, C.stringFromSql uses,
+ C.stringFromSql other)
| _ => raise Fail "Bad sendMail row"
val proc = Unix.execute ("/usr/sbin/exim4", ["-t"])
mwrite intro;
mwrite ("\n\nUsername: ");
mwrite (name);
- mwrite ("\nReal name: ");
+ mwrite ("\nMember real name: ");
mwrite (rname);
+ case gname of
+ NONE => ()
+ | SOME gname => (mwrite "\nLegal guardian name: ";
+ mwrite gname);
mwrite ("\nForward e-mail: ");
mwrite (if forward then "yes" else "no");
mwrite ("\n\nDesired uses:\n");
OS.Process.isSuccess (Unix.reap proc)
end
-type application = { name : string, rname : string, email : string,
+type application = { name : string, rname : string, gname : string option, email : string,
forward : bool, uses : string, other : string }
-fun apply {name, rname, email, forward, uses, other} =
+fun apply {name, rname, gname, email, forward, uses, other} =
let
val db = getDb ()
in
val id = C.intFromSql id
val passwd = Int.toString (Int.abs (Random.randInt (!rnd)))
in
- C.dml db ($`INSERT INTO MemberApp (id, name, rname, email, forward, uses, other, passwd, status, applied, msg)
+ C.dml db ($`INSERT INTO MemberApp (id, name, rname, gname, email, forward, uses, other, passwd, status, applied, msg)
VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname),
+ ^(case gname of NONE => "NULL" | SOME gname => C.stringToSql gname),
^(C.stringToSql email), ^(C.boolToSql forward), ^(C.stringToSql uses),
^(C.stringToSql other), ^(C.stringToSql passwd), 0, CURRENT_TIMESTAMP, '')`);
sendMail (email, "Confirm membership application",
<% @header [("title", ["Apply for membership"])] %>
<% if $"cmd" = "app" then
+ val minor = $"minor" <> "";
val name = $"name";
val rname = $"rname";
+ val gname = $"gname";
val email = $"email";
val forward = $"forward" <> "on";
val uses = $"uses";
val other = $"other";
- if name = "" then
+ if $"agree" <> "on" then
+ %><h3><b>You must accept the Terms of Service!</b></h3><%
+ elseif name = "" then
%><h3><b>Please enter a username</b></h3><%
elseif rname = "" then
- %><h3><b>Please enter your name</b></h3><%
+ %><h3><b>Please enter the potential member's name</b></h3><%
+ elseif (iff minor then gname = "" else false) then
+ %><h3><b>Please enter your name, as legal guardian<b></h3><%
elseif email = "" then
%><h3><b>Please enter your contact e-mail address</b></h3><%
elseif uses = "" then
elseif not (App.validEmail email) then
%><h3><b>Invalid e-mail address</b></h3><%
elseif not (App.apply { name = name, rname = rname, email = email,
+ gname = (case gname of "" => NONE | _ => SOME gname),
forward = forward, uses = uses, other = other }) then
%><h3><b>Error sending confirmation e-mail</b></h3><%
else
%><h3><b>Application recorded</b></h3>
Check your e-mail for a message with further instructions.<%
end
-else %>
+else
+ val minor = $"minor" <> "" %>
<form action="join" method="post">
<input type="hidden" name="cmd" value="app">
<table>
<tr> <td align="right" valign="top"><b>Desired username</b>:</td> <td><input name="name"><br>
You should follow usual UNIX conventions, and it's helpful to pick a name you wouldn't mind using to identify yourself to strangers.</td> </tr>
+<% if minor then %>
+<tr> <td align="right"><b>New member's "real" name</b>:</td> <td><input name="rname"></td> </tr>
+<tr> <td align="right"><b>Legal guardian's name</b>:</td> <td><input name="gname"></td> </tr>
+<% else %>
<tr> <td align="right"><b>Your "real" name</b>:</td> <td><input name="rname"></td> </tr>
+<% end %>
<tr> <td align="right"><b>Contact e-mail address</b></td> <td><input name="email"></td> </tr>
<tr> <td align="right" valign="top"><input type="checkbox" name="forward"></td> <td>Check this box if you would like to use hcoop as your primary e-mail provider.<br>
If you don't select this option and you are approved to join, e-mail to your account will be forwarded to the address you provide here.<br>
- You can change this option later, but we'll probably have helpul things to e-mail you as soon as you join. It's important that we be able to reach members reliably, so please don't decide to use us as your primary e-mail provider unless you can commit to checking your hcoop mailbox just as often as any other personal accounts you have.</td> </tr>
+ You can change this option later, but we'll probably have helpful things to e-mail you as soon as you join. It's important that we be able to reach members reliably, so please don't decide to use us as your primary e-mail provider unless you can commit to checking your hcoop mailbox just as often as any other personal accounts you have.</td> </tr>
<tr> <td align="right" valign="top"><b>How do you plan to use a hcoop membership?</b></td> <td><textarea name="uses" rows="5" cols="80" wrap="soft"></textarea></td> </tr>
<tr> <td align="right" valign="top"><b>Any other information about yourself</b></td> <td><textarea name="other" rows="5" cols="80" wrap="soft"></textarea></td> </tr>
-<tr> <td><input type="submit" value="Apply"></td> </tr>
</table>
+
+<h2><b>Terms of Service Agreement</b></h2>
+
+<% App.readTosBody () %>
+
+<br><hr><br>
+
+<input type="checkbox" name="agree">
+<% if minor then App.readTosMinorAgree () else App.readTosAgree () end %>
+
+<br><br><input type="submit" value="Apply">
+
</form>
<% end %>
<blockquote><tt>adduser <% #name appl %> "<% #rname appl %>"<% if #forward appl then %>" <% #email appl %>"<% end %></tt></blockquote>
<form action="users">
+<input type="hidden" name="app" value="<% #id appl %>">
<table>
<tr> <td align="right"><b>Name</b>:</td> <td><input name="name" value="<% Web.html (#name appl) %>"></td> </tr>
<tr> <td align="right"><b>Real name</b>:</td> <td><input name="rname" value="<% Web.html (#rname appl) %>"></td> </tr>
<b>Authorization error</b>: <% Web.htmlNl msg %>
<% | Web.Format s => %>
<b>Format</b>: <% Web.htmlNl s %>
+
+<% | Init.NeedTos => %>
+<p><b>Our records indicate that you need to agree to our Terms of Service.</b></p>
+
+<% val ap = #app (Init.getUser ());
+
+App.readTosBody () %>
+
+<br><hr><br>
+<form action="portal" method="post">
+
+<% val ap = App.lookupApp ap;
+switch #gname ap of
+ NONE => %>
+<b>Real name:</b> <% Web.html (#rname ap) %><br>
+<input type="checkbox" name="agree">
+<% App.readTosAgree ()
+ | SOME gname => %>
+<b>Member name:</b> <% Web.html (#rname ap) %><br>
+<b>Legal guardian name:</b> <% Web.html gname %><br>
+<input type="checkbox" name="agree">
+<% App.readTosMinorAgree ()
+end %>
+<br><br><input type="submit" value="Agree">
+</form>
+
<% | ex => %>
<b>Unknown exception kind.</b> Backtrace:
<% foreach s in SMLofNJ.exnHistory ex do %>
val boardEmail : string
exception Access of string
+ exception NeedTos
- type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp}
+ type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp,
+ app : int}
val rowError : string * C.value list -> 'a
val lookupUser : int -> user
val listUsers : unit -> user list
- val addUser : string * string * int -> int
+ val addUser : string * string * int * int -> int
(* Pass name, real name, and balance ID *)
val modUser : user -> unit
val deleteUser : int -> string
val getUserName : unit -> string
val dateString : unit -> string
+
+ val grandfatherUsers : unit -> unit
end
\ No newline at end of file
structure C = PgClient
exception Access of string
+exception NeedTos
val urlPrefix = "http://users.hcoop.net/portal/"
val boardEmail = "board.fake@hcoop.net"
fun conn () = C.conn "dbname='hcoop'"
val close = C.close
-type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp}
+type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp,
+ app : int}
val db = ref (NONE : C.conn option)
val user = ref (NONE : user option)
fun getDb () = valOf (!db)
-fun mkUserRow [id, name, rname, bal, joined] =
+fun mkUserRow [id, name, rname, bal, joined, app] =
{id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname,
- bal = C.intFromSql bal, joined = C.timestampFromSql joined}
+ bal = C.intFromSql bal, joined = C.timestampFromSql joined,
+ app = C.intFromSql app}
| mkUserRow row = rowError ("user", row)
fun init () =
val c = conn ()
in
+ db := SOME c;
C.dml c "BEGIN";
case Web.getCgi "REMOTE_USER" of
NONE => raise Fail "Not logged in"
| SOME name =>
- (case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined
+ (case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined, app
FROM WebUser
WHERE name=^(C.stringToSql name)`) of
NONE => raise Fail "User not found"
- | SOME r => user := SOME (mkUserRow r));
- db := SOME c
+ | SOME r =>
+ let
+ val r = mkUserRow r
+ in
+ user := SOME r;
+ case C.oneOrNoRows c ($`SELECT ipaddr
+ FROM MemberApp
+ WHERE id = ^(C.intToSql (#app r))
+ AND ipaddr IS NOT NULL`) of
+ NONE =>
+ if Web.getParam "agree" = "on" then
+ (case Web.getCgi "REMOTE_ADDR" of
+ NONE => raise Fail "REMOTE_ADDR not set"
+ | SOME ra =>
+ ignore (C.dml c ($`UPDATE MemberApp
+ SET ipaddr = ^(C.stringToSql ra),
+ applied = CURRENT_TIMESTAMP
+ WHERE id = ^(C.intToSql (#app r))`)))
+ else
+ raise NeedTos
+ | _ => ()
+ end)
end
fun done () =
fun getUserName () = #name (getUser ())
fun lookupUser id =
- mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined
+ mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined, app
FROM WebUser
WHERE id = ^(C.intToSql id)`))
fun listUsers () =
- C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined
+ C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app
FROM WebUser
ORDER BY name`)
[id] => C.intFromSql id
| _ => raise Fail "Bad next sequence val"
-fun addUser (name, rname, bal) =
+fun addUser (name, rname, bal, app) =
let
val db = getDb ()
val id = nextSeq (db, "WebUserSeq")
in
- C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined)
- VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal), CURRENT_TIMESTAMP)`);
+ C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined, app)
+ VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal), CURRENT_TIMESTAMP, ^(C.intToSql app))`);
id
end
in
ignore (C.dml db ($`UPDATE WebUser SET
name = ^(C.stringToSql (#name user)), rname = ^(C.stringToSql (#rname user)),
- bal = ^(C.intToSql (#bal user))
+ bal = ^(C.intToSql (#bal user)), app = ^(C.intToSql (#app user))
WHERE id = ^(C.intToSql (#id user))`))
end
[d] => C.stringFromSql d
| r => rowError ("dateString", r)
+fun grandfatherUsers () =
+ let
+ val db = getDb ()
+
+ fun mkApp [id, name, rname] =
+ let
+ val id = C.intFromSql id
+ val name = C.stringFromSql name
+ val rname = C.stringFromSql rname
+
+ val aid = nextSeq (db, "MemberAppSeq")
+ in
+ ignore (C.dml db ($`INSERT INTO MemberApp (id, name, rname, gname, email, forward, uses, other,
+ passwd, status, applied, confirmed, decided, msg)
+ VALUES (^(C.intToSql aid), ^(C.stringToSql name), ^(C.stringToSql rname),
+ NULL, '^name@hcoop.net', FALSE, 'GRANDFATHERED', 'GRANDFATHERED',
+ 'GRANDFATHERED', 4, CURRENT_TIMESTAMP, CURRENT_TIMESTAMP,
+ CURRENT_TIMESTAMP, 'GRANDFATHERED')`));
+ ignore (C.dml db ($`UPDATE WebUser SET app = ^(C.intToSql aid) WHERE id = ^(C.intToSql id)`))
+ end
+ in
+ C.app db mkApp "SELECT id, name, rname FROM WebUser WHERE app IS NULL"
+ end
end
\ No newline at end of file
+CREATE TABLE MemberApp(
+ id INTEGER PRIMARY KEY,
+ name TEXT NOT NULL,
+ rname TEXT NOT NULL,
+ gname TEXT,
+ email TEXT NOT NULL,
+ forward BOOLEAN NOT NULL,
+ uses TEXT NOT NULL,
+ other TEXT NOT NULL,
+ passwd TEXT NOT NULL,
+ status INTEGER NOT NULL,
+ applied TIMESTAMP NOT NULL,
+ ipaddr TEXT,
+ confirmed TIMESTAMP,
+ decided TIMESTAMP,
+ msg TEXT NOT NULL);
+
+CREATE SEQUENCE MemberAppSeq START 1;
+
CREATE TABLE Balance(
id INTEGER PRIMARY KEY,
name TEXT NOT NULL,
rname TEXT NOT NULL,
bal INTEGER NOT NULL,
joined TIMESTAMP NOT NULL,
- FOREIGN KEY (bal) REFERENCES Balance(id) ON DELETE CASCADE);
+ app INTEGER NOT NULL,
+ FOREIGN KEY (bal) REFERENCES Balance(id) ON DELETE CASCADE,
+ FOREIGN KEY (app) REFERENCES MemberApp(id) ON DELETE CASCADE);
CREATE SEQUENCE WebUserSeq START 1;
usr INTEGER PRIMARY KEY,
FOREIGN KEY (usr) REFERENCES WebUser(id) ON DELETE CASCADE);
-CREATE TABLE MemberApp(
- id INTEGER PRIMARY KEY,
- name TEXT NOT NULL,
- rname TEXT NOT NULL,
- email TEXT NOT NULL,
- forward BOOLEAN NOT NULL,
- uses TEXT NOT NULL,
- other TEXT NOT NULL,
- passwd TEXT NOT NULL,
- status INTEGER NOT NULL,
- applied TIMESTAMP NOT NULL,
- confirmed TIMESTAMP,
- decided TIMESTAMP,
- msg TEXT NOT NULL);
-
-CREATE SEQUENCE MemberAppSeq START 1;
-
CREATE TABLE AppVote(
app INTEGER NOT NULL,
usr INTEGER NOT NULL,
SOME _ => %>
<h3><b>Username already in use</b></h3>
<% | NONE =>
+ val ap = Web.stoi ($"app");
val bal =
(case $"bal" of
"" => Balance.addBalance ($"name")
| s => Web.stoi s);
- val id = Init.addUser ($"name", $"rname", bal);
+ val id = Init.addUser ($"name", $"rname", bal, ap);
Group.addToGroups (id, map Web.stoi (Web.getMultiParam "grp"));
if $"amount" <> "" then
Init.deleteUser (Web.stoi ($"del2")) %>
<h3><b><% #name user %> deleted!</b></h3>
+<% elseif $"cmd" = "grandfather" then
+ Init.grandfatherUsers()
+ %><h3><b>Grandfathered</b></h3>
+
<% end %>
<% if showNormal then %>
<% end %>
</table>
+<br><a href="users?cmd=grandfather">Grandfather old users to have applications</a><br>
+
<% end %>
<% @footer [] %>
\ No newline at end of file
HCoop / hcoop / zz_old / portal.git / commitdiff