structure Money :> MONEY =
struct

open Util Sql Init


(* Managing transactions *)

type transaction = {id :int, descr : string, amount : real, d : string, stamp : C.timestamp}

fun mkTransactionRow [id, descr, amount, d, stamp] =
    {id = C.intFromSql id, descr = C.stringFromSql descr, amount = C.realFromSql amount,
     d = C.stringFromSql d, stamp = C.timestampFromSql stamp}
  | mkTransactionRow row = Init.rowError ("transaction", row)

fun addTransaction (descr, amount, d) =
    let
	val db = getDb ()
	val id = nextSeq (db, "TransactionSeq")
    in
	C.dml db ($`INSERT INTO Transaction (id, descr, amount, d, stamp)
                    VALUES (^(C.intToSql id), ^(C.stringToSql descr), ^(C.realToSql amount), ^(C.stringToSql d), CURRENT_TIMESTAMP)`);
	id
    end

fun lookupTransaction id =
    let
	val c = getDb ()
    in
	(case C.oneOrNoRows c ($`SELECT id, descr, amount, d, stamp FROM Transaction WHERE id = ^(C.intToSql id)`) of
	     NONE => raise Fail "Transaction not found"
	   | SOME r => mkTransactionRow r)
    end

fun modTransaction (trans : transaction) =
    let
	val db = getDb ()
    in
	ignore (C.dml db ($`UPDATE TRANSACTION
			    SET descr = ^(C.stringToSql (#descr trans)), amount = ^(C.realToSql (#amount trans)),
			        d = ^(C.stringToSql (#d trans)), stamp = CURRENT_TIMESTAMP
			    WHERE id = ^(C.intToSql (#id trans))`))
    end

fun deleteTransaction id =
    ignore (C.dml (getDb ()) ($`DELETE FROM Transaction WHERE id = ^(C.intToSql id)`))

fun listTransactions () =
    C.map (getDb ()) mkTransactionRow ($`SELECT id, descr, amount, d, stamp FROM Transaction
				   ORDER BY d DESC`)

fun listTransactionsLimit lim =
    C.map (getDb ()) mkTransactionRow ($`SELECT id, descr, amount, d, stamp FROM Transaction
    				         ORDER BY d DESC
					 LIMIT ^(C.intToSql lim)`)

fun listUserTransactions usr =
    let
	val mkRow =
	    fn (amount :: row) => (C.realFromSql amount, mkTransactionRow row)
	     | _ => raise Fail "Bad charge+transaction row"
    in
	C.map (getDb ()) mkRow ($`SELECT C.amount, T.id, T.descr, T.amount, T.d, T.stamp FROM Transaction T, Charge C
				  WHERE id = trn
				  AND usr = ^(C.intToSql usr)
				  ORDER BY T.d DESC`)
    end

fun listUserTransactionsLimit (usr, lim) =
    let
	val mkRow =
	    fn (amount :: row) => (C.realFromSql amount, mkTransactionRow row)
	     | _ => raise Fail "Bad charge+transaction row"
    in
	C.map (getDb ()) mkRow ($`SELECT C.amount, T.id, T.descr, T.amount, T.d, T.stamp FROM Transaction T, Charge C
				  WHERE id = trn
				  AND usr = ^(C.intToSql usr)
				  ORDER BY T.d DESC
				  LIMIT ^(C.intToSql lim)`)
    end

val mkUserRow' =
    fn (trn :: rest) =>
       (if C.isNull trn then false else true,
	mkUserRow rest)
     | row => Init.rowError ("listUsers", row)

fun listUsers trn =
    C.map (getDb ()) mkUserRow' ($`SELECT trn, id, name, rname, bal, joined, app, shares, paypal, checkout
			           FROM WebUser LEFT OUTER JOIN Charge ON usr = id AND trn = ^(C.intToSql trn)
			           ORDER BY name`)


(* Managing charges *)

type charge = {trn : int, usr : int, amount : real}

fun mkChargeRow [trn, usr, amount] =
    {trn = C.intFromSql trn, usr = C.intFromSql usr, amount = C.realFromSql amount}
  | mkChargeRow row = Init.rowError ("charge", row)

fun addCharge {trn, usr, amount} =
    ignore (C.dml (getDb ()) ($`INSERT INTO Charge (trn, usr, amount)
		                VALUES (^(C.intToSql trn), ^(C.intToSql usr), ^(C.realToSql amount))`))

fun listCharges trn =
    C.map (getDb ()) mkChargeRow ($`SELECT trn, usr, amount FROM Charge
			            WHERE trn = ^(C.intToSql trn)`)

val mkChargeRow' =
    fn (name :: rest) => (C.stringFromSql name, mkChargeRow rest)
     | row => Init.rowError ("name+charge", row)

fun listChargesWithNames trn =
    C.map (getDb ()) mkChargeRow' ($`SELECT name, trn, usr, amount FROM Charge, WebUser
			             WHERE trn = ^(C.intToSql trn)
					AND usr = id
				     ORDER BY name`)


(* Macro-operations *)

fun clearCharges trn =
    let
	val db = getDb ()

	fun clearCharge [bal, amount] =
	    ignore (C.dml db ($`UPDATE Balance
				SET amount = amount - ^(C.stringFromSql amount)
				WHERE id = ^(C.stringFromSql bal)`))
	  | clearCharge row = Init.rowError ("clearCharge", row)
    in
	C.app db clearCharge ($`SELECT bal, SUM(amount) FROM Charge, WebUser
				WHERE trn = ^(C.intToSql trn)
				   AND usr = id
				GROUP BY bal`);
	ignore (C.dml db ($`DELETE FROM Charge WHERE trn = ^(C.intToSql trn)`))
    end

fun applyCharges trn =
    let
	val db = getDb ()

	fun applyCharge [bal, amount] =
	    ignore (C.dml db ($`UPDATE Balance
				SET amount = amount + ^(C.stringFromSql amount)
				WHERE id = ^(C.stringFromSql bal)`))
	  | applyCharge row = Init.rowError ("applyCharge", row)
    in
	C.app db applyCharge ($`SELECT bal, SUM(amount) FROM Charge, WebUser
				WHERE trn = ^(C.intToSql trn)
				   AND usr = id
				GROUP BY bal`)
    end

fun addEvenCharges (trn, usrs) =
    let
	val tran = lookupTransaction trn
	val nUsrs = length usrs

	val split = #amount tran / (real nUsrs)

	val db = getDb ()

	fun addCharge usr =
	    ignore (C.dml db ($`INSERT INTO Charge (trn, usr, amount)
			        VALUES (^(C.intToSql trn), ^(C.intToSql usr), ^(C.realToSql split))`))
    in
	app addCharge usrs;
	applyCharges trn
    end

(* Automated hosting charges *)

type hosting = {trn : int, cutoff : int, cost : real, usage : string}

structure StringKey = struct
   type ord_key = string
   val compare = String.compare
end

structure SM = BinaryMapFn(StringKey)

fun addHostingCharges {trn, cutoff, cost, usage} =
    let
	val tran = lookupTransaction trn

	val paying =
	    case Group.groupNameToId "paying" of
		NONE => raise Fail "No 'paying' group"
	      | SOME id => id

	val nvs = String.tokens Char.isSpace usage

	fun walkNvs (nvs, umap, amount) =
	    case nvs of
		name :: bw :: rest =>
		let
		    val bw = Web.stoi bw
		in
		    if bw > cutoff then
			let
			    val extra = cost * (real (bw - cutoff) / 1000000.0)
			in
			    walkNvs (rest,
				     SM.insert (umap, name, extra),
				     amount + extra)
			end
		    else
			walkNvs (rest, umap, amount)
		end
	      | _ => (umap, amount)

	val (umap, amount) = walkNvs (nvs, SM.empty, #amount tran)

	val db = getDb ()

	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 even = amount / real shares

	fun doUser ([uid, uname, shares], umap)  =
	    let
		val uid = C.intFromSql uid
		val uname = C.stringFromSql uname
		val shares = C.intFromSql shares

		val (charge, umap) =
		    case SM.find (umap, uname) of
			NONE => (even * real shares, umap)
		      | SOME extra => (even * real shares - extra, #1 (SM.remove (umap, uname)))
	    in
		addCharge {trn = trn, usr = uid, amount = charge};
		umap
	    end

	val _ = if SM.numItems (C.fold db doUser umap
				       ($`SELECT id, name, shares
					    FROM WebUser JOIN Membership ON usr = WebUser.id AND grp = ^(C.intToSql paying)`))
		   = 0 then
		    applyCharges trn
		else
		    raise Fail "Usage description contains an unknown username"

	val usageFile = TextIO.openOut (Init.scratchDir ^ "/usage/" ^ Int.toString trn)
    in
	TextIO.output (usageFile, usage);
	TextIO.closeOut usageFile
    end

fun equalizeBalances () =
    ignore (C.dml (getDb ()) ($`UPDATE Balance SET amount = (SELECT SUM(amount) FROM Charge JOIN WebUser ON usr = WebUser.id WHERE bal = Balance.id)`))

fun lookupHostingUsage trn =
    let
	val usageFile = TextIO.openIn (Init.scratchDir ^ "/usage/" ^ Int.toString trn)

	fun loop acc =
	    case TextIO.inputLine usageFile of
		NONE => String.concat (List.rev acc)
	      | SOME line => loop (line :: acc)
    in
	SOME (loop [])
	before TextIO.closeIn usageFile
    end handle _ => NONE

fun costBase amt =
    case C.oneRow (getDb ()) ($`SELECT ^(C.realToSql amt) / SUM(shares) FROM WebUserPaying`) of
	[share] => C.realFromSql share
      | row => Init.rowError ("Bad costBase result", row)

val monthlyCost = 900.0
val graceMonths = 1

val baseDues = 7.0

fun delinquentPledgers () =
    let
	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 baseDues) * ^(C.intToSql graceMonths)
				      AND shares > 1
				    ORDER BY name`)
    end

fun resetPledges 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

end