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

[hcoop/portal.git] / support.sml

diff --git a/support.sml b/support.sml
index c629b4d..43bb9fb 100644 (file)
--- a/support.sml
+++ b/support.sml
@@ -9,7 +9,8 @@ datatype status =
        | CLOSED
 
 type category = { id : int, grp : int, name : string, descr : string }
-type issue = { id : int, usr : int, cat : int, title : string, priv : bool, status : status, stamp : C.timestamp }
+type issue = { id : int, usr : int, cat : int, title : string, priv : bool, status : status,
+              stamp : C.timestamp, cstamp : C.timestamp option, pstamp : C.timestamp option }
 type post = { id : int, usr : int, iss : int, body : string, stamp : C.timestamp }
 type subscription = { usr : int, cat : int }
 
@@ -79,19 +80,22 @@ fun statusFromSql v =
       | 2 => CLOSED
       | _ => raise Fail "Bad support issue status"
 
-fun mkIssueRow [id, usr, cat, title, priv, status, stamp] =
+fun mkIssueRow [id, usr, cat, title, priv, status, stamp, pstamp, cstamp] =
     {id = C.intFromSql id, usr = C.intFromSql usr, cat = C.intFromSql cat,
      title = C.stringFromSql title, priv = C.boolFromSql priv,
-     status = statusFromSql status, stamp = C.timestampFromSql stamp}
+     status = statusFromSql status, stamp = C.timestampFromSql stamp,
+     pstamp = if C.isNull pstamp then NONE else SOME (C.timestampFromSql pstamp),
+     cstamp = if C.isNull cstamp then NONE else SOME (C.timestampFromSql cstamp)}
+
   | mkIssueRow row = rowError ("issue", row)
 
 fun lookupIssue id =
-    mkIssueRow (C.oneRow (getDb ()) ($`SELECT id, usr, cat, title, priv, status, stamp
+    mkIssueRow (C.oneRow (getDb ()) ($`SELECT id, usr, cat, title, priv, status, stamp, pstamp, cstamp
                                       FROM SupIssue
                                       WHERE id = ^(C.intToSql id)`))
 
 fun listIssues () =
-    C.map (getDb ()) mkIssueRow ($`SELECT id, usr, cat, title, priv, status, stamp
+    C.map (getDb ()) mkIssueRow ($`SELECT id, usr, cat, title, priv, status, stamp, pstamp, cstamp
                                   FROM SupIssue
                                   ORDER BY stamp DESC`)
 
@@ -99,7 +103,7 @@ fun mkIssueRow' (name :: rest) = (C.stringFromSql name, mkIssueRow rest)
   | mkIssueRow' r = Init.rowError ("issue'", r)
 
 fun listOpenIssues usr =
-    C.map (getDb ()) mkIssueRow' ($`SELECT WebUser.name, SupIssue.id, SupIssue.usr, SupIssue.cat, title, priv, status, stamp
+    C.map (getDb ()) mkIssueRow' ($`SELECT WebUser.name, SupIssue.id, SupIssue.usr, SupIssue.cat, title, priv, status, stamp, pstamp, cstamp
                                    FROM SupIssue JOIN SupCategory ON cat = SupCategory.id
                                       JOIN WebUser ON WebUser.id = SupIssue.usr
                                    WHERE status < 2
@@ -113,14 +117,14 @@ fun listOpenIssues usr =
                                    ORDER BY stamp DESC`)
 
 fun listCategoryIssues cat =
-    C.map (getDb ()) mkIssueRow' ($`SELECT WebUser.name, SupIssue.id, usr, cat, title, priv, status, stamp
+    C.map (getDb ()) mkIssueRow' ($`SELECT WebUser.name, SupIssue.id, usr, cat, title, priv, status, stamp, pstamp, cstamp
                                    FROM SupIssue
                                       JOIN WebUser ON WebUser.id = usr
                                    WHERE cat = ^(C.intToSql cat)
                                    ORDER BY stamp DESC`)
 
 fun listOpenCategoryIssues (cat, usr) =
-    C.map (getDb ()) mkIssueRow' ($`SELECT name, SupIssue.id, usr, cat, title, priv, status, stamp
+    C.map (getDb ()) mkIssueRow' ($`SELECT name, SupIssue.id, usr, cat, title, priv, status, stamp, pstamp, cstamp
                                    FROM SupIssue
                                       JOIN WebUser ON WebUser.id = usr
                                    WHERE cat = ^(C.intToSql cat)
@@ -129,7 +133,7 @@ fun listOpenCategoryIssues (cat, usr) =
                                    ORDER BY stamp DESC`)
 
 fun listOpenCategoryIssuesAdmin cat =
-    C.map (getDb ()) mkIssueRow' ($`SELECT name, SupIssue.id, usr, cat, title, priv, status, stamp
+    C.map (getDb ()) mkIssueRow' ($`SELECT name, SupIssue.id, usr, cat, title, priv, status, stamp, pstamp, cstamp
                                    FROM SupIssue
                                       JOIN WebUser ON WebUser.id = usr
                                    WHERE cat = ^(C.intToSql cat)
@@ -141,10 +145,10 @@ fun addIssue (usr, cat, title, priv, status) =
        val db = getDb ()
        val id = nextSeq (db, "SupIssueSeq")
     in
-       C.dml db ($`INSERT INTO SupIssue (id, usr, cat, title, priv, status, stamp)
+       C.dml db ($`INSERT INTO SupIssue (id, usr, cat, title, priv, status, stamp, pstamp, cstamp)
                    VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql cat),
                            ^(C.stringToSql title), ^(C.boolToSql priv),
-                           ^(statusToSql status), CURRENT_TIMESTAMP)`);
+                           ^(statusToSql status), CURRENT_TIMESTAMP, NULL, NULL)`);
        id
     end
 
@@ -152,6 +156,10 @@ fun modIssue (iss : issue) =
     let
        val db = getDb ()
     in
+       case #status iss of
+           PENDING => ignore (C.dml db ($`UPDATE SupIssue SET pstamp = CURRENT_TIMESTAMP WHERE id = ^(C.intToSql (#id iss))`))
+         | CLOSED => ignore (C.dml db ($`UPDATE SupIssue SET cstamp = CURRENT_TIMESTAMP WHERE id = ^(C.intToSql (#id iss))`))
+         | _ => ();
        ignore (C.dml db ($`UPDATE SupIssue SET
                            usr = ^(C.intToSql (#usr iss)), cat = ^(C.intToSql (#cat iss)),
                               title = ^(C.stringToSql (#title iss)), priv = ^(C.boolToSql (#priv iss)),
@@ -232,7 +240,7 @@ fun unsubscribe {usr, cat} =
     ignore (C.dml (getDb ()) ($`DELETE FROM SupSubscription
                                WHERE usr = ^(C.intToSql usr) AND cat = ^(C.intToSql cat)`))
 
-val okChars = [#" ", #"-", #".", #"!", #"?", #":", #";", #"'", #"\""]
+val okChars = [#" ", #"-", #".", #"!", #"?", #":", #",", #";", #"'", #"\"", #"/", #"(", #")", #"{", #"}", #"[", #"]"]
 
 fun validTitle s = CharVector.exists (fn ch => not (Char.isSpace ch)) s
                   andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse List.exists (fn ch' => ch = ch') okChars) s
@@ -273,6 +281,7 @@ fun writeRecipients (mail, iss : issue, cat : category, noName) =
                    ()
                else
                    (Mail.mwrite (mail, name);
+                    Mail.mwrite (mail, emailSuffix);
                     Mail.mwrite (mail, ","))
            end
     in