<% Web.html title %>

From: adamch Date: Thu, 14 Apr 2005 19:19:36 +0000 (+0000) Subject: Initial revision X-Git-Tag: working~1 X-Git-Url: http://git.hcoop.net/hcoop/zz_old/portal.git/commitdiff_plain/8d347a3306ce7cc6e744183f0d4229f09d3f7101 Initial revision --- 8d347a3306ce7cc6e744183f0d4229f09d3f7101 diff --git a/.cvsignore b/.cvsignore new file mode 100644 index 0000000..e25901e --- /dev/null +++ b/.cvsignore @@ -0,0 +1,3 @@ +out +.cm +CM diff --git a/after.mlt b/after.mlt new file mode 100644 index 0000000..a7fc86f --- /dev/null +++ b/after.mlt @@ -0,0 +1,3 @@ +<% Init.done () %> + + \ No newline at end of file diff --git a/balance.sig b/balance.sig new file mode 100644 index 0000000..9cd300a --- /dev/null +++ b/balance.sig @@ -0,0 +1,14 @@ +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 diff --git a/balance.sml b/balance.sml new file mode 100644 index 0000000..b2e905c --- /dev/null +++ b/balance.sml @@ -0,0 +1,65 @@ +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 diff --git a/balances.mlt b/balances.mlt new file mode 100644 index 0000000..d2c19c9 --- /dev/null +++ b/balances.mlt @@ -0,0 +1,69 @@ +<% Group.requireGroupNum 0; + +@header [("title", ["Balance management"])]; + +ref showNormal = true; + +if $"cmd" = "Create" then + if not (Balance.validBalanceName ($"name")) then %> +

Invalid balance name

+ <% else switch Balance.balanceNameToId ($"name") of + SOME _ => %> +

Balance name already in use

+<% | NONE => + val id = Balance.addBalance ($"name") %> +

Balance added

+<% end + end +elseif $"mod" <> "" then + showNormal := false; + val balance = Balance.lookupBalance (Web.stoi ($"mod")) %> +

Modify balance record

+ + + +<% elseif $"cmd" = "Save" then + val balance = Balance.lookupBalance (Web.stoi ($"id")); + Balance.modBalance {balance with name = $"name"} %> +

Balance record saved.

+ +<% elseif $"del" <> "" then + showNormal := false; + val balance = Balance.lookupBalance (Web.stoi ($"del")) %> +

Are you sure you want to delete balance <% #name balance %>?

+ ">Yes, delete <% #name balance %>! + +<% elseif $"del2" <> "" then + val balance = Balance.lookupBalance (Web.stoi ($"del2")); + Balance.deleteBalance (Web.stoi ($"del2")) %> +

<% #name balance %> deleted!

+ +<% end %> + +<% if showNormal then %> +

New balance

+ + + +

Manage current balances

+ + +<% foreach balance in Balance.listBalances () do %> + +<% end %> +

<% Web.html (#name balance) %>

<% #amount balance %>

[Modify] [Delete]

+ +<% end %> + +<% @footer [] %> diff --git a/before.mlt b/before.mlt new file mode 100644 index 0000000..5bc0423 --- /dev/null +++ b/before.mlt @@ -0,0 +1,3 @@ +<% Init.init () %> + + \ No newline at end of file diff --git a/exn.mlt b/exn.mlt new file mode 100644 index 0000000..e645be1 --- /dev/null +++ b/exn.mlt @@ -0,0 +1,19 @@ +<% @header [("title", ["Exception"])] %> + +<% switch Web.getExn () of + Fail msg => %> +Fail: <% Web.htmlNl msg %> +<% | Init.C.Sql msg => %> +SQL: <% Web.htmlNl msg %> +<% | Init.Access msg => %> +Authorization error: <% Web.htmlNl msg %> +<% | Web.Format s => %> +Format: <% Web.htmlNl s %> +<% | ex => %> +Unknown exception kind. Backtrace: +<% foreach s in SMLofNJ.exnHistory ex do %> +

<% Web.html s %>

+<% end +end %> + +<% @footer [] %> diff --git a/footer.mlt b/footer.mlt new file mode 100644 index 0000000..8634a86 --- /dev/null +++ b/footer.mlt @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/group.sig b/group.sig new file mode 100644 index 0000000..d914acb --- /dev/null +++ b/group.sig @@ -0,0 +1,29 @@ +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 diff --git a/group.sml b/group.sml new file mode 100644 index 0000000..8bad77f --- /dev/null +++ b/group.sml @@ -0,0 +1,144 @@ +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 diff --git a/groups.mlt b/groups.mlt new file mode 100644 index 0000000..3941620 --- /dev/null +++ b/groups.mlt @@ -0,0 +1,99 @@ +<% Group.requireGroupNum 0; + +@header [("title", ["Group management"])]; + +ref showNormal = true; + +if $"cmd" = "Create" then + if not (Group.validGroupName ($"name")) then %> +

Invalid group name

+ <% else switch Group.groupNameToId ($"name") of + SOME _ => %> +

Group name already in use

+<% | NONE => + val id = Group.addGroup ($"name") %> +

Group added

+<% end + end +elseif $"mod" <> "" then + showNormal := false; + val group = Group.lookupGroup (Web.stoi ($"mod")) %> +

Modify group record

+ + + +<% elseif $"cmd" = "Save" then + val group = Group.lookupGroup (Web.stoi ($"id")); + Group.modGroup {group with name = $"name"} %> +

Group record saved.

+ +<% elseif $"del" <> "" then + showNormal := false; + val group = Group.lookupGroup (Web.stoi ($"del")) %> +

Are you sure you want to delete group <% #name group %>?

+ ">Yes, delete <% #name group %>! + +<% elseif $"del2" <> "" then + val group = Group.lookupGroup (Web.stoi ($"del2")); + Group.deleteGroup (Web.stoi ($"del2")) %> +

<% #name group %> deleted!

+ +<% elseif $"cmd" = "Grant" then + Group.addToGroup {usr = Web.stoi ($"usr"), grp = Web.stoi ($"grp")} %> +

Membership granted.

+ +<% elseif $"revoke" <> "" then + Group.removeFromGroup {usr = Web.stoi ($"revoke"), grp = Web.stoi ($"grp")} %> +

Membership revoked.

+ +<% end %> + +<% if showNormal then %> + +

Create group

+ + + +

Grant membership

+ + + +

Manage current groups

+ + +<% foreach group in Group.listGroups () do %> + +<% foreach user in Group.groupMembers (#id group) do %> + +<% end +end %> +

<% Web.html (#name group) %>(#<% #id group %>)		[Modify] [Delete]
	<% Web.html (#name user) %>	[Revoke]

+ +<% end %> + +<% @footer [] %> \ No newline at end of file diff --git a/header.mlt b/header.mlt new file mode 100644 index 0000000..68e3d67 --- /dev/null +++ b/header.mlt @@ -0,0 +1,13 @@ + +<% val title = + case $"title" of + "" => "Hcoop Portal" + | t => ("Hcoop Portal: " ^ t) %> +<% Web.html title %> + + +<% if Group.inGroupNum 0 then %> +

Admin: Members | Groups | Balances

+<% end %> + +

<% Web.html title %>

diff --git a/init.sig b/init.sig new file mode 100644 index 0000000..4746bf2 --- /dev/null +++ b/init.sig @@ -0,0 +1,33 @@ +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 diff --git a/init.sml b/init.sml new file mode 100644 index 0000000..390b9a8 --- /dev/null +++ b/init.sml @@ -0,0 +1,99 @@ +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 diff --git a/mlt.conf b/mlt.conf new file mode 100644 index 0000000..3540eff --- /dev/null +++ b/mlt.conf @@ -0,0 +1,12 @@ +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 diff --git a/money.mlt b/money.mlt new file mode 100644 index 0000000..e2bf406 --- /dev/null +++ b/money.mlt @@ -0,0 +1,194 @@ +<% @header [("title", ["MoneyMatters"])]; + +ref showNormal = true; + +if $"cmd" = "list" then + showNormal := false %> + +

Transactions

+ + + +<% foreach trn in Money.listTransactions () do %> + +<% switch Money.listChargesWithNames (#id trn) of + [(name, cha)] => %><% + | _ => %><% +end +end %> +

Date	Description	Amount	Last modified	Participants
<% #d trn %>	<% Web.html (#descr trn) %>	<% #amount trn %>	<% #stamp trn %>	<% name %>
multi

+ +<% elseif $"cmd" = "bals" then + showNormal := false %> + +

Balances

+ + +<% foreach bal in Balance.listBalances () do %> + +<% end %> +

<% #name bal %>

<% #amount bal %>

+<% switch Balance.listBalanceUsers (#id bal) of + [] => + | (user :: users) => + %><% Web.html (#name user) %><% + foreach user in users do + %>, <% Web.html (#name user) %><% + end +end %>

+ +<% elseif $"cmd" = "hosting" then + Group.requireGroupName "money"; + showNormal := false %> + +

New hosting bill

+ + + +<% elseif $"cmd" = "even" then + val id = Money.addTransaction ($"descr", Web.stor ($"amount"), $"d"); + Money.addEvenCharges (id, map Web.stoi (Web.getMultiParam "usrs")) + + %>

Even transaction added.

+ +<% elseif $"modEven" <> "" then + showNormal := false; + val trn = Money.lookupTransaction (Web.stoi ($"modEven")) %> +

Modify even transaction

+ + + +<% 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")) + + %>

Even transaction modified

+ +<% elseif $"del" <> "" then + showNormal := false; + val trn = Money.lookupTransaction (Web.stoi ($"del")) %> +

Are you sure you want to delete transaction <% Web.html (#descr trn) %>?

+ ">Yes, delete <% Web.html (#descr trn) %>! + +<% elseif $"del2" <> "" then + val id = Web.stoi ($"del2"); + val trn = Money.lookupTransaction id; + Money.clearCharges id; + Money.deleteTransaction id %> +

<% Web.html (#descr trn) %> deleted!

+ +<% elseif $"trn" <> "" then + showNormal := false; + val id = Web.stoi ($"trn"); + val trn = Money.lookupTransaction id %> + + + + + + + +<% ref first = true; +foreach (name, cha) in Money.listChargesWithNames id do + if first then + first := false + else + %> <% + end + %><% +end %> +

TRN#:	<% id %>
Description:	<% Web.html (#descr trn) %>
Date:	<% #d trn %>
Amount:	$<% #amount trn %>
Distribution:
	<% name %>	$<% #amount cha %>

+ +<% end %> + +<% if showNormal then %> + +List all transactions
+List all balances
+ +<% if Group.inGroupName "money" then %> + +
New transaction:
+Hosting bill
+Generic/even
+ +

Most recent transactions

+ + + +<% foreach trn in Money.listTransactionsLimit 20 do %> + +<% switch Money.listChargesWithNames (#id trn) of + [(name, cha)] => %><% + | _ => %><% +end %> + +<% end %> +

Date	Description	Amount	Participants	Replace	Delete
<% #d trn %>	<% Web.html (#descr trn) %>	<% #amount trn %>	<% name %>	multi	[Even]	[Delete]

+ +<% else %> + +

Your recent account activity

+ + + +<% foreach (amount, trn) in Money.listUserTransactionsLimit (Init.getUserId (), 20) do %> + +<% end %> +

Date	Description	Amount
<% #d trn %>	<% Web.html (#descr trn) %>	<% amount %>/<% #amount trn %>

+ +<% end +end %> + +<% @footer [] %> diff --git a/money.sig b/money.sig new file mode 100644 index 0000000..e35df38 --- /dev/null +++ b/money.sig @@ -0,0 +1,30 @@ +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 diff --git a/money.sml b/money.sml new file mode 100644 index 0000000..133e37b --- /dev/null +++ b/money.sml @@ -0,0 +1,233 @@ +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 diff --git a/portal.mlt b/portal.mlt new file mode 100644 index 0000000..03be2b2 --- /dev/null +++ b/portal.mlt @@ -0,0 +1,5 @@ +<% val you = Init.getUser (); + +@header [] %> + +<% @footer [] %> \ No newline at end of file diff --git a/tables.sql b/tables.sql new file mode 100644 index 0000000..3105801 --- /dev/null +++ b/tables.sql @@ -0,0 +1,64 @@ +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); + + diff --git a/users.mlt b/users.mlt new file mode 100644 index 0000000..6dc4ce8 --- /dev/null +++ b/users.mlt @@ -0,0 +1,98 @@ +<% Group.requireGroupNum 0; + +@header [("title", ["Member management"])]; + +ref showNormal = true; + +if $"cmd" = "Create" then + if not (Init.validUsername ($"name")) then %> +

Invalid username

+ <% else switch Init.userNameToId ($"name") of + SOME _ => %> +

Username already in use

+<% | 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")) %> +

Member added

+<% end + end +elseif $"mod" <> "" then + showNormal := false; + val user = Init.lookupUser (Web.stoi ($"mod")) %> +

Modify member record

+ + + +<% elseif $"cmd" = "Save" then + val user = Init.lookupUser (Web.stoi ($"id")); + Init.modUser {user with name = $"name", bal = Web.stoi ($"bal")} %> +

Member record saved.

+ +<% elseif $"del" <> "" then + showNormal := false; + val user = Init.lookupUser (Web.stoi ($"del")) %> +

Are you sure you want to delete member <% #name user %>?

+ ">Yes, delete <% #name user %>! + +<% elseif $"del2" <> "" then + val user = Init.lookupUser (Web.stoi ($"del2")); + Init.deleteUser (Web.stoi ($"del2")) %> +

<% #name user %> deleted!

+ +<% end %> + +<% if showNormal then %> +

New member

+ + + +

Manage current members

+ + +<% foreach user in Init.listUsers () do %> + +<% end %> +

<% Web.html (#name user) %>

+<% val bal = Balance.lookupBalance (#bal user); +if #name bal <> #name user then %> +<% Web.html (#name bal) %> +<% end %> +

[Modify] [Delete]

+ +<% end %> + +<% @footer [] %> \ No newline at end of file diff --git a/util.sig b/util.sig new file mode 100644 index 0000000..3a03953 --- /dev/null +++ b/util.sig @@ -0,0 +1,8 @@ +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 diff --git a/util.sml b/util.sml new file mode 100644 index 0000000..6f067ac --- /dev/null +++ b/util.sml @@ -0,0 +1,24 @@ +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

Name:
Real name:
Funded by:
Groups:

Group:
Member:

Description:
Date:
Amount:
Free bandwidth cutoff (MB):
Cost/GB:
Member usage:

Invalid balance name

Balance name already in use

Balance added

Modify balance record

Balance record saved.

Are you sure you want to delete balance <% #name balance %>?

<% #name balance %> deleted!

New balance

Manage current balances

Invalid group name

Group name already in use

Group added

Modify group record

Group record saved.

Are you sure you want to delete group <% #name group %>?

<% #name group %> deleted!

Membership granted.

Membership revoked.

Create group

Grant membership

Manage current groups

<% Web.html title %>

Transactions

Balances

New hosting bill

Hosting transaction added.

New generic/even transaction

Even transaction added.

Modify even transaction

Even transaction modified

Are you sure you want to delete transaction <% Web.html (#descr trn) %>?

<% Web.html (#descr trn) %> deleted!

Most recent transactions

Your recent account activity

Invalid username

Username already in use

Member added

Modify member record

Member record saved.

Are you sure you want to delete member <% #name user %>?

<% #name user %> deleted!

New member

Manage current members