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
, shares
, paypal
, checkout
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
)
219 case C
.oneRow
db ($`SELECT
SUM(shares
)
220 FROM WebUser JOIN Membership ON usr
= WebUser
.id AND grp
= ^
(C
.intToSql paying
)`
) of
221 [n
] => C
.intFromSql n
222 | row
=> Init
.rowError ("Bad addHostingCharges share count result", row
)
224 val even
= amount
/ real shares
226 fun doUser ([uid
, uname
, shares
], umap
) =
228 val uid
= C
.intFromSql uid
229 val uname
= C
.stringFromSql uname
230 val shares
= C
.intFromSql shares
233 case SM
.find (umap
, uname
) of
234 NONE
=> (even
* real shares
, umap
)
235 | SOME extra
=> (even
* real shares
- extra
, #
1 (SM
.remove (umap
, uname
)))
237 addCharge
{trn
= trn
, usr
= uid
, amount
= charge
};
241 val _
= if SM
.numItems (C
.fold db doUser umap
242 ($`SELECT id
, name
, shares
243 FROM WebUser JOIN Membership ON usr
= WebUser
.id AND grp
= ^
(C
.intToSql paying
)`
))
247 raise Fail
"Usage description contains an unknown username"
249 val usageFile
= TextIO.openOut (Init
.scratchDir ^
"/usage/" ^
Int.toString trn
)
251 TextIO.output (usageFile
, usage
);
252 TextIO.closeOut usageFile
255 fun equalizeBalances () =
256 ignore (C
.dml (getDb ()) ($`UPDATE Balance SET amount
= (SELECT
SUM(amount
) FROM Charge JOIN WebUser ON usr
= WebUser
.id WHERE bal
= Balance
.id
)`
))
258 fun lookupHostingUsage trn
=
260 val usageFile
= TextIO.openIn (Init
.scratchDir ^
"/usage/" ^
Int.toString trn
)
263 case TextIO.inputLine usageFile
of
264 NONE
=> String.concat (List.rev acc
)
265 | SOME line
=> loop (line
:: acc
)
268 before TextIO.closeIn usageFile
272 case C
.oneRow (getDb ()) ($`SELECT ^
(C
.realToSql amt
) / SUM(shares
) FROM WebUserPaying`
) of
273 [share
] => C
.realFromSql share
274 | row
=> Init
.rowError ("Bad costBase result", row
)