payment: note that Stripe has instituted an additional 1% fee for non-US cards

[hcoop/portal.git] / request.sml

functor Request (T : REQUEST_IN) :> REQUEST_OUT =
struct

open Util Sql Init

val table = T.table
val seq = table ^ "Seq"

datatype status =
	 NEW
       | INSTALLED
       | REJECTED

type request = { id : int, usr : int, data : string, msg : string, status : status,
		 stamp : C.timestamp, cstamp : C.timestamp option }

val statusFromInt =
    fn 0 => NEW
     | 1 => INSTALLED
     | 2 => REJECTED
     | _ => raise C.Sql "Bad APT request status"

val statusToInt =
    fn NEW => 0
     | INSTALLED => 1
     | REJECTED => 2

fun statusFromSql v = statusFromInt (C.intFromSql v)
fun statusToSql s = C.intToSql (statusToInt s)

fun mkRow [id, usr, data, msg, status, stamp, cstamp] =
    {id = C.intFromSql id, usr = C.intFromSql usr, data = C.stringFromSql data,
     msg = C.stringFromSql msg, status = statusFromSql status, stamp = C.timestampFromSql stamp,
     cstamp = if C.isNull cstamp then NONE else SOME (C.timestampFromSql cstamp)}
  | mkRow r = rowError ("APT request", r)

fun add (usr, data, msg) =
    let
	val db = getDb ()
	val id = nextSeq (db, seq)
    in
	C.dml db ($`INSERT INTO ^table (id, usr, data, msg, status, stamp, cstamp)
		    VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.stringToSql data), ^(C.stringToSql msg),
			    0, CURRENT_TIMESTAMP, NULL)`);
	id
    end

fun modify (req : request) =
    let
	val db = getDb ()
    in
	if #status req <> NEW then
	    ignore (C.dml db ($`UPDATE ^table SET cstamp = CURRENT_TIMESTAMP WHERE id = ^(C.intToSql (#id req))`))
	else
	    ();
	ignore (C.dml db ($`UPDATE ^table SET
			    usr = ^(C.intToSql (#usr req)), data = ^(C.stringToSql (#data req)),
			       msg = ^(C.stringToSql (#msg req)), status = ^(statusToSql (#status req))
			    WHERE id = ^(C.intToSql (#id req))`))
    end

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

fun lookup id =
    case C.oneOrNoRows (getDb ()) ($`SELECT id, usr, data, msg, status, stamp, cstamp
				     FROM ^table
				     WHERE id = ^(C.intToSql id)`) of
	SOME row => mkRow row
      | NONE => raise Fail ($`^table request not found`)

fun mkRow' (name :: rest) = (C.stringFromSql name, mkRow rest)
  | mkRow' r = rowError ("Apt.request'", r)

fun list () =
    C.map (getDb ()) mkRow' ($`SELECT name, ^table.id, usr, data, msg, status, stamp, cstamp
			       FROM ^table JOIN WebUser ON usr = WebUser.id
			       ORDER BY stamp DESC`)

fun listOpen () =
    C.map (getDb ()) mkRow' ($`SELECT name, ^table.id, usr, data, msg, status, stamp, cstamp
			       FROM ^table JOIN WebUser ON usr = WebUser.id
	 		       WHERE status = 0
			       ORDER BY stamp DESC`)

fun notify f req =
    let
	val grp =
	    case Group.groupNameToId T.adminGroup of
		NONE => 0
	      | SOME grp => grp

	val req = lookup req
	val user = Init.lookupUser (#usr req)

	val mail = Mail.mopen ()

	fun doOne [name] =
	    let
		val name = C.stringFromSql name
	    in
		if name = #name user then
		    ()
		else
		    (Mail.mwrite (mail, name);
		     Mail.mwrite (mail, emailSuffix);
		     Mail.mwrite (mail, ","))
	    end
	  | doOne r = rowError (table ^ ".doOne", r)
    in
	Mail.mwrite (mail, "From: Hcoop Portal <portal");
	Mail.mwrite (mail, emailSuffix);
	Mail.mwrite (mail, ">\nTo: ");
	Mail.mwrite (mail, #name user);
	Mail.mwrite (mail, emailSuffix);		     
	Mail.mwrite (mail, "\nBcc: ");
	C.app (getDb ()) doOne ($`SELECT name
				  FROM WebUser JOIN Membership ON (usr = id AND grp = ^(C.intToSql grp))`);
	Mail.mwrite (mail, "\nSubject: ");
	Mail.mwrite (mail, T.subject (#data req));
	Mail.mwrite (mail, "\n\n");

	f (user, mail);

	T.body (mail, #data req);

	Mail.mwrite (mail, "\n");
	Mail.mwrite (mail, #msg req);

	Mail.mwrite (mail, "\n\nOpen requests: ");
	Mail.mwrite (mail, urlPrefix);
	Mail.mwrite (mail, T.template);
	Mail.mwrite (mail, "?cmd=open\n");

	OS.Process.isSuccess (Mail.mclose mail)
    end

val notifyNew = notify (fn (user, mail) =>
			   (Mail.mwrite (mail, #name user);
			    Mail.mwrite (mail, " has requested the following ");
			    Mail.mwrite (mail, T.descr);
			    Mail.mwrite (mail, ":\n\n")))

val statusToString =
    fn NEW => "New"
     | INSTALLED => "Installed"
     | REJECTED => "Rejected"

fun notifyMod (oldStatus, newStatus, changer, req) =
    if oldStatus = newStatus then
	notify (fn (_, mail) =>
		   (Mail.mwrite (mail, changer);
		    Mail.mwrite (mail, " has added a comment to this request.\n\n"))) req
    else
	notify (fn (_, mail) =>
		   (Mail.mwrite (mail, changer);
		    Mail.mwrite (mail, " has changed the status of this request from ");
		    Mail.mwrite (mail, statusToString oldStatus);
		    Mail.mwrite (mail, " to ");
		    Mail.mwrite (mail, statusToString newStatus);
		    Mail.mwrite (mail, ".\n\n"))) req
		
end