--- /dev/null
+out
+.cm
+CM
--- /dev/null
+<% Init.done () %>
+
+<!-- After -->
\ No newline at end of file
--- /dev/null
+signature BALANCE =
+sig
+ type balance = {id :int, name : string, amount : real}
+
+ val addBalance : string -> int
+ val lookupBalance : int -> balance
+ val modBalance : balance -> unit
+ val deleteBalance : int -> unit
+ val listBalances : unit -> balance list
+ val listBalanceUsers : int -> Init.user list
+
+ val validBalanceName : string -> bool
+ val balanceNameToId : string -> int option
+end
\ No newline at end of file
--- /dev/null
+structure Balance :> BALANCE =
+struct
+
+open Util Sql Init
+
+
+(* Managing balances *)
+
+type balance = {id :int, name : string, amount : real}
+
+fun mkBalanceRow [id, name, amount] =
+ {id = C.intFromSql id, name = C.stringFromSql name, amount = C.realFromSql amount}
+ | mkBalanceRow row = raise Fail ("Bad balance row : " ^ makeSet id row)
+
+fun addBalance name =
+ let
+ val db = getDb ()
+ val id = nextSeq (db, "BalanceSeq")
+ in
+ C.dml db ($`INSERT INTO Balance (id, name, amount)
+ VALUES (^id, ^(C.stringToSql name), 0.0)`);
+ C.intFromSql id
+ end
+
+fun lookupBalance id =
+ let
+ val c = getDb ()
+ in
+ (case C.oneOrNoRows c ($`SELECT id, name, amount FROM Balance WHERE id = ^(C.intToSql id)`) of
+ NONE => raise Fail "Balance not found"
+ | SOME r => mkBalanceRow r)
+ end
+
+fun modBalance (balance : balance) =
+ let
+ val db = getDb ()
+ in
+ ignore (C.dml db ($`UPDATE Balance
+ SET name = ^(C.stringToSql (#name balance))
+ WHERE id = ^(C.intToSql (#id balance))`))
+ end
+
+fun deleteBalance id =
+ ignore (C.dml (getDb ()) ($`DELETE FROM Balance WHERE id = ^(C.intToSql id)`))
+
+fun listBalances () =
+ C.map (getDb ()) mkBalanceRow ($`SELECT id, name, amount FROM Balance
+ ORDER BY name`)
+
+fun validBalanceName name =
+ size name <= 20
+ andalso CharVector.all (fn ch => Char.isAlpha ch orelse ch = #"+") name
+
+fun balanceNameToId name =
+ case C.oneOrNoRows (getDb ()) ($`SELECT id FROM Balance WHERE name = ^(C.stringToSql name)`) of
+ SOME [id] => SOME (C.intFromSql id)
+ | _ => NONE
+
+fun listBalanceUsers bal =
+ C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined
+ FROM WebUser
+ WHERE bal = ^(C.intToSql bal)
+ ORDER BY name`)
+
+end
\ No newline at end of file
--- /dev/null
+<% Group.requireGroupNum 0;
+
+@header [("title", ["Balance management"])];
+
+ref showNormal = true;
+
+if $"cmd" = "Create" then
+ if not (Balance.validBalanceName ($"name")) then %>
+ <h3><b>Invalid balance name</b></h3>
+ <% else switch Balance.balanceNameToId ($"name") of
+ SOME _ => %>
+ <h3><b>Balance name already in use</b></h3>
+<% | NONE =>
+ val id = Balance.addBalance ($"name") %>
+ <h3><b>Balance added</b></h3>
+<% end
+ end
+elseif $"mod" <> "" then
+ showNormal := false;
+ val balance = Balance.lookupBalance (Web.stoi ($"mod")) %>
+<h3><b>Modify balance record</b></h3>
+
+<form action="balances">
+<input type="hidden" name="id" value="<% $"mod" %>">
+<table>
+<tr> <td align="right"><b>Name</b>:</td> <td><input name="name" value="<% #name balance %>"></td> </tr>
+<tr> <td><input type="submit" name="cmd" value="Save"></td> </tr>
+</table>
+</form>
+
+<% elseif $"cmd" = "Save" then
+ val balance = Balance.lookupBalance (Web.stoi ($"id"));
+ Balance.modBalance {balance with name = $"name"} %>
+ <h3><b>Balance record saved.</b></h3>
+
+<% elseif $"del" <> "" then
+ showNormal := false;
+ val balance = Balance.lookupBalance (Web.stoi ($"del")) %>
+ <h3><b>Are you sure you want to delete balance <% #name balance %></a>?</b></h3>
+ <a href="balances?del2=<% $"del" %>">Yes, delete <% #name balance %>!</a>
+
+<% elseif $"del2" <> "" then
+ val balance = Balance.lookupBalance (Web.stoi ($"del2"));
+ Balance.deleteBalance (Web.stoi ($"del2")) %>
+ <h3><b><% #name balance %> deleted!</b></h3>
+
+<% end %>
+
+<% if showNormal then %>
+<h3><b>New balance</b></h3>
+
+<form action="balances">
+<table>
+<tr> <td align="right"><b>Name</b>:</td> <td><input name="name"></td> </tr>
+<tr> <td><input type="submit" name="cmd" value="Create"></td> </tr>
+</table>
+</form>
+
+<h3><b>Manage current balances</b></h3>
+
+<table>
+<% foreach balance in Balance.listBalances () do %>
+ <tr> <td><% Web.html (#name balance) %></td> <td><% #amount balance %></td> <td><a href="balances?mod=<% #id balance %>">[Modify]</a> <a href="balances?del=<% #id balance %>">[Delete]</a></td> </tr>
+<% end %>
+</table>
+
+<% end %>
+
+<% @footer [] %>
--- /dev/null
+<% Init.init () %>
+
+<!-- Before -->
\ No newline at end of file
--- /dev/null
+<% @header [("title", ["Exception"])] %>
+
+<% switch Web.getExn () of
+ Fail msg => %>
+<b>Fail</b>: <% Web.htmlNl msg %>
+<% | Init.C.Sql msg => %>
+<b>SQL</b>: <% Web.htmlNl msg %>
+<% | Init.Access msg => %>
+<b>Authorization error</b>: <% Web.htmlNl msg %>
+<% | Web.Format s => %>
+<b>Format</b>: <% Web.htmlNl s %>
+<% | ex => %>
+<b>Unknown exception kind.</b> Backtrace:
+<% foreach s in SMLofNJ.exnHistory ex do %>
+<li> <% Web.html s %></li>
+<% end
+end %>
+
+<% @footer [] %>
--- /dev/null
+</body></html>
\ No newline at end of file
--- /dev/null
+signature GROUP =
+sig
+ type group = {id :int, name : string}
+ type membership = {usr : int, grp : int}
+
+ val addGroup : string -> int
+ val lookupGroup : int -> group
+ val modGroup : group -> unit
+ val deleteGroup : int -> unit
+ val listGroups : unit -> group list
+
+ val validGroupName : string -> bool
+ val groupNameToId : string -> int option
+
+ val userInGroupNum : int * int -> bool
+ val userInGroupName : int * string -> bool
+
+ val addToGroup : membership -> unit
+ val addToGroups : int * int list -> unit
+ val removeFromGroup : membership -> unit
+ val groupMembers : int -> Init.user list
+
+ val inGroupNum : int -> bool
+ val inGroupName : string -> bool
+
+ (* These raise Access if the check fails *)
+ val requireGroupNum : int -> unit
+ val requireGroupName : string -> unit
+end
\ No newline at end of file
--- /dev/null
+structure Group :> GROUP =
+struct
+
+open Util Sql Init
+
+
+(* Managing groups *)
+
+type group = {id :int, name : string}
+
+fun mkGroupRow [id, name] =
+ {id = C.intFromSql id, name = C.stringFromSql name}
+ | mkGroupRow row = raise Fail ("Bad group row : " ^ makeSet id row)
+
+fun addGroup name =
+ let
+ val db = getDb ()
+ val id = nextSeq (db, "WebGroupSeq")
+ in
+ C.dml db ($`INSERT INTO WebGroup (id, name)
+ VALUES (^id, ^(C.stringToSql name))`);
+ C.intFromSql id
+ end
+
+fun lookupGroup id =
+ let
+ val c = getDb ()
+ in
+ (case C.oneOrNoRows c ($`SELECT id, name FROM WebGroup WHERE id = ^(C.intToSql id)`) of
+ NONE => raise Fail "Group not found"
+ | SOME r => mkGroupRow r)
+ end
+
+fun modGroup (group : group) =
+ let
+ val db = getDb ()
+ in
+ ignore (C.dml db ($`UPDATE WebGroup
+ SET name = ^(C.stringToSql (#name group))
+ WHERE id = ^(C.intToSql (#id group))`))
+ end
+
+fun deleteGroup id =
+ ignore (C.dml (getDb ()) ($`DELETE FROM WebGroup WHERE id = ^(C.intToSql id)`))
+
+fun listGroups () =
+ C.map (getDb ()) mkGroupRow ($`SELECT id, name FROM WebGroup
+ ORDER BY name`)
+
+(* Checking group membership *)
+
+fun userInGroupNum (usr, grp) =
+ let
+ val c = getDb ()
+ in
+ (case C.oneOrNoRows c ($`SELECT COUNT( * )
+ FROM Membership
+ WHERE grp = ^(C.intToSql grp)
+ AND usr = ^(C.intToSql usr)`) of
+ SOME[x] => x <> "0"
+ | _ => false)
+ end
+
+fun userInGroupName (usr, grp) =
+ let
+ val c = getDb ()
+ in
+ (case C.oneOrNoRows c ($`SELECT COUNT( * )
+ FROM Membership, WebGroup
+ WHERE name = ^(C.stringToSql grp)
+ AND usr = ^(C.intToSql usr)
+ AND grp = id`) of
+ SOME[x] => x <> "0"
+ | _ => false)
+ end
+
+
+(* Managing group memberships *)
+
+type membership = {usr : int, grp : int}
+
+fun addToGroup (mem : membership) =
+ let
+ val usr = #usr mem
+ val grp = #grp mem
+ in
+ if userInGroupNum (usr, grp) then
+ ()
+ else
+ ignore (C.dml (getDb ()) ($`INSERT INTO Membership (grp, usr)
+ VALUES (^(C.intToSql grp), ^(C.intToSql usr))`))
+ end
+
+fun addToGroups (usr, grps) =
+ List.app (fn grp => addToGroup {usr = usr, grp = grp}) grps
+
+fun removeFromGroup (mem : membership) =
+ let
+ val usr = #usr mem
+ val grp = #grp mem
+ in
+ ignore (C.dml (getDb ()) ($`DELETE FROM Membership
+ WHERE grp = ^(C.intToSql grp)
+ AND usr = ^(C.intToSql usr)`))
+ end
+
+fun mkMembershipRow [grp, usr] =
+ {grp = C.intFromSql grp, usr = C.intFromSql usr}
+ | mkMembershipRow row = raise Fail ("Bad membership row : " ^ makeSet id row)
+
+fun groupMembers grp =
+ C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined FROM Membership, WebUser
+ WHERE grp = ^(C.intToSql grp)
+ AND usr = id
+ ORDER BY name`)
+
+
+(* Checking memberships of the current user *)
+
+fun inGroupNum grp = userInGroupNum (getUserId(), grp)
+fun inGroupName grp = userInGroupName (getUserId(), grp)
+
+fun requireGroupNum grp =
+ if inGroupNum grp then
+ ()
+ else
+ raise Access ("You aren't a member of group #" ^ Int.toString grp)
+
+fun requireGroupName grp =
+ if inGroupName grp then
+ ()
+ else
+ raise Access ("You aren't a member of group \"" ^ grp ^ "\"")
+
+fun validGroupName name =
+ size name <= 10
+ andalso CharVector.all Char.isAlpha name
+
+fun groupNameToId name =
+ case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebGroup WHERE name = ^(C.stringToSql name)`) of
+ SOME [id] => SOME (C.intFromSql id)
+ | _ => NONE
+
+end
\ No newline at end of file
--- /dev/null
+<% Group.requireGroupNum 0;
+
+@header [("title", ["Group management"])];
+
+ref showNormal = true;
+
+if $"cmd" = "Create" then
+ if not (Group.validGroupName ($"name")) then %>
+ <h3><b>Invalid group name</b></h3>
+ <% else switch Group.groupNameToId ($"name") of
+ SOME _ => %>
+ <h3><b>Group name already in use</b></h3>
+<% | NONE =>
+ val id = Group.addGroup ($"name") %>
+ <h3><b>Group added</b></h3>
+<% end
+ end
+elseif $"mod" <> "" then
+ showNormal := false;
+ val group = Group.lookupGroup (Web.stoi ($"mod")) %>
+<h3><b>Modify group record</b></h3>
+
+<form action="groups">
+<input type="hidden" name="id" value="<% $"mod" %>">
+<table>
+<tr> <td align="right"><b>Name</b>:</td> <td><input name="name" value="<% #name group %>"></td> </tr>
+<tr> <td><input type="submit" name="cmd" value="Save"></td> </tr>
+</table>
+</form>
+
+<% elseif $"cmd" = "Save" then
+ val group = Group.lookupGroup (Web.stoi ($"id"));
+ Group.modGroup {group with name = $"name"} %>
+ <h3><b>Group record saved.</b></h3>
+
+<% elseif $"del" <> "" then
+ showNormal := false;
+ val group = Group.lookupGroup (Web.stoi ($"del")) %>
+ <h3><b>Are you sure you want to delete group <% #name group %>?</b></h3>
+ <a href="groups?del2=<% $"del" %>">Yes, delete <% #name group %>!</a>
+
+<% elseif $"del2" <> "" then
+ val group = Group.lookupGroup (Web.stoi ($"del2"));
+ Group.deleteGroup (Web.stoi ($"del2")) %>
+ <h3><b><% #name group %> deleted!</b></h3>
+
+<% elseif $"cmd" = "Grant" then
+ Group.addToGroup {usr = Web.stoi ($"usr"), grp = Web.stoi ($"grp")} %>
+ <h3><b>Membership granted.</b></h3>
+
+<% elseif $"revoke" <> "" then
+ Group.removeFromGroup {usr = Web.stoi ($"revoke"), grp = Web.stoi ($"grp")} %>
+ <h3><b>Membership revoked.</b></h3>
+
+<% end %>
+
+<% if showNormal then %>
+
+<h3><b>Create group</b></h3>
+
+<form action="groups">
+<table>
+<tr> <td align="right"><b>Name</b>:</td> <td><input name="name"></td> </tr>
+<tr> <td><input type="submit" name="cmd" value="Create"></td> </tr>
+</table>
+</form>
+
+<h3><b>Grant membership</b></h3>
+
+<form action="groups">
+<table>
+<tr> <td align="right"><b>Group</b>:</td> <td><select name="grp">
+<% foreach group in Group.listGroups () do %>
+ <option value="<% #id group %>"><% Web.html (#name group) %></option>
+<% end %>
+</select></td> </tr>
+<tr> <td align="right"><b>Member</b>:</td> <td><select name="usr">
+<% foreach user in Init.listUsers () do %>
+ <option value="<% #id user %>"><% Web.html (#name user) %></option>
+<% end %>
+</select></td> </tr>
+<tr> <td><input type="submit" name="cmd" value="Grant"></td> </tr>
+</table>
+</form>
+
+<h3><b>Manage current groups</b></h3>
+
+<table>
+<% foreach group in Group.listGroups () do %>
+ <tr> <td><% Web.html (#name group) %>(#<% #id group %>)</td> <td></td> <td><a href="groups?mod=<% #id group %>">[Modify]</a> <a href="groups?del=<% #id group %>">[Delete]</a></td> </tr>
+<% foreach user in Group.groupMembers (#id group) do %>
+ <tr> <td></td> <td><a href="user?id=<% #id user %>"><% Web.html (#name user) %></a></td> <td><a href="groups?revoke=<% #id user %>&grp=<% #id group %>">[Revoke]</a></td> </tr>
+<% end
+end %>
+</table>
+
+<% end %>
+
+<% @footer [] %>
\ No newline at end of file
--- /dev/null
+<html><head>
+<% val title =
+ case $"title" of
+ "" => "Hcoop Portal"
+ | t => ("Hcoop Portal: " ^ t) %>
+<title><% Web.html title %></title>
+</head><body>
+
+<% if Group.inGroupNum 0 then %>
+<p><b>Admin</b>: <a href="users">Members</a> | <a href="groups">Groups</a> | <a href="balances">Balances</a></p>
+<% end %>
+
+<h2><b><% Web.html title %></b></h2>
--- /dev/null
+signature INIT = sig
+ structure C : SQL_CLIENT
+
+ exception Access of string
+
+ type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp}
+
+ val mkUserRow : string list -> user
+
+ (* Open or close a session, wrapped in a transaction *)
+ val init : unit -> unit
+ val done : unit -> unit
+
+ val nextSeq : C.conn * string -> string
+
+ (* Fun with users *)
+
+ val lookupUser : int -> user
+ val listUsers : unit -> user list
+ val addUser : string * string * int -> int
+ (* Pass name, real name, and balance ID *)
+ val modUser : user -> unit
+ val deleteUser : int -> string
+
+ val validUsername : string -> bool
+ val userNameToId : string -> int option
+
+ val getDb : unit -> C.conn
+
+ val getUser : unit -> user
+ val getUserId : unit -> int
+ val getUserName : unit -> string
+end
\ No newline at end of file
--- /dev/null
+structure Init :> INIT =
+struct
+
+open Util Sql
+structure C = PgClient
+
+exception Access of string
+
+fun conn () = C.conn "dbname='hcoop'"
+val close = C.close
+
+type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp}
+
+val db = ref (NONE : C.conn option)
+val user = ref (NONE : user option)
+
+fun getDb () = valOf (!db)
+
+fun mkUserRow [id, name, rname, bal, joined] =
+ {id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname,
+ bal = C.intFromSql bal, joined = C.timestampFromSql joined}
+ | mkUserRow row = raise Fail ("Bad user row : " ^ makeSet id row)
+
+fun init () =
+ let
+ val c = conn ()
+ in
+ 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
+ FROM WebUser
+ WHERE name=^(C.stringToSql name)`) of
+ NONE => raise Fail "User not found"
+ | SOME r => user := SOME (mkUserRow r));
+ db := SOME c
+ end
+
+fun done () =
+ let
+ val db = getDb ()
+ in
+ C.dml db "COMMIT";
+ close db
+ end
+
+fun getUser () = valOf (!user)
+fun getUserId () = #id (getUser ())
+fun getUserName () = #name (getUser ())
+
+fun lookupUser id =
+ mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined
+ FROM WebUser
+ WHERE id = ^(C.intToSql id)`))
+
+fun listUsers () =
+ C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined
+ FROM WebUser
+ ORDER BY name`)
+
+fun nextSeq (db, seq) =
+ case C.oneRow db ($`SELECT nextval('^(seq)')`) of
+ [id] => id
+ | _ => raise Fail "Bad next sequence val"
+
+fun addUser (name, rname, bal) =
+ let
+ val db = getDb ()
+ val id = nextSeq (db, "WebUserSeq")
+ in
+ C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined)
+ VALUES (^id, ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal), CURRENT_TIMESTAMP)`);
+ C.intFromSql id
+ end
+
+fun modUser (user : user) =
+ let
+ val db = getDb ()
+ in
+ ignore (C.dml db ($`UPDATE WebUser SET
+ name = ^(C.stringToSql (#name user)), rname = ^(C.stringToSql (#rname user)),
+ bal = ^(C.intToSql (#bal user))
+ WHERE id = ^(C.intToSql (#id user))`))
+ end
+
+fun deleteUser id =
+ C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`)
+
+fun validUsername name =
+ size name <= 10
+ andalso CharVector.all Char.isAlpha name
+
+fun userNameToId name =
+ case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebUser WHERE name = ^(C.stringToSql name)`) of
+ SOME [id] => SOME (C.intFromSql id)
+ | _ => NONE
+
+end
\ No newline at end of file
--- /dev/null
+print real = Util.printReal
+print int = Util.printInt
+
+before before
+after after
+exn exn
+
+out /home/hcoop/public_html/src/hcoop/out
+pub /var/www/users.hcoop.net/cgi/hcoop
+
+cm /usr/local/share/smlsql/smlsql.cm
+cm /usr/local/share/smlsql/libpq/sources.cm
--- /dev/null
+<% @header [("title", ["MoneyMatters"])];
+
+ref showNormal = true;
+
+if $"cmd" = "list" then
+ showNormal := false %>
+
+<h3><b>Transactions</b></h3>
+
+<table>
+<tr> <td><b>Date</b></td> <td><b>Description</b></td> <td><b>Amount</b></td> <td><b>Last modified</b></td> <td><b>Participants</b></td> </tr>
+<% foreach trn in Money.listTransactions () do %>
+<tr> <td><% #d trn %></td> <td><a href="money?trn=<% #id trn %>"><% Web.html (#descr trn) %></a></td> <td><% #amount trn %></td> <td><% #stamp trn %></td>
+<% switch Money.listChargesWithNames (#id trn) of
+ [(name, cha)] => %><td><a href="user?id=<% #usr cha %>"><% name %></a></td> </tr><%
+ | _ => %><td><i>multi</i></td> </tr><%
+end
+end %>
+</table>
+
+<% elseif $"cmd" = "bals" then
+ showNormal := false %>
+
+<h3><b>Balances</b></h3>
+
+<table>
+<% foreach bal in Balance.listBalances () do %>
+<tr><td><% #name bal %></td> <td><% #amount bal %></td> <td>
+<% switch Balance.listBalanceUsers (#id bal) of
+ [] =>
+ | (user :: users) =>
+ %><a href="user?id=<% #id user %>"><% Web.html (#name user) %></a><%
+ foreach user in users do
+ %>, <a href="user?id=<% # id user %>"><% Web.html (#name user) %></a><%
+ end
+end %></td> </tr>
+<% end %>
+</table>
+
+<% elseif $"cmd" = "hosting" then
+ Group.requireGroupName "money";
+ showNormal := false %>
+
+<h3><b>New hosting bill</b></h3>
+
+<form action="money">
+<input type="hidden" name="cmd" value="hosting2">
+<table>
+<tr> <td align="right"><b>Description</b>:</td> <td><input name="descr"></td> </tr>
+<tr> <td align="right"><b>Date</b>:</td> <td><input name="d"></td> </tr>
+<tr> <td align="right"><b>Amount</b>:</td> <td><input name="amount"></td> </tr>
+<tr> <td align="right"><b>Free bandwidth cutoff (MB)</b>:</td> <td><input name="cutoff" value="200"></td> </tr>
+<tr> <td align="right"><b>Cost/GB</b>:</td> <td><input name="cost" value="4"></td> </tr>
+<tr> <td align="right" valign="top"><b>Member usage</b>:</td> <td><textarea wrap="soft" name="usage" rows="24" cols="80"></textarea></td> </tr>
+<tr> <td><input type="submit" value="Add"></td> </tr>
+</table>
+
+<% elseif $"cmd" = "hosting2" then
+ val id = Money.addTransaction ($"descr", Web.stor ($"amount"), $"d");
+ Money.addHostingCharges {trn = id, cutoff = 1000 * Web.stoi ($"cutoff"), cost = Web.stor ($"cost"), usage = $"usage"};
+
+ %><h3><b>Hosting transaction added.</b></h3>
+
+<% elseif $"cmd" = "evenForm" then
+ Group.requireGroupName "money";
+ showNormal := false %>
+<h3><b>New generic/even transaction</b></h3>
+<form action="money">
+<input type="hidden" name="cmd" value="even">
+<table>
+<tr> <td align="right"><b>Description</b>:</td> <td><input name="descr"></td> </tr>
+<tr> <td align="right"><b>Date</b>:</td> <td><input name="d"></td> </tr>
+<tr> <td align="right"><b>Amount</b>:</td> <td><input name="amount"></td> </tr>
+<tr> <td align="right" valign="top"><b>Members</b>:</td> <td><select name="usrs" size="5" multiple>
+<% foreach usr in Init.listUsers () do %>
+ <option value="<% #id usr %>"><% #name usr %></option>
+<% end %>
+</select></td> </tr>
+<tr> <td><input type="submit" value="Add"></td> </tr>
+</table>
+</form>
+
+<% elseif $"cmd" = "even" then
+ val id = Money.addTransaction ($"descr", Web.stor ($"amount"), $"d");
+ Money.addEvenCharges (id, map Web.stoi (Web.getMultiParam "usrs"))
+
+ %><h3><b>Even transaction added.</b></h3>
+
+<% elseif $"modEven" <> "" then
+ showNormal := false;
+ val trn = Money.lookupTransaction (Web.stoi ($"modEven")) %>
+<h3><b>Modify even transaction</b></h3>
+
+<form action="money">
+<input type="hidden" name="saveEven" value="<% $"modEven" %>">
+<table>
+<tr> <td align="right"><b>Description</b>:</td> <td><input name="descr" value="<% Web.html (#descr trn) %>"></td> </tr>
+<tr> <td align="right"><b>Date</b>:</td> <td><input name="d" value="<% Web.html (#d trn) %>"></td> </tr>
+<tr> <td align="right"><b>Amount</b>:</td> <td><input name="amount" value="<% #amount trn %>"></td> </tr>
+<tr> <td align="right" valign="top"><b>Members</b>:</td> <td><select name="usrs" size="5" multiple>
+<% foreach (sel, usr) in Money.listUsers (#id trn) do %>
+ <option value="<% #id usr %>"<% if sel then %> selected<% end %>><% #name usr %></option>
+<% end %>
+</select></td> </tr>
+<tr> <td><input type="submit" value="Save"></td> </tr>
+</table>
+</form>
+
+<% elseif $"saveEven" <> "" then
+ val id = Web.stoi ($"saveEven");
+ val trn = Money.lookupTransaction id;
+ Money.clearCharges id;
+ Money.modTransaction {trn with descr = $"descr", d = $"d", amount = Web.stor ($"amount")};
+ Money.addEvenCharges (id, map Web.stoi (Web.getMultiParam "usrs"))
+
+ %><h3><b>Even transaction modified</b></h3>
+
+<% elseif $"del" <> "" then
+ showNormal := false;
+ val trn = Money.lookupTransaction (Web.stoi ($"del")) %>
+ <h3><b>Are you sure you want to delete transaction <a href="money?trn=<% #id trn %>"><% Web.html (#descr trn) %></a>?</b></h3>
+ <a href="money?del2=<% $"del" %>">Yes, delete <% Web.html (#descr trn) %>!</a>
+
+<% elseif $"del2" <> "" then
+ val id = Web.stoi ($"del2");
+ val trn = Money.lookupTransaction id;
+ Money.clearCharges id;
+ Money.deleteTransaction id %>
+ <h3><b><% Web.html (#descr trn) %> deleted!</b></h3>
+
+<% elseif $"trn" <> "" then
+ showNormal := false;
+ val id = Web.stoi ($"trn");
+ val trn = Money.lookupTransaction id %>
+<table>
+<tr> <td align="right"><b>TRN#</b>:</td> <td><% id %></td> </tr>
+<tr> <td align="right"><b>Description</b>:</td> <td><% Web.html (#descr trn) %></td> </tr>
+<tr> <td align="right"><b>Date</b>:</td> <td><% #d trn %></td> </tr>
+<tr> <td align="right"><b>Amount</b>:</td> <td>$<% #amount trn %></td> </tr>
+<tr> <td align="right" valign="top"><b>Distribution</b>:</td>
+
+<% ref first = true;
+foreach (name, cha) in Money.listChargesWithNames id do
+ if first then
+ first := false
+ else
+ %><tr> <td></td> <%
+ end
+ %><td><a href="user?id=<% #usr cha %>"><% name %></a></td> <td>$<% #amount cha %></td> </tr><%
+end %>
+</table>
+
+<% end %>
+
+<% if showNormal then %>
+
+<a href="money?cmd=list">List all transactions</a><br>
+<a href="money?cmd=bals">List all balances</a><br>
+
+<% if Group.inGroupName "money" then %>
+
+<br><b><u>New transaction:</u></b><br>
+<a href="money?cmd=hosting">Hosting bill</a><br>
+<a href="money?cmd=evenForm">Generic/even</a><br>
+
+<h3><b>Most recent transactions</b></h3>
+
+<table>
+<tr> <td><b>Date</b></td> <td><b>Description</b></td> <td><b>Amount</b></td> <td><b>Participants</b></td> <td><b>Replace</b></td> <td><b>Delete</b></td> </tr>
+<% foreach trn in Money.listTransactionsLimit 20 do %>
+<tr> <td><% #d trn %></td> <td><a href="money?trn=<% #id trn %>"><% Web.html (#descr trn) %></a></td> <td><% #amount trn %></td>
+<% switch Money.listChargesWithNames (#id trn) of
+ [(name, cha)] => %><td><a href="user?id=<% #usr cha %>"><% name %></a></td><%
+ | _ => %><td><i>multi</i></td><%
+end %>
+<td><a href="money?modEven=<% #id trn %>">[Even]</a></td> <td><a href="money?del=<% #id trn %>">[Delete]</a></td> </tr>
+<% end %>
+</table>
+
+<% else %>
+
+<h3><b>Your recent account activity</b></h3>
+
+<table>
+<tr> <td><b>Date</b></td> <td><b>Description</b></td> <td><b>Amount</b></td> </tr>
+<% foreach (amount, trn) in Money.listUserTransactionsLimit (Init.getUserId (), 20) do %>
+<tr> <td><% #d trn %></td> <td><a href="money?trn=<% #id trn %>"><% Web.html (#descr trn) %></a></td> <td><% amount %>/<% #amount trn %></td> </tr>
+<% end %>
+</table>
+
+<% end
+end %>
+
+<% @footer [] %>
--- /dev/null
+signature MONEY =
+sig
+ type transaction = {id :int, descr : string, amount : real, d : string, stamp : Init.C.timestamp}
+
+ val addTransaction : string * real * string -> int
+ val lookupTransaction : int -> transaction
+ val modTransaction : transaction -> unit
+ val deleteTransaction : int -> unit
+ val listTransactions : unit -> transaction list
+ val listTransactionsLimit : int -> transaction list
+ val listUserTransactions : int -> (real * transaction) list
+ val listUserTransactionsLimit : int * int -> (real * transaction) list
+ (* Returns list of (your part, overall) pairs *)
+ val listUsers : int -> (bool * Init.user) list
+ (* List users and indicate whether they participated in a transaction *)
+
+ type charge = {trn : int, usr : int, amount : real}
+
+ val addCharge : charge -> unit
+ val listCharges : int -> charge list
+ val listChargesWithNames : int -> (string * charge) list
+
+ val clearCharges : int -> unit
+ val applyCharges : Init.C.conn -> int -> unit
+
+ val addEvenCharges : int * int list -> unit
+
+ type hosting = {trn : int, cutoff : int, cost : real, usage : string}
+ val addHostingCharges : hosting -> unit
+end
\ No newline at end of file
--- /dev/null
+structure Money :> MONEY =
+struct
+
+open Util Sql Init
+
+
+(* Managing transactions *)
+
+type transaction = {id :int, descr : string, amount : real, d : string, stamp : C.timestamp}
+
+fun mkTransactionRow [id, descr, amount, d, stamp] =
+ {id = C.intFromSql id, descr = C.stringFromSql descr, amount = C.realFromSql amount,
+ d = C.stringFromSql d, stamp = C.timestampFromSql stamp}
+ | mkTransactionRow row = raise Fail ("Bad transaction row : " ^ makeSet id row)
+
+fun addTransaction (descr, amount, d) =
+ let
+ val db = getDb ()
+ val id = nextSeq (db, "TransactionSeq")
+ in
+ C.dml db ($`INSERT INTO Transaction (id, descr, amount, d, stamp)
+ VALUES (^id, ^(C.stringToSql descr), ^(C.realToSql amount), ^(C.stringToSql d), CURRENT_TIMESTAMP)`);
+ C.intFromSql id
+ end
+
+fun lookupTransaction id =
+ let
+ val c = getDb ()
+ in
+ (case C.oneOrNoRows c ($`SELECT id, descr, amount, d, stamp FROM Transaction WHERE id = ^(C.intToSql id)`) of
+ NONE => raise Fail "Transaction not found"
+ | SOME r => mkTransactionRow r)
+ end
+
+fun modTransaction (trans : transaction) =
+ let
+ val db = getDb ()
+ in
+ ignore (C.dml db ($`UPDATE TRANSACTION
+ SET descr = ^(C.stringToSql (#descr trans)), amount = ^(C.realToSql (#amount trans)),
+ d = ^(C.stringToSql (#d trans)), stamp = CURRENT_TIMESTAMP
+ WHERE id = ^(C.intToSql (#id trans))`))
+ end
+
+fun deleteTransaction id =
+ ignore (C.dml (getDb ()) ($`DELETE FROM Transaction WHERE id = ^(C.intToSql id)`))
+
+fun listTransactions () =
+ C.map (getDb ()) mkTransactionRow ($`SELECT id, descr, amount, d, stamp FROM Transaction
+ ORDER BY d DESC`)
+
+fun listTransactionsLimit lim =
+ C.map (getDb ()) mkTransactionRow ($`SELECT id, descr, amount, d, stamp FROM Transaction
+ ORDER BY d DESC
+ LIMIT ^(C.intToSql lim)`)
+
+fun listUserTransactions usr =
+ let
+ val mkRow =
+ fn (amount :: row) => (C.realFromSql amount, mkTransactionRow row)
+ | _ => raise Fail "Bad charge+transaction row"
+ in
+ C.map (getDb ()) mkRow ($`SELECT C.amount, T.id, T.descr, T.amount, T.d, T.stamp FROM Transaction T, Charge C
+ WHERE id = trn
+ AND usr = ^(C.intToSql usr)
+ ORDER BY T.d DESC`)
+ end
+
+fun listUserTransactionsLimit (usr, lim) =
+ let
+ val mkRow =
+ fn (amount :: row) => (C.realFromSql amount, mkTransactionRow row)
+ | _ => raise Fail "Bad charge+transaction row"
+ in
+ C.map (getDb ()) mkRow ($`SELECT C.amount, T.id, T.descr, T.amount, T.d, T.stamp FROM Transaction T, Charge C
+ WHERE id = trn
+ AND usr = ^(C.intToSql usr)
+ ORDER BY T.d DESC
+ LIMIT ^(C.intToSql lim)`)
+ end
+
+val mkUserRow' =
+ fn (trn :: rest) =>
+ (if C.isNull trn then false else true,
+ mkUserRow rest)
+ | row => raise Fail ("Bad listUsers row: " ^ makeSet id row)
+
+fun listUsers trn =
+ C.map (getDb ()) mkUserRow' ($`SELECT trn, id, name, rname, bal, joined
+ FROM WebUser LEFT OUTER JOIN Charge ON usr = id AND trn = ^(C.intToSql trn)
+ ORDER BY name`)
+
+
+(* Managing charges *)
+
+type charge = {trn : int, usr : int, amount : real}
+
+fun mkChargeRow [trn, usr, amount] =
+ {trn = C.intFromSql trn, usr = C.intFromSql usr, amount = C.realFromSql amount}
+ | mkChargeRow row = raise Fail ("Bad charge row : " ^ makeSet id row)
+
+fun addCharge {trn, usr, amount} =
+ ignore (C.dml (getDb ()) ($`INSERT INTO Charge (trn, usr, amount)
+ VALUES (^(C.intToSql trn), ^(C.intToSql usr), ^(C.realToSql amount))`))
+
+fun listCharges trn =
+ C.map (getDb ()) mkChargeRow ($`SELECT trn, usr, amount FROM Charge
+ WHERE trn = ^(C.intToSql trn)`)
+
+val mkChargeRow' =
+ fn (name :: rest) => (C.stringFromSql name, mkChargeRow rest)
+ | row => raise Fail ("Bad name+charge row: " ^ makeSet id row)
+
+fun listChargesWithNames trn =
+ C.map (getDb ()) mkChargeRow' ($`SELECT name, trn, usr, amount FROM Charge, WebUser
+ WHERE trn = ^(C.intToSql trn)
+ AND usr = id
+ ORDER BY name`)
+
+
+(* Macro-operations *)
+
+fun clearCharges trn =
+ let
+ val db = getDb ()
+
+ fun clearCharge [bal, amount] =
+ ignore (C.dml db ($`UPDATE Balance
+ SET amount = amount - ^amount
+ WHERE id = ^bal`))
+ | clearCharge row = raise Fail ("Bad clearCharge row : " ^ makeSet id row)
+ in
+ C.app db clearCharge ($`SELECT bal, SUM(amount) FROM Charge, WebUser
+ WHERE trn = ^(C.intToSql trn)
+ AND usr = id
+ GROUP BY bal`);
+ ignore (C.dml db ($`DELETE FROM Charge WHERE trn = ^(C.intToSql trn)`))
+ end
+
+fun applyCharges db trn =
+ let
+ fun applyCharge [bal, amount] =
+ ignore (C.dml db ($`UPDATE Balance
+ SET amount = amount + ^amount
+ WHERE id = ^bal`))
+ | applyCharge row = raise Fail ("Bad applyCharge row : " ^ makeSet id row)
+ in
+ C.app db applyCharge ($`SELECT bal, SUM(amount) FROM Charge, WebUser
+ WHERE trn = ^(C.intToSql trn)
+ AND usr = id
+ GROUP BY bal`)
+ end
+
+fun addEvenCharges (trn, usrs) =
+ let
+ val tran = lookupTransaction trn
+ val nUsrs = length usrs
+
+ val split = #amount tran / (real nUsrs)
+
+ val db = getDb ()
+
+ fun addCharge usr =
+ ignore (C.dml db ($`INSERT INTO Charge (trn, usr, amount)
+ VALUES (^(C.intToSql trn), ^(C.intToSql usr), ^(C.realToSql split))`))
+ in
+ app addCharge usrs;
+ applyCharges db trn
+ end
+
+(* Automated hosting charges *)
+
+type hosting = {trn : int, cutoff : int, cost : real, usage : string}
+
+structure StringKey = struct
+ type ord_key = string
+ val compare = String.compare
+end
+
+structure SM = BinaryMapFn(StringKey)
+
+fun addHostingCharges {trn, cutoff, cost, usage} =
+ let
+ val tran = lookupTransaction trn
+
+ val paying =
+ case Group.groupNameToId "paying" of
+ NONE => raise Fail "No 'paying' group"
+ | SOME id => id
+
+ val nvs = String.tokens Char.isSpace usage
+
+ fun walkNvs (nvs, umap, amount) =
+ case nvs of
+ name :: bw :: rest =>
+ let
+ val bw = Web.stoi bw
+ in
+ if bw > cutoff then
+ let
+ val extra = cost * (real (bw - cutoff) / 1000000.0)
+ in
+ walkNvs (rest,
+ SM.insert (umap, name, extra),
+ amount - extra)
+ end
+ else
+ walkNvs (rest, umap, amount)
+ end
+ | _ => (umap, amount)
+
+ val (umap, amount) = walkNvs (nvs, SM.empty, #amount tran)
+
+ val payers = Group.groupMembers paying
+ val even = amount / real (length payers)
+
+ fun doUser (usr : Init.user, umap) =
+ let
+ val (charge, umap) =
+ case SM.find (umap, #name usr) of
+ NONE => (even, umap)
+ | SOME extra => (even + extra, #1 (SM.remove (umap, #name usr)))
+ in
+ addCharge {trn = trn, usr = #id usr, amount = charge};
+ umap
+ end
+ in
+ if SM.numItems (foldl doUser umap payers) = 0 then
+ ()
+ else
+ raise Fail "Usage description contains an unknown username"
+ end
+end
\ No newline at end of file
--- /dev/null
+<% val you = Init.getUser ();
+
+@header [] %>
+
+<% @footer [] %>
\ No newline at end of file
--- /dev/null
+CREATE TABLE Balance(
+ id INTEGER PRIMARY KEY,
+ name TEXT NOT NULL,
+ amount REAL NOT NULL);
+
+CREATE SEQUENCE BalanceSeq START 1;
+
+INSERT INTO Balance
+ (id, name, amount) VALUES
+ (0, 'adam', 0.0);
+
+CREATE TABLE WebUser(
+ 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);
+
+CREATE SEQUENCE WebUserSeq START 1;
+
+INSERT INTO WebUser
+ (id, name, bal) VALUES
+ (0, 'adam', 0);
+
+CREATE TABLE WebGroup(
+ id INTEGER PRIMARY KEY,
+ name TEXT NOT NULL);
+
+CREATE SEQUENCE WebGroupSeq START 1;
+
+INSERT INTO WebGroup
+ (id, name) VALUES
+ (0, 'root');
+
+CREATE TABLE Membership(
+ grp INTEGER NOT NULL,
+ usr INTEGER NOT NULL,
+ PRIMARY KEY (grp, usr),
+ FOREIGN KEY (grp) REFERENCES WebGroup(id) ON DELETE CASCADE,
+ FOREIGN KEY (usr) REFERENCES WebUser(id) ON DELETE CASCADE);
+
+INSERT INTO Membership
+ (grp, usr) VALUES
+ (0, 0);
+
+CREATE TABLE Transaction(
+ id INTEGER PRIMARY KEY,
+ descr TEXT NOT NULL,
+ amount REAL NOT NULL,
+ d DATE NOT NULL,
+ stamp TIMESTAMP NOT NULL);
+
+CREATE SEQUENCE TransactionSeq START 1;
+
+CREATE TABLE Charge(
+ trn INTEGER NOT NULL,
+ usr INTEGER NOT NULL,
+ amount REAL NOT NULL,
+ PRIMARY KEY (trn, usr),
+ FOREIGN KEY (trn) REFERENCES Transaction(id) ON DELETE CASCADE,
+ FOREIGN KEY (usr) REFERENCES WebUser(id) ON DELETE CASCADE);
+
+
--- /dev/null
+<% Group.requireGroupNum 0;
+
+@header [("title", ["Member management"])];
+
+ref showNormal = true;
+
+if $"cmd" = "Create" then
+ if not (Init.validUsername ($"name")) then %>
+ <h3><b>Invalid username</b></h3>
+ <% else switch Init.userNameToId ($"name") of
+ SOME _ => %>
+ <h3><b>Username already in use</b></h3>
+<% | NONE =>
+ val bal =
+ (case $"bal" of
+ "" => Balance.addBalance ($"name")
+ | s => Web.stoi s);
+
+ val id = Init.addUser ($"name", $"rname", bal);
+ Group.addToGroups (id, map Web.stoi (Web.getMultiParam "grp")) %>
+ <h3><b>Member added</b></h3>
+<% end
+ end
+elseif $"mod" <> "" then
+ showNormal := false;
+ val user = Init.lookupUser (Web.stoi ($"mod")) %>
+<h3><b>Modify member record</b></h3>
+
+<form action="users">
+<input type="hidden" name="id" value="<% $"mod" %>">
+<table>
+<tr> <td align="right"><b>Name</b>:</td> <td><input name="name" value="<% #name user %>"></td> </tr>
+<tr> <td align="right"><b>Real name</b>:</td> <td><input name="rname" value="<% #rname user %>"></td> </tr>
+<tr> <td align="right" valign="top"><b>Funded by</b>:</td> <td><select name="bal">
+<% foreach bal in Balance.listBalances () do %>
+ <option value="<% #id bal %>"<% if #bal user = #id bal then %> selected <% end %>><% Web.html (#name bal) %></option>
+<% end %>
+</select></td></tr>
+<tr> <td><input type="submit" name="cmd" value="Save"></td> </tr>
+</table>
+</form>
+
+<% elseif $"cmd" = "Save" then
+ val user = Init.lookupUser (Web.stoi ($"id"));
+ Init.modUser {user with name = $"name", bal = Web.stoi ($"bal")} %>
+ <h3><b>Member record saved.</b></h3>
+
+<% elseif $"del" <> "" then
+ showNormal := false;
+ val user = Init.lookupUser (Web.stoi ($"del")) %>
+ <h3><b>Are you sure you want to delete member <a href="user?id=<% #id user %>"><% #name user %></a>?</b></h3>
+ <a href="users?del2=<% $"del" %>">Yes, delete <% #name user %>!</a>
+
+<% elseif $"del2" <> "" then
+ val user = Init.lookupUser (Web.stoi ($"del2"));
+ Init.deleteUser (Web.stoi ($"del2")) %>
+ <h3><b><% #name user %> deleted!</b></h3>
+
+<% end %>
+
+<% if showNormal then %>
+<h3><b>New member</b></h3>
+
+<form action="users">
+<table>
+<tr> <td align="right"><b>Name</b>:</td> <td><input name="name"></td> </tr>
+<tr> <td align="right"><b>Real name</b>:</td> <td><input name="rname"></td> </tr>
+<tr> <td align="right" valign="top"><b>Funded by</b>:</td> <td><select name="bal">
+ <option value="">A new balance</option>
+<% foreach bal in Balance.listBalances () do %>
+ <option value="<% #id bal %>"><% Web.html (#name bal) %></option>
+<% end %>
+</select></td></tr>
+<tr> <td align="right"><b>Groups</b>:</td> <td><select name="grp" size="5" multiple>
+<% foreach group in Group.listGroups () do %>
+ <option value="<% #id group %>"><% Web.html (#name group) %></option>
+<% end %>
+</select></td></tr>
+<tr> <td><input type="submit" name="cmd" value="Create"></td> </tr>
+</table>
+</form>
+
+<h3><b>Manage current members</b></h3>
+
+<table>
+<% foreach user in Init.listUsers () do %>
+ <tr> <td><a href="user?id=<% #id user %>"><% Web.html (#name user) %></a></td> <td>
+<% val bal = Balance.lookupBalance (#bal user);
+if #name bal <> #name user then %>
+<i><% Web.html (#name bal) %></i>
+<% end %>
+ </td><td><a href="users?mod=<% #id user %>">[Modify]</a> <a href="users?del=<% #id user %>">[Delete]</a></td> </tr>
+<% end %>
+</table>
+
+<% end %>
+
+<% @footer [] %>
\ No newline at end of file
--- /dev/null
+signature UTIL =
+sig
+ val printInt : int -> unit
+ val printReal : real -> unit
+
+ val id : 'a -> 'a
+ val makeSet : ('a -> string) -> 'a list -> string
+end
\ No newline at end of file
--- /dev/null
+structure Util :> UTIL =
+struct
+
+fun printInt n =
+ Web.print (if n < 0 then
+ "-" ^ Int.toString (~n)
+ else
+ Int.toString n)
+
+fun printReal n =
+ Web.print (if n < 0.0 then
+ "-" ^ Real.fmt (StringCvt.FIX (SOME 2)) (~n)
+ else
+ Real.fmt (StringCvt.FIX (SOME 2)) n)
+
+fun id x = x
+
+fun makeSet f items =
+ case items of
+ [] => "()"
+ | [usr] => "(" ^ f usr ^ ")"
+ | usr::rest => foldl (fn (usr, s) => s ^ ", " ^ f usr) ("(" ^ f usr) rest ^ ")"
+
+end
\ No newline at end of file
HCoop / hcoop / zz_old / portal.git / commitdiff