Commit | Line | Data |
---|---|---|
208e2cbc AC |
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} | |
ee587f7f | 14 | | mkTransactionRow row = Init.rowError ("transaction", row) |
208e2cbc AC |
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) | |
ee587f7f AC |
22 | VALUES (^(C.intToSql id), ^(C.stringToSql descr), ^(C.realToSql amount), ^(C.stringToSql d), CURRENT_TIMESTAMP)`); |
23 | id | |
208e2cbc AC |
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) | |
ee587f7f | 86 | | row => Init.rowError ("listUsers", row) |
208e2cbc AC |
87 | |
88 | fun listUsers trn = | |
89 | C.map (getDb ()) mkUserRow' ($`SELECT trn, id, name, rname, bal, joined | |
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} | |
ee587f7f | 100 | | mkChargeRow row = Init.rowError ("charge", row) |
208e2cbc AC |
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) | |
ee587f7f | 112 | | row => Init.rowError ("name+charge", row) |
208e2cbc AC |
113 | |
114 | fun listChargesWithNames trn = | |
115 | C.map (getDb ()) mkChargeRow' ($`SELECT name, trn, usr, amount FROM Charge, WebUser | |
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 | |
ee587f7f AC |
129 | SET amount = amount - ^(C.stringFromSql amount) |
130 | WHERE id = ^(C.stringFromSql bal)`)) | |
131 | | clearCharge row = Init.rowError ("clearCharge", row) | |
208e2cbc AC |
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 | ||
f49e1088 | 140 | fun applyCharges trn = |
208e2cbc | 141 | let |
f49e1088 AC |
142 | val db = getDb () |
143 | ||
208e2cbc AC |
144 | fun applyCharge [bal, amount] = |
145 | ignore (C.dml db ($`UPDATE Balance | |
ee587f7f AC |
146 | SET amount = amount + ^(C.stringFromSql amount) |
147 | WHERE id = ^(C.stringFromSql bal)`)) | |
148 | | applyCharge row = Init.rowError ("applyCharge", row) | |
208e2cbc AC |
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; | |
f49e1088 | 170 | applyCharges trn |
208e2cbc AC |
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), | |
207 | amount - extra) | |
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) | |
224 | | SOME extra => (even + extra, #1 (SM.remove (umap, #name usr))) | |
225 | in | |
226 | addCharge {trn = trn, usr = #id usr, amount = charge}; | |
227 | umap | |
228 | end | |
229 | in | |
230 | if SM.numItems (foldl doUser umap payers) = 0 then | |
231 | () | |
232 | else | |
233 | raise Fail "Usage description contains an unknown username" | |
234 | end | |
235 | end |