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 = raise Fail ("Bad transaction row : " ^ makeSet id 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 (^id, ^(C.stringToSql descr), ^(C.realToSql amount), ^(C.stringToSql d), CURRENT_TIMESTAMP)`);
  23         C.intFromSql 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 => raise Fail ("Bad listUsers row: " ^ makeSet id row)
  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}
 100   | mkChargeRow row = raise Fail ("Bad charge row : " ^ makeSet id 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 => raise Fail ("Bad name+charge row: " ^ makeSet id 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 - ^amount
 130                                 WHERE id = ^bal`))
 131           | clearCharge row = raise Fail ("Bad clearCharge row : " ^ makeSet id 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 db trn =
 141     let
 142         fun applyCharge [bal, amount] =
 143             ignore (C.dml db ($`UPDATE Balance
 144                                 SET amount = amount + ^amount
 145                                 WHERE id = ^bal`))
 146           | applyCharge row = raise Fail ("Bad applyCharge row : " ^ makeSet id row)
 147     in
 148         C.app db applyCharge ($`SELECT bal, SUM(amount) FROM Charge, WebUser
 149                                 WHERE trn = ^(C.intToSql trn)
 150                                    AND usr = id
 151                                 GROUP BY bal`)
 152     end
 153
 154 fun addEvenCharges (trn, usrs) =
 155     let
 156         val tran = lookupTransaction trn
 157         val nUsrs = length usrs
 158
 159         val split = #amount tran / (real nUsrs)
 160
 161         val db = getDb ()
 162
 163         fun addCharge usr =
 164             ignore (C.dml db ($`INSERT INTO Charge (trn, usr, amount)
 165                                 VALUES (^(C.intToSql trn), ^(C.intToSql usr), ^(C.realToSql split))`))
 166     in
 167         app addCharge usrs;
 168         applyCharges db trn
 169     end
 170
 171 (* Automated hosting charges *)
 172
 173 type hosting = {trn : int, cutoff : int, cost : real, usage : string}
 174
 175 structure StringKey = struct
 176    type ord_key = string
 177    val compare = String.compare
 178 end
 179
 180 structure SM = BinaryMapFn(StringKey)
 181
 182 fun addHostingCharges {trn, cutoff, cost, usage} =
 183     let
 184         val tran = lookupTransaction trn
 185
 186         val paying =
 187             case Group.groupNameToId "paying" of
 188                 NONE => raise Fail "No 'paying' group"
 189               | SOME id => id
 190
 191         val nvs = String.tokens Char.isSpace usage
 192
 193         fun walkNvs (nvs, umap, amount) =
 194             case nvs of
 195                 name :: bw :: rest =>
 196                 let
 197                     val bw = Web.stoi bw
 198                 in
 199                     if bw > cutoff then
 200                         let
 201                             val extra = cost * (real (bw - cutoff) / 1000000.0)
 202                         in
 203                             walkNvs (rest,
 204                                      SM.insert (umap, name, extra),
 205                                      amount - extra)
 206                         end
 207                     else
 208                         walkNvs (rest, umap, amount)
 209                 end
 210               | _ => (umap, amount)
 211
 212         val (umap, amount) = walkNvs (nvs, SM.empty, #amount tran)
 213
 214         val payers = Group.groupMembers paying
 215         val even = amount / real (length payers)
 216
 217         fun doUser (usr : Init.user, umap)  =
 218             let
 219                 val (charge, umap) =
 220                     case SM.find (umap, #name usr) of
 221                         NONE => (even, umap)
 222                       | SOME extra => (even + extra, #1 (SM.remove (umap, #name usr)))
 223             in
 224                 addCharge {trn = trn, usr = #id usr, amount = charge};
 225                 umap
 226             end
 227     in
 228         if SM.numItems (foldl doUser umap payers) = 0 then
 229             ()
 230         else
 231             raise Fail "Usage description contains an unknown username"
 232     end
 233 end