money.sml

   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}
  14   | mkTransactionRow row = Init.rowError ("transaction", row)
  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)
  22                     VALUES (^(C.intToSql id), ^(C.stringToSql descr), ^(C.realToSql amount), ^(C.stringToSql d), CURRENT_TIMESTAMP)`);
  23         id
  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)
  86      | row => Init.rowError ("listUsers", row)
  87
  88 fun listUsers trn =
  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)
  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}
 100   | mkChargeRow row = Init.rowError ("charge", row)
 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)
 112      | row => Init.rowError ("name+charge", row)
 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
 129                                 SET amount = amount - ^(C.stringFromSql amount)
 130                                 WHERE id = ^(C.stringFromSql bal)`))
 131           | clearCharge row = Init.rowError ("clearCharge", row)
 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
 140 fun applyCharges trn =
 141     let
 142         val db = getDb ()
 143
 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)
 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;
 170         applyCharges trn
 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             applyCharges trn
 232         else
 233             raise Fail "Usage description contains an unknown username"
 234     end
 235
 236 fun equalizeBalances () =
 237     ignore (C.dml (getDb ()) ($`UPDATE Balance SET amount = (SELECT SUM(amount) FROM Charge JOIN WebUser ON usr = WebUser.id WHERE bal = Balance.id)`))
 238
 239 end