8d347a33 |
1 | structure Money :> MONEY = |
2 | struct |
3 | |
4 | open Util Sql Init |
5 | |
6 | |
7 | (* Managing transactions *) |
8 | |
9 | type transaction = {id :int, descr : string, amount : real, d : string, stamp : C.timestamp} |
10 | |
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} |
369e1577 |
14 | | mkTransactionRow row = Init.rowError ("transaction", row) |
8d347a33 |
15 | |
16 | fun addTransaction (descr, amount, d) = |
17 | let |
18 | val db = getDb () |
19 | val id = nextSeq (db, "TransactionSeq") |
20 | in |
21 | C.dml db ($`INSERT INTO Transaction (id, descr, amount, d, stamp) |
369e1577 |
22 | VALUES (^(C.intToSql id), ^(C.stringToSql descr), ^(C.realToSql amount), ^(C.stringToSql d), CURRENT_TIMESTAMP)`); |
23 | id |
8d347a33 |
24 | end |
25 | |
26 | fun lookupTransaction id = |
27 | let |
28 | val c = getDb () |
29 | in |
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) |
33 | end |
34 | |
35 | fun modTransaction (trans : transaction) = |
36 | let |
37 | val db = getDb () |
38 | in |
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))`)) |
43 | end |
44 | |
45 | fun deleteTransaction id = |
46 | ignore (C.dml (getDb ()) ($`DELETE FROM Transaction WHERE id = ^(C.intToSql id)`)) |
47 | |
48 | fun listTransactions () = |
49 | C.map (getDb ()) mkTransactionRow ($`SELECT id, descr, amount, d, stamp FROM Transaction |
50 | ORDER BY d DESC`) |
51 | |
52 | fun listTransactionsLimit lim = |
53 | C.map (getDb ()) mkTransactionRow ($`SELECT id, descr, amount, d, stamp FROM Transaction |
54 | ORDER BY d DESC |
55 | LIMIT ^(C.intToSql lim)`) |
56 | |
57 | fun listUserTransactions usr = |
58 | let |
59 | val mkRow = |
60 | fn (amount :: row) => (C.realFromSql amount, mkTransactionRow row) |
61 | | _ => raise Fail "Bad charge+transaction row" |
62 | in |
63 | C.map (getDb ()) mkRow ($`SELECT C.amount, T.id, T.descr, T.amount, T.d, T.stamp FROM Transaction T, Charge C |
64 | WHERE id = trn |
65 | AND usr = ^(C.intToSql usr) |
66 | ORDER BY T.d DESC`) |
67 | end |
68 | |
69 | fun listUserTransactionsLimit (usr, lim) = |
70 | let |
71 | val mkRow = |
72 | fn (amount :: row) => (C.realFromSql amount, mkTransactionRow row) |
73 | | _ => raise Fail "Bad charge+transaction row" |
74 | in |
75 | C.map (getDb ()) mkRow ($`SELECT C.amount, T.id, T.descr, T.amount, T.d, T.stamp FROM Transaction T, Charge C |
76 | WHERE id = trn |
77 | AND usr = ^(C.intToSql usr) |
78 | ORDER BY T.d DESC |
79 | LIMIT ^(C.intToSql lim)`) |
80 | end |
81 | |
82 | val mkUserRow' = |
83 | fn (trn :: rest) => |
84 | (if C.isNull trn then false else true, |
85 | mkUserRow rest) |
369e1577 |
86 | | row => Init.rowError ("listUsers", row) |
8d347a33 |
87 | |
88 | fun listUsers trn = |
ca988110 |
89 | C.map (getDb ()) mkUserRow' ($`SELECT trn, id, name, rname, bal, joined, app |
8d347a33 |
90 | FROM WebUser LEFT OUTER JOIN Charge ON usr = id AND trn = ^(C.intToSql trn) |
91 | ORDER BY name`) |
92 | |
93 | |
94 | (* Managing charges *) |
95 | |
96 | type charge = {trn : int, usr : int, amount : real} |
97 | |
98 | fun mkChargeRow [trn, usr, amount] = |
99 | {trn = C.intFromSql trn, usr = C.intFromSql usr, amount = C.realFromSql amount} |
369e1577 |
100 | | mkChargeRow row = Init.rowError ("charge", row) |
8d347a33 |
101 | |
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))`)) |
105 | |
106 | fun listCharges trn = |
107 | C.map (getDb ()) mkChargeRow ($`SELECT trn, usr, amount FROM Charge |
108 | WHERE trn = ^(C.intToSql trn)`) |
109 | |
110 | val mkChargeRow' = |
111 | fn (name :: rest) => (C.stringFromSql name, mkChargeRow rest) |
369e1577 |
112 | | row => Init.rowError ("name+charge", row) |
8d347a33 |
113 | |
114 | fun listChargesWithNames trn = |
d0dd06fa |
115 | C.map (getDb ()) mkChargeRow' ($`SELECT name, trn, usr, amount FROM Charge, WebUser |
8d347a33 |
116 | WHERE trn = ^(C.intToSql trn) |
117 | AND usr = id |
118 | ORDER BY name`) |
119 | |
120 | |
121 | (* Macro-operations *) |
122 | |
123 | fun clearCharges trn = |
124 | let |
125 | val db = getDb () |
126 | |
127 | fun clearCharge [bal, amount] = |
128 | ignore (C.dml db ($`UPDATE Balance |
369e1577 |
129 | SET amount = amount - ^(C.stringFromSql amount) |
130 | WHERE id = ^(C.stringFromSql bal)`)) |
131 | | clearCharge row = Init.rowError ("clearCharge", row) |
8d347a33 |
132 | in |
133 | C.app db clearCharge ($`SELECT bal, SUM(amount) FROM Charge, WebUser |
134 | WHERE trn = ^(C.intToSql trn) |
135 | AND usr = id |
136 | GROUP BY bal`); |
137 | ignore (C.dml db ($`DELETE FROM Charge WHERE trn = ^(C.intToSql trn)`)) |
138 | end |
139 | |
f1ea3762 |
140 | fun applyCharges trn = |
8d347a33 |
141 | let |
f1ea3762 |
142 | val db = getDb () |
143 | |
8d347a33 |
144 | fun applyCharge [bal, amount] = |
145 | ignore (C.dml db ($`UPDATE Balance |
369e1577 |
146 | SET amount = amount + ^(C.stringFromSql amount) |
147 | WHERE id = ^(C.stringFromSql bal)`)) |
148 | | applyCharge row = Init.rowError ("applyCharge", row) |
8d347a33 |
149 | in |
150 | C.app db applyCharge ($`SELECT bal, SUM(amount) FROM Charge, WebUser |
151 | WHERE trn = ^(C.intToSql trn) |
152 | AND usr = id |
153 | GROUP BY bal`) |
154 | end |
155 | |
156 | fun addEvenCharges (trn, usrs) = |
157 | let |
158 | val tran = lookupTransaction trn |
159 | val nUsrs = length usrs |
160 | |
161 | val split = #amount tran / (real nUsrs) |
162 | |
163 | val db = getDb () |
164 | |
165 | fun addCharge usr = |
166 | ignore (C.dml db ($`INSERT INTO Charge (trn, usr, amount) |
167 | VALUES (^(C.intToSql trn), ^(C.intToSql usr), ^(C.realToSql split))`)) |
168 | in |
169 | app addCharge usrs; |
f1ea3762 |
170 | applyCharges trn |
8d347a33 |
171 | end |
172 | |
173 | (* Automated hosting charges *) |
174 | |
175 | type hosting = {trn : int, cutoff : int, cost : real, usage : string} |
176 | |
177 | structure StringKey = struct |
178 | type ord_key = string |
179 | val compare = String.compare |
180 | end |
181 | |
182 | structure SM = BinaryMapFn(StringKey) |
183 | |
184 | fun addHostingCharges {trn, cutoff, cost, usage} = |
185 | let |
186 | val tran = lookupTransaction trn |
187 | |
188 | val paying = |
189 | case Group.groupNameToId "paying" of |
190 | NONE => raise Fail "No 'paying' group" |
191 | | SOME id => id |
192 | |
193 | val nvs = String.tokens Char.isSpace usage |
194 | |
195 | fun walkNvs (nvs, umap, amount) = |
196 | case nvs of |
197 | name :: bw :: rest => |
198 | let |
199 | val bw = Web.stoi bw |
200 | in |
201 | if bw > cutoff then |
202 | let |
203 | val extra = cost * (real (bw - cutoff) / 1000000.0) |
204 | in |
205 | walkNvs (rest, |
206 | SM.insert (umap, name, extra), |
f9d08b8c |
207 | amount + extra) |
8d347a33 |
208 | end |
209 | else |
210 | walkNvs (rest, umap, amount) |
211 | end |
212 | | _ => (umap, amount) |
213 | |
214 | val (umap, amount) = walkNvs (nvs, SM.empty, #amount tran) |
215 | |
216 | val payers = Group.groupMembers paying |
217 | val even = amount / real (length payers) |
218 | |
219 | fun doUser (usr : Init.user, umap) = |
220 | let |
221 | val (charge, umap) = |
222 | case SM.find (umap, #name usr) of |
223 | NONE => (even, umap) |
f9d08b8c |
224 | | SOME extra => (even - extra, #1 (SM.remove (umap, #name usr))) |
8d347a33 |
225 | in |
226 | addCharge {trn = trn, usr = #id usr, amount = charge}; |
227 | umap |
228 | end |
31b85852 |
229 | |
230 | val _ = if SM.numItems (foldl doUser umap payers) = 0 then |
231 | applyCharges trn |
232 | else |
233 | raise Fail "Usage description contains an unknown username" |
234 | |
235 | val usageFile = TextIO.openOut (Init.scratchDir ^ "/usage/" ^ Int.toString trn) |
8d347a33 |
236 | in |
31b85852 |
237 | TextIO.output (usageFile, usage); |
238 | TextIO.closeOut usageFile |
8d347a33 |
239 | end |
f9d08b8c |
240 | |
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)`)) |
243 | |
31b85852 |
244 | fun lookupHostingUsage trn = |
245 | let |
246 | val usageFile = TextIO.openIn (Init.scratchDir ^ "/usage/" ^ Int.toString trn) |
247 | |
248 | fun loop acc = |
249 | case TextIO.inputLine usageFile of |
250 | NONE => String.concat (List.rev acc) |
251 | | SOME line => loop (line :: acc) |
252 | in |
253 | SOME (loop []) |
254 | before TextIO.closeIn usageFile |
255 | end handle _ => NONE |
256 | |
892e3ea1 |
257 | fun costBase amt = |
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) |
261 | |
31b85852 |
262 | end |