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, shares, paypal, checkout
  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 db = getDb ()
 217
 218         val shares =
 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)
 223
 224         val even = amount / real shares
 225
 226         fun doUser ([uid, uname, shares], umap)  =
 227             let
 228                 val uid = C.intFromSql uid
 229                 val uname = C.stringFromSql uname
 230                 val shares = C.intFromSql shares
 231
 232                 val (charge, umap) =
 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)))
 236             in
 237                 addCharge {trn = trn, usr = uid, amount = charge};
 238                 umap
 239             end
 240
 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)`))
 244                    = 0 then
 245                     applyCharges trn
 246                 else
 247                     raise Fail "Usage description contains an unknown username"
 248
 249         val usageFile = TextIO.openOut (Init.scratchDir ^ "/usage/" ^ Int.toString trn)
 250     in
 251         TextIO.output (usageFile, usage);
 252         TextIO.closeOut usageFile
 253     end
 254
 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)`))
 257
 258 fun lookupHostingUsage trn =
 259     let
 260         val usageFile = TextIO.openIn (Init.scratchDir ^ "/usage/" ^ Int.toString trn)
 261
 262         fun loop acc =
 263             case TextIO.inputLine usageFile of
 264                 NONE => String.concat (List.rev acc)
 265               | SOME line => loop (line :: acc)
 266     in
 267         SOME (loop [])
 268         before TextIO.closeIn usageFile
 269     end handle _ => NONE
 270
 271 fun costBase amt =
 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)
 275
 276 val monthlyCost = 900.0
 277 val graceMonths = 1
 278
 279 val baseDues = 7.0
 280
 281 fun delinquentPledgers () =
 282     let
 283         fun makeRow [id, name, shares, amount] = {id = C.intFromSql id, name = C.stringFromSql name,
 284                                                   shares = C.intFromSql shares, balance = C.realFromSql amount}
 285           | makeRow row = Init.rowError ("Bad delinquentPledgers", row)
 286     in
 287         C.map (getDb ()) makeRow ($`SELECT WebUserPaying.id, WebUserPaying.name, shares, amount
 288                                     FROM WebUserPaying JOIN Balance ON Balance.id = bal
 289                                     WHERE amount < shares * ^(C.realToSql baseDues) * ^(C.intToSql graceMonths)
 290                                       AND shares > 1
 291                                     ORDER BY name`)
 292     end
 293
 294 fun resetPledges ids =
 295     ignore (C.dml (getDb ()) ($`UPDATE WebUser SET shares = 1 WHERE id IN (^(String.concatWith ", " (List.map C.intToSql ids)))`))
 296
 297 fun freezeworthyPledgers () =
 298     let
 299         fun makeRow [id, name, amount, j] = {id = C.intFromSql id, name = C.stringFromSql name,
 300                                              balance = C.realFromSql amount, joinedThisMonth = C.boolFromSql j}
 301           | makeRow row = Init.rowError ("Bad freezeworthyPledgers", row)
 302     in
 303         C.map (getDb ()) makeRow ($`SELECT WebUserPaying.id, WebUserPaying.name, amount, CURRENT_TIMESTAMP - joined < INTERVAL '1 month'
 304                                     FROM WebUserPaying JOIN Balance ON Balance.id = bal
 305                                     WHERE amount >= ^(C.realToSql baseDues) * ^(C.intToSql graceMonths)
 306                                       AND amount < ^(C.realToSql baseDues) * ^(C.intToSql (graceMonths + 1))
 307                                     ORDER BY name`)
 308     end
 309
 310 fun bootworthyPledgers () =
 311     let
 312         fun makeRow [id, name, amount, j] = {id = C.intFromSql id, name = C.stringFromSql name,
 313                                              balance = C.realFromSql amount, joinedThisMonth = C.boolFromSql j}
 314           | makeRow row = Init.rowError ("Bad bootworthyPledgers", row)
 315     in
 316         C.map (getDb ()) makeRow ($`SELECT WebUserPaying.id, WebUserPaying.name, amount, CURRENT_TIMESTAMP - joined < INTERVAL '1 month'
 317                                     FROM WebUserPaying JOIN Balance ON Balance.id = bal
 318                                     WHERE amount < ^(C.realToSql baseDues) * ^(C.intToSql graceMonths)
 319                                     ORDER BY name`)
 320     end
 321
 322 fun billDues {descr, base, date} =
 323     let
 324         val db = getDb ()
 325         val paying =
 326             case Group.groupNameToId "paying" of
 327                 NONE => raise Fail "No 'paying' group"
 328               | SOME id => id
 329
 330         val shares =
 331             case C.oneRow db ($`SELECT SUM(shares)
 332                                   FROM WebUser JOIN Membership ON usr = WebUser.id AND grp = ^(C.intToSql paying)`) of
 333                 [n] => C.intFromSql n
 334               | row => Init.rowError ("Bad addHostingCharges share count result", row)
 335
 336         val total = real shares * base
 337
 338         val give = addTransaction (descr, ~total, date)
 339
 340         fun doUser [uid, shares]  =
 341             let
 342                 val uid = C.intFromSql uid
 343                 val shares = C.intFromSql shares
 344             in
 345                 addCharge {trn = give, usr = uid, amount = ~(base * real shares)}
 346             end
 347           | doUser r = Init.rowError ("Bad billDues/doUser row", r)
 348
 349         val receive = addTransaction (descr, total, date)
 350
 351         val hcoop = valOf (Init.userNameToId "hcoop")
 352     in
 353         C.app db doUser ($`SELECT id, shares
 354                            FROM WebUser JOIN Membership ON usr = WebUser.id AND grp = ^(C.intToSql paying)`);
 355         applyCharges give;
 356
 357         addCharge {trn = receive, usr = hcoop, amount = total};
 358         applyCharges receive
 359     end
 360
 361 (* Stripe *)
 362
 363 type stripePayment = {charge_id : string, webuser_id : int, card_name : string, paid_on : string, gross_cents : int, fee_cents : int, net : real}
 364
 365 fun mkStripeRow [charge_id, webuser_id, name, paid_on, gross, fee] =
 366     {charge_id = C.stringFromSql charge_id, webuser_id = C.intFromSql webuser_id,
 367      card_name = C.stringFromSql name, paid_on = C.stringFromSql paid_on,
 368      gross_cents = C.intFromSql gross, fee_cents = C.intFromSql fee,  net = real (C.intFromSql gross - C.intFromSql fee) / 100.0 }
 369     | mkStripeRow row = Init.rowError ("stripe_payment", row)
 370
 371 fun listUserPendingStripePayments uid =
 372     C.map (getDb ()) mkStripeRow ($`SELECT charge_id, webuser_id, card_name, paid_on, gross, fee FROM stripe_payment
 373                                      WHERE webuser_id = ^(C.intToSql uid)
 374                                      AND charge_id NOT IN (SELECT stripe_charge_id FROM stripe_handled)
 375                                      ORDER BY paid_on DESC`)
 376
 377 fun listAllPendingStripePayments _ =
 378     C.map (getDb ()) mkStripeRow ($`SELECT charge_id, webuser_id, card_name, paid_on, gross, fee FROM stripe_payment
 379                                      WHERE charge_id NOT IN (SELECT stripe_charge_id FROM stripe_handled)
 380                                      ORDER BY paid_on DESC`)
 381
 382 fun lookupStripePayment id =
 383     let
 384         val c = getDb ()
 385     in
 386         (case C.oneOrNoRows c ($`SELECT charge_id, webuser_id, card_name, paid_on, gross, fee FROM stripe_payment WHERE charge_id = ^(C.stringToSql id)`) of
 387              NONE => raise Fail "Stripe Payment Not Found"
 388            | SOME r => mkStripeRow r)
 389     end
 390
 391 (* Not Used *)
 392 val stripeNotify : stripePayment -> bool =
 393 fn pmt =>
 394     let
 395         val user = Init.lookupUser (#webuser_id pmt)
 396         val mail = Mail.mopen ()
 397     in
 398         Mail.mwrite (mail, "From: Hcoop Support System <support");
 399         Mail.mwrite (mail, emailSuffix);
 400         Mail.mwrite (mail, ">\nTo: payment");
 401         Mail.mwrite (mail, emailSuffix);
 402         Mail.mwrite (mail, "\n");
 403         Mail.mwrite (mail, "Subject: Stripe Payment Received");
 404         Mail.mwrite (mail, "\n\n");
 405
 406         Mail.mwrite (mail, "A member has paid us via Stripe. Visit the money page to process the payment.");
 407         Mail.mwrite (mail, "Member: ");
 408         Mail.mwrite (mail, #name user);
 409         Mail.mwrite (mail, "\n");
 410         Mail.mwrite (mail, "Amount (after fees): ");
 411         Mail.mwrite (mail, Real.toString (#net pmt));
 412         Mail.mwrite (mail, "\n\n");
 413
 414         OS.Process.isSuccess (Mail.mclose mail)
 415     end
 416
 417 val applyStripePayment : stripePayment -> int =
 418  fn pmt =>
 419     let
 420         val _ = Group.requireGroupName "money";
 421         val amount = #net pmt;
 422         val txid = addTransaction ("Stripe", amount, #paid_on pmt)
 423     in
 424         addCharge {trn = txid, usr = #webuser_id pmt, amount = amount};
 425         applyCharges txid;
 426         C.dml (getDb ()) ($`INSERT INTO stripe_processed (stripe_charge_id, transaction_id)
 427                                   VALUES (^(C.stringToSql (#charge_id pmt)), ^(C.intToSql txid))`);
 428         txid
 429     end
 430 end
 431