1 structure Money :> MONEY =
7 (* Managing transactions *)
9 type transaction = {id :int, descr : string, amount : real, d : string, stamp : C.timestamp}
11 fun mkTransactionRow [id, descr, amount, d, stamp] =
12 {id = C.intFromSql id, descr = C.stringFromSql descr, amount = C.realFromSql amount,
13 d = C.stringFromSql d, stamp = C.timestampFromSql stamp}
14 | mkTransactionRow row = Init.rowError ("transaction", row)
16 fun addTransaction (descr, amount, d) =
19 val id = nextSeq (db, "TransactionSeq")
21 C.dml db ($`INSERT INTO Transaction (id, descr, amount, d, stamp)
22 VALUES (^(C.intToSql id), ^(C.stringToSql descr), ^(C.realToSql amount), ^(C.stringToSql d), CURRENT_TIMESTAMP)`);
26 fun lookupTransaction id =
30 (case C.oneOrNoRows c ($`SELECT id, descr, amount, d, stamp FROM Transaction WHERE id = ^(C.intToSql id)`) of
31 NONE => raise Fail "Transaction not found"
32 | SOME r => mkTransactionRow r)
35 fun modTransaction (trans : transaction) =
39 ignore (C.dml db ($`UPDATE TRANSACTION
40 SET descr = ^(C.stringToSql (#descr trans)), amount = ^(C.realToSql (#amount trans)),
41 d = ^(C.stringToSql (#d trans)), stamp = CURRENT_TIMESTAMP
42 WHERE id = ^(C.intToSql (#id trans))`))
45 fun deleteTransaction id =
46 ignore (C.dml (getDb ()) ($`DELETE FROM Transaction WHERE id = ^(C.intToSql id)`))
48 fun listTransactions () =
49 C.map (getDb ()) mkTransactionRow ($`SELECT id, descr, amount, d, stamp FROM Transaction
52 fun listTransactionsLimit lim =
53 C.map (getDb ()) mkTransactionRow ($`SELECT id, descr, amount, d, stamp FROM Transaction
55 LIMIT ^(C.intToSql lim)`)
57 fun listUserTransactions usr =
60 fn (amount :: row) => (C.realFromSql amount, mkTransactionRow row)
61 | _ => raise Fail "Bad charge+transaction row"
63 C.map (getDb ()) mkRow ($`SELECT C.amount, T.id, T.descr, T.amount, T.d, T.stamp FROM Transaction T, Charge C
65 AND usr = ^(C.intToSql usr)
69 fun listUserTransactionsLimit (usr, lim) =
72 fn (amount :: row) => (C.realFromSql amount, mkTransactionRow row)
73 | _ => raise Fail "Bad charge+transaction row"
75 C.map (getDb ()) mkRow ($`SELECT C.amount, T.id, T.descr, T.amount, T.d, T.stamp FROM Transaction T, Charge C
77 AND usr = ^(C.intToSql usr)
79 LIMIT ^(C.intToSql lim)`)
84 (if C.isNull trn then false else true,
86 | row => Init.rowError ("listUsers", row)
89 C.map (getDb ()) mkUserRow' ($`SELECT trn, id, name, rname, bal, joined, app
90 FROM WebUser LEFT OUTER JOIN Charge ON usr = id AND trn = ^(C.intToSql trn)
94 (* Managing charges *)
96 type charge = {trn : int, usr : int, amount : real}
98 fun mkChargeRow [trn, usr, amount] =
99 {trn = C.intFromSql trn, usr = C.intFromSql usr, amount = C.realFromSql amount}
100 | mkChargeRow row = Init.rowError ("charge", row)
102 fun addCharge {trn, usr, amount} =
103 ignore (C.dml (getDb ()) ($`INSERT INTO Charge (trn, usr, amount)
104 VALUES (^(C.intToSql trn), ^(C.intToSql usr), ^(C.realToSql amount))`))
106 fun listCharges trn =
107 C.map (getDb ()) mkChargeRow ($`SELECT trn, usr, amount FROM Charge
108 WHERE trn = ^(C.intToSql trn)`)
111 fn (name :: rest) => (C.stringFromSql name, mkChargeRow rest)
112 | row => Init.rowError ("name+charge", row)
114 fun listChargesWithNames trn =
115 C.map (getDb ()) mkChargeRow' ($`SELECT name, trn, usr, amount FROM Charge, WebUser
116 WHERE trn = ^(C.intToSql trn)
121 (* Macro-operations *)
123 fun clearCharges trn =
127 fun clearCharge [bal, amount] =
128 ignore (C.dml db ($`UPDATE Balance
129 SET amount = amount - ^(C.stringFromSql amount)
130 WHERE id = ^(C.stringFromSql bal)`))
131 | clearCharge row = Init.rowError ("clearCharge", row)
133 C.app db clearCharge ($`SELECT bal, SUM(amount) FROM Charge, WebUser
134 WHERE trn = ^(C.intToSql trn)
137 ignore (C.dml db ($`DELETE FROM Charge WHERE trn = ^(C.intToSql trn)`))
140 fun applyCharges trn =
144 fun applyCharge [bal, amount] =
145 ignore (C.dml db ($`UPDATE Balance
146 SET amount = amount + ^(C.stringFromSql amount)
147 WHERE id = ^(C.stringFromSql bal)`))
148 | applyCharge row = Init.rowError ("applyCharge", row)
150 C.app db applyCharge ($`SELECT bal, SUM(amount) FROM Charge, WebUser
151 WHERE trn = ^(C.intToSql trn)
156 fun addEvenCharges (trn, usrs) =
158 val tran = lookupTransaction trn
159 val nUsrs = length usrs
161 val split = #amount tran / (real nUsrs)
166 ignore (C.dml db ($`INSERT INTO Charge (trn, usr, amount)
167 VALUES (^(C.intToSql trn), ^(C.intToSql usr), ^(C.realToSql split))`))
173 (* Automated hosting charges *)
175 type hosting = {trn : int, cutoff : int, cost : real, usage : string}
177 structure StringKey = struct
178 type ord_key = string
179 val compare = String.compare
182 structure SM = BinaryMapFn(StringKey)
184 fun addHostingCharges {trn, cutoff, cost, usage} =
186 val tran = lookupTransaction trn
189 case Group.groupNameToId "paying" of
190 NONE => raise Fail "No 'paying' group"
193 val nvs = String.tokens Char.isSpace usage
195 fun walkNvs (nvs, umap, amount) =
197 name :: bw :: rest =>
203 val extra = cost * (real (bw - cutoff) / 1000000.0)
206 SM.insert (umap, name, extra),
210 walkNvs (rest, umap, amount)
212 | _ => (umap, amount)
214 val (umap, amount) = walkNvs (nvs, SM.empty, #amount tran)
216 val payers = Group.groupMembers paying
217 val even = amount / real (length payers)
219 fun doUser (usr : Init.user, umap) =
222 case SM.find (umap, #name usr) of
224 | SOME extra => (even - extra, #1 (SM.remove (umap, #name usr)))
226 addCharge {trn = trn, usr = #id usr, amount = charge};
230 val _ = if SM.numItems (foldl doUser umap payers) = 0 then
233 raise Fail "Usage description contains an unknown username"
235 val usageFile = TextIO.openOut (Init.scratchDir ^ "/usage/" ^ Int.toString trn)
237 TextIO.output (usageFile, usage);
238 TextIO.closeOut usageFile
241 fun equalizeBalances () =
242 ignore (C.dml (getDb ()) ($`UPDATE Balance SET amount = (SELECT SUM(amount) FROM Charge JOIN WebUser ON usr = WebUser.id WHERE bal = Balance.id)`))
244 fun lookupHostingUsage trn =
246 val usageFile = TextIO.openIn (Init.scratchDir ^ "/usage/" ^ Int.toString trn)
249 case TextIO.inputLine usageFile of
250 NONE => String.concat (List.rev acc)
251 | SOME line => loop (line :: acc)
254 before TextIO.closeIn usageFile
258 case C.oneRow (getDb ()) ($`SELECT ^(C.realToSql amt) / SUM(shares) FROM WebUserPaying`) of
259 [share] => C.realFromSql share
260 | row => Init.rowError ("Bad costBase result", row)