<% Web.html title %>

From 8d347a3306ce7cc6e744183f0d4229f09d3f7101 Mon Sep 17 00:00:00 2001 From: adamch Date: Thu, 14 Apr 2005 19:19:36 +0000 Subject: [PATCH] Initial revision --- .cvsignore | 3 + after.mlt | 3 + balance.sig | 14 ++++ balance.sml | 65 ++++++++++++++ balances.mlt | 69 +++++++++++++++ before.mlt | 3 + exn.mlt | 19 +++++ footer.mlt | 1 + group.sig | 29 +++++++ group.sml | 144 +++++++++++++++++++++++++++++++ groups.mlt | 99 ++++++++++++++++++++++ header.mlt | 13 +++ init.sig | 33 ++++++++ init.sml | 99 ++++++++++++++++++++++ mlt.conf | 12 +++ money.mlt | 194 ++++++++++++++++++++++++++++++++++++++++++ money.sig | 30 +++++++ money.sml | 233 +++++++++++++++++++++++++++++++++++++++++++++++++++ portal.mlt | 5 ++ tables.sql | 64 ++++++++++++++ users.mlt | 98 ++++++++++++++++++++++ util.sig | 8 ++ util.sml | 24 ++++++ 23 files changed, 1262 insertions(+) create mode 100644 .cvsignore create mode 100644 after.mlt create mode 100644 balance.sig create mode 100644 balance.sml create mode 100644 balances.mlt create mode 100644 before.mlt create mode 100644 exn.mlt create mode 100644 footer.mlt create mode 100644 group.sig create mode 100644 group.sml create mode 100644 groups.mlt create mode 100644 header.mlt create mode 100644 init.sig create mode 100644 init.sml create mode 100644 mlt.conf create mode 100644 money.mlt create mode 100644 money.sig create mode 100644 money.sml create mode 100644 portal.mlt create mode 100644 tables.sql create mode 100644 users.mlt create mode 100644 util.sig create mode 100644 util.sml 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 -- 2.20.1

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