X-Git-Url: https://git.hcoop.net/hcoop/portal.git/blobdiff_plain/1b566e48ec4228ebf60088e7040b9d92a8c1fb01..811dc1e5e566b76e8448fd1dcf156c8f2d56427a:/money.sml diff --git a/money.sml b/money.sml index 1b569c8..55330c2 100644 --- a/money.sml +++ b/money.sml @@ -276,22 +276,156 @@ fun costBase amt = val monthlyCost = 900.0 val graceMonths = 1 +val baseDues = 7.0 + fun delinquentPledgers () = let - val costBase = costBase monthlyCost - fun makeRow [id, name, shares, amount] = {id = C.intFromSql id, name = C.stringFromSql name, shares = C.intFromSql shares, balance = C.realFromSql amount} | makeRow row = Init.rowError ("Bad delinquentPledgers", row) in C.map (getDb ()) makeRow ($`SELECT WebUserPaying.id, WebUserPaying.name, shares, amount FROM WebUserPaying JOIN Balance ON Balance.id = bal - WHERE amount < shares * ^(C.realToSql costBase) * ^(C.intToSql graceMonths) + WHERE amount < shares * ^(C.realToSql baseDues) * ^(C.intToSql graceMonths) AND shares > 1 ORDER BY name`) end fun resetPledges ids = - raise Fail ($`UPDATE WebUser SET shares = 1 WHERE id IN (^(String.concatWith ", " (List.map C.intToSql ids)))`) + ignore (C.dml (getDb ()) ($`UPDATE WebUser SET shares = 1 WHERE id IN (^(String.concatWith ", " (List.map C.intToSql ids)))`)) + +fun freezeworthyPledgers () = + let + fun makeRow [id, name, amount, j] = {id = C.intFromSql id, name = C.stringFromSql name, + balance = C.realFromSql amount, joinedThisMonth = C.boolFromSql j} + | makeRow row = Init.rowError ("Bad freezeworthyPledgers", row) + in + C.map (getDb ()) makeRow ($`SELECT WebUserPaying.id, WebUserPaying.name, amount, CURRENT_TIMESTAMP - joined < INTERVAL '1 month' + FROM WebUserPaying JOIN Balance ON Balance.id = bal + WHERE amount >= ^(C.realToSql baseDues) * ^(C.intToSql graceMonths) + AND amount < ^(C.realToSql baseDues) * ^(C.intToSql (graceMonths + 1)) + ORDER BY name`) + end + +fun bootworthyPledgers () = + let + fun makeRow [id, name, amount, j] = {id = C.intFromSql id, name = C.stringFromSql name, + balance = C.realFromSql amount, joinedThisMonth = C.boolFromSql j} + | makeRow row = Init.rowError ("Bad bootworthyPledgers", row) + in + C.map (getDb ()) makeRow ($`SELECT WebUserPaying.id, WebUserPaying.name, amount, CURRENT_TIMESTAMP - joined < INTERVAL '1 month' + FROM WebUserPaying JOIN Balance ON Balance.id = bal + WHERE amount < ^(C.realToSql baseDues) * ^(C.intToSql graceMonths) + ORDER BY name`) + end + +fun billDues {descr, base, date} = + let + val db = getDb () + val paying = + case Group.groupNameToId "paying" of + NONE => raise Fail "No 'paying' group" + | SOME id => id + + val shares = + case C.oneRow db ($`SELECT SUM(shares) + FROM WebUser JOIN Membership ON usr = WebUser.id AND grp = ^(C.intToSql paying)`) of + [n] => C.intFromSql n + | row => Init.rowError ("Bad addHostingCharges share count result", row) + + val total = real shares * base + + val give = addTransaction (descr, ~total, date) + fun doUser [uid, shares] = + let + val uid = C.intFromSql uid + val shares = C.intFromSql shares + in + addCharge {trn = give, usr = uid, amount = ~(base * real shares)} + end + | doUser r = Init.rowError ("Bad billDues/doUser row", r) + + val receive = addTransaction (descr, total, date) + + val hcoop = valOf (Init.userNameToId "hcoop") + in + C.app db doUser ($`SELECT id, shares + FROM WebUser JOIN Membership ON usr = WebUser.id AND grp = ^(C.intToSql paying)`); + applyCharges give; + + addCharge {trn = receive, usr = hcoop, amount = total}; + applyCharges receive + end + +(* Stripe *) + +type stripePayment = {charge_id : string, webuser_id : int, card_name : string, paid_on : string, gross_cents : int, fee_cents : int, net : real} + +fun mkStripeRow [charge_id, webuser_id, name, paid_on, gross, fee] = + {charge_id = C.stringFromSql charge_id, webuser_id = C.intFromSql webuser_id, + card_name = C.stringFromSql name, paid_on = C.stringFromSql paid_on, + gross_cents = C.intFromSql gross, fee_cents = C.intFromSql fee, net = real (C.intFromSql gross - C.intFromSql fee) / 100.0 } + | mkStripeRow row = Init.rowError ("stripe_payment", row) + +fun listUserPendingStripePayments uid = + C.map (getDb ()) mkStripeRow ($`SELECT charge_id, webuser_id, card_name, paid_on, gross, fee FROM stripe_payment + WHERE webuser_id = ^(C.intToSql uid) + AND charge_id NOT IN (SELECT stripe_charge_id FROM stripe_handled) + ORDER BY paid_on DESC`) + +fun listAllPendingStripePayments _ = + C.map (getDb ()) mkStripeRow ($`SELECT charge_id, webuser_id, card_name, paid_on, gross, fee FROM stripe_payment + WHERE charge_id NOT IN (SELECT stripe_charge_id FROM stripe_handled) + ORDER BY paid_on DESC`) + +fun lookupStripePayment id = + let + val c = getDb () + in + (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 + NONE => raise Fail "Stripe Payment Not Found" + | SOME r => mkStripeRow r) + end + +(* Not Used *) +val stripeNotify : stripePayment -> bool = +fn pmt => + let + val user = Init.lookupUser (#webuser_id pmt) + val mail = Mail.mopen () + in + Mail.mwrite (mail, "From: Hcoop Support System \nTo: payment"); + Mail.mwrite (mail, emailSuffix); + Mail.mwrite (mail, "\n"); + Mail.mwrite (mail, "Subject: Stripe Payment Received"); + Mail.mwrite (mail, "\n\n"); + + Mail.mwrite (mail, "A member has paid us via Stripe. Visit the money page to process the payment."); + Mail.mwrite (mail, "Member: "); + Mail.mwrite (mail, #name user); + Mail.mwrite (mail, "\n"); + Mail.mwrite (mail, "Amount (after fees): "); + Mail.mwrite (mail, Real.toString (#net pmt)); + Mail.mwrite (mail, "\n\n"); + + OS.Process.isSuccess (Mail.mclose mail) + end + +val applyStripePayment : stripePayment -> int = + fn pmt => + let + val _ = Group.requireGroupName "money"; + val amount = #net pmt; + val txid = addTransaction ("Stripe", amount, #paid_on pmt) + in + addCharge {trn = txid, usr = #webuser_id pmt, amount = amount}; + applyCharges txid; + C.dml (getDb ()) ($`INSERT INTO stripe_processed (stripe_charge_id, transaction_id) + VALUES (^(C.stringToSql (#charge_id pmt)), ^(C.intToSql txid))`); + txid + end end +