support.sml

   1 structure Support :> SUPPORT =
   2 struct
   3
   4 open Util Sql Init
   5
   6 datatype status =
   7          NEW
   8        | PENDING
   9        | CLOSED
  10
  11 type category = { id : int, grp : int, name : string, descr : string }
  12 type issue = { id : int, usr : int, cat : int, title : string, priv : bool, status : status, stamp : C.timestamp }
  13 type post = { id : int, usr : int, iss : int, body : string, stamp : C.timestamp }
  14 type subscription = { usr : int, cat : int }
  15
  16
  17 (* Categories *)
  18
  19 fun mkCatRow [id, grp, name, descr] =
  20     {id = C.intFromSql id, grp = C.intFromSql grp, name = C.stringFromSql name,
  21      descr = C.stringFromSql descr}
  22   | mkCatRow row = rowError ("category", row)
  23
  24 fun lookupCategory id =
  25     mkCatRow (C.oneRow (getDb ()) ($`SELECT id, grp, name, descr
  26                                       FROM SupCategory
  27                                       WHERE id = ^(C.intToSql id)`))
  28
  29 fun listCategories () =
  30     C.map (getDb ()) mkCatRow ($`SELECT id, grp, name, descr
  31                                  FROM SupCategory
  32                                  ORDER BY name`)
  33
  34 fun mkCatRow' (sub :: rest) =
  35     (not (C.isNull sub), mkCatRow rest)
  36   | mkCatRow' row = Init.rowError ("category'", row)
  37
  38 fun listCategoriesWithSubscriptions usr =
  39     C.map (getDb ()) mkCatRow' ($`SELECT cat, id, grp, name, descr
  40                                   FROM SupCategory LEFT OUTER JOIN SupSubscription
  41                                      ON (usr = ^(C.intToSql usr) AND cat = id)
  42                                   ORDER BY name`)
  43
  44 fun addCategory (grp, name, descr) =
  45     let
  46         val db = getDb ()
  47         val id = nextSeq (db, "SupCategorySeq")
  48     in
  49         C.dml db ($`INSERT INTO SupCategory (id, grp, name, descr)
  50                     VALUES (^(C.intToSql id), ^(C.intToSql grp), ^(C.stringToSql name), ^(C.stringToSql descr))`);
  51         id
  52     end
  53
  54 fun modCategory (cat : category) =
  55     let
  56         val db = getDb ()
  57     in
  58         ignore (C.dml db ($`UPDATE SupCategory SET
  59                             grp = ^(C.intToSql (#grp cat)), name = ^(C.stringToSql (#name cat)),
  60                                descr = ^(C.stringToSql (#descr cat))
  61                             WHERE id = ^(C.intToSql (#id cat))`))
  62     end
  63
  64 fun deleteCategory id =
  65     ignore (C.dml (getDb ()) ($`DELETE FROM SupCategory WHERE id = ^(C.intToSql id)`))
  66
  67
  68 (* Issues *)
  69
  70 val statusToSql =
  71     fn NEW => "0"
  72      | PENDING => "1"
  73      | CLOSED => "2"
  74
  75 fun statusFromSql v =
  76     case C.intFromSql v of
  77         0 => NEW
  78       | 1 => PENDING
  79       | 2 => CLOSED
  80       | _ => raise Fail "Bad support issue status"
  81
  82 fun mkIssueRow [id, usr, cat, title, priv, status, stamp] =
  83     {id = C.intFromSql id, usr = C.intFromSql usr, cat = C.intFromSql cat,
  84      title = C.stringFromSql title, priv = C.boolFromSql priv,
  85      status = statusFromSql status, stamp = C.timestampFromSql stamp}
  86   | mkIssueRow row = rowError ("issue", row)
  87
  88 fun lookupIssue id =
  89     mkIssueRow (C.oneRow (getDb ()) ($`SELECT id, usr, cat, title, priv, status, stamp
  90                                        FROM SupIssue
  91                                        WHERE id = ^(C.intToSql id)`))
  92
  93 fun listIssues () =
  94     C.map (getDb ()) mkIssueRow ($`SELECT id, usr, cat, title, priv, status, stamp
  95                                    FROM SupIssue
  96                                    ORDER BY stamp DESC`)
  97
  98 fun mkIssueRow' (name :: rest) = (C.stringFromSql name, mkIssueRow rest)
  99   | mkIssueRow' r = Init.rowError ("issue'", r)
 100
 101 fun listOpenIssues usr =
 102     C.map (getDb ()) mkIssueRow' ($`SELECT WebUser.name, SupIssue.id, SupIssue.usr, SupIssue.cat, title, priv, status, stamp
 103                                     FROM SupIssue JOIN SupCategory ON cat = SupCategory.id
 104                                        JOIN WebUser ON WebUser.id = SupIssue.usr
 105                                     WHERE status < 2
 106                                        AND (usr = ^(C.intToSql usr)
 107                                          OR ((SELECT COUNT( * ) FROM SupSubscription
 108                                               WHERE SupSubscription.usr = ^(C.intToSql usr)
 109                                                  AND SupSubscription.cat = SupIssue.cat) > 0
 110                                              AND (not priv OR (SELECT COUNT( * ) FROM Membership
 111                                                                WHERE Membership.usr = ^(C.intToSql usr)
 112                                                                   AND Membership.grp = SupCategory.grp) > 0)))
 113                                     ORDER BY stamp DESC`)
 114
 115 fun listCategoryIssues cat =
 116     C.map (getDb ()) mkIssueRow' ($`SELECT WebUser.name, SupIssue.id, usr, cat, title, priv, status, stamp
 117                                     FROM SupIssue
 118                                        JOIN WebUser ON WebUser.id = usr
 119                                     WHERE cat = ^(C.intToSql cat)
 120                                     ORDER BY stamp DESC`)
 121
 122 fun listOpenCategoryIssues (cat, usr) =
 123     C.map (getDb ()) mkIssueRow' ($`SELECT name, SupIssue.id, usr, cat, title, priv, status, stamp
 124                                     FROM SupIssue
 125                                        JOIN WebUser ON WebUser.id = usr
 126                                     WHERE cat = ^(C.intToSql cat)
 127                                        AND status < 2
 128                                        AND (NOT priv OR usr = ^(C.intToSql usr))
 129                                     ORDER BY stamp DESC`)
 130
 131 fun listOpenCategoryIssuesAdmin cat =
 132     C.map (getDb ()) mkIssueRow' ($`SELECT name, SupIssue.id, usr, cat, title, priv, status, stamp
 133                                     FROM SupIssue
 134                                        JOIN WebUser ON WebUser.id = usr
 135                                     WHERE cat = ^(C.intToSql cat)
 136                                        AND status < 2
 137                                     ORDER BY stamp DESC`)
 138
 139 fun addIssue (usr, cat, title, priv, status) =
 140     let
 141         val db = getDb ()
 142         val id = nextSeq (db, "SupIssueSeq")
 143     in
 144         C.dml db ($`INSERT INTO SupIssue (id, usr, cat, title, priv, status, stamp)
 145                     VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql cat),
 146                             ^(C.stringToSql title), ^(C.boolToSql priv),
 147                             ^(statusToSql status), CURRENT_TIMESTAMP)`);
 148         id
 149     end
 150
 151 fun modIssue (iss : issue) =
 152     let
 153         val db = getDb ()
 154     in
 155         ignore (C.dml db ($`UPDATE SupIssue SET
 156                             usr = ^(C.intToSql (#usr iss)), cat = ^(C.intToSql (#cat iss)),
 157                                title = ^(C.stringToSql (#title iss)), priv = ^(C.boolToSql (#priv iss)),
 158                                status = ^(statusToSql (#status iss))
 159                             WHERE id = ^(C.intToSql (#id iss))`))
 160     end
 161
 162 fun deleteIssue id =
 163     ignore (C.dml (getDb ()) ($`DELETE FROM SupIssue WHERE id = ^(C.intToSql id)`))
 164
 165
 166 (* Posts *)
 167
 168 fun mkPostRow [id, usr, iss, body, stamp] =
 169     {id = C.intFromSql id, usr = C.intFromSql usr, iss = C.intFromSql iss,
 170      body = C.stringFromSql body, stamp = C.timestampFromSql stamp}
 171   | mkPostRow row = rowError ("post", row)
 172
 173 fun lookupPost id =
 174     mkPostRow (C.oneRow (getDb ()) ($`SELECT id, usr, iss, body, stamp
 175                                       FROM SupPost
 176                                       WHERE id = ^(C.intToSql id)`))
 177
 178 fun mkPostRow' (name :: rest) = (C.stringFromSql name, mkPostRow rest)
 179   | mkPostRow' row = Init.rowError ("post'", row)
 180
 181 fun listPosts iss =
 182     C.map (getDb ()) mkPostRow' ($`SELECT name, SupPost.id, usr, iss, body, SupPost.stamp
 183                                    FROM SupPost JOIN WebUser ON usr = WebUser.id
 184                                    WHERE iss = ^(C.intToSql iss)
 185                                    ORDER BY stamp`)
 186
 187 fun addPost (usr, iss, body) =
 188     let
 189         val db = getDb ()
 190         val id = nextSeq (db, "SupPostSeq")
 191     in
 192         C.dml db ($`INSERT INTO SupPost (id, usr, iss, body, stamp)
 193                     VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql iss),
 194                             ^(C.stringToSql body), CURRENT_TIMESTAMP)`);
 195         id
 196     end
 197
 198 fun modPost (post : post) =
 199     let
 200         val db = getDb ()
 201     in
 202         ignore (C.dml db ($`UPDATE SupPost SET
 203                             usr = ^(C.intToSql (#usr post)), iss = ^(C.intToSql (#iss post)),
 204                                body = ^(C.stringToSql (#body post))
 205                             WHERE id = ^(C.intToSql (#id post))`))
 206     end
 207
 208 fun deletePost id =
 209     ignore (C.dml (getDb ()) ($`DELETE FROM SupPost WHERE id = ^(C.intToSql id)`))
 210
 211
 212 (* Subscriptions *)
 213
 214 fun mkSubRow [usr, cat] =
 215     {usr = C.intFromSql usr, cat = C.intFromSql cat}
 216   | mkSubRow row = rowError ("subscription", row)
 217
 218 fun subscribed {usr, cat} =
 219     case C.oneRow (getDb ()) ($`SELECT COUNT( * ) FROM SupSubscription
 220                                 WHERE usr = ^(C.intToSql usr) AND cat = ^(C.intToSql cat)`) of
 221         [n] => not (C.isNull n) andalso C.intFromSql n > 0
 222       | r => Init.rowError ("subscribed", r)
 223
 224 fun subscribe (sub as {usr, cat}) =
 225     if subscribed sub then
 226         ()
 227     else
 228         ignore (C.dml (getDb ()) ($`INSERT INTO SupSubscription (usr, cat)
 229                                     VALUES (^(C.intToSql usr), ^(C.intToSql cat))`))
 230
 231 fun unsubscribe {usr, cat} =
 232     ignore (C.dml (getDb ()) ($`DELETE FROM SupSubscription
 233                                 WHERE usr = ^(C.intToSql usr) AND cat = ^(C.intToSql cat)`))
 234
 235 val okChars = [#" ", #"-", #".", #"!", #"?", #":", #";", #"'", #"\"", #"/"]
 236
 237 fun validTitle s = CharVector.exists (fn ch => not (Char.isSpace ch)) s
 238                    andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse List.exists (fn ch' => ch = ch') okChars) s
 239
 240 fun allowedToSee iss =
 241     let
 242         val iss = lookupIssue iss
 243         val cat = lookupCategory (#cat iss)
 244     in
 245         not (#priv iss) orelse Group.inGroupNum (#grp cat) orelse (Init.getUserId () = #usr iss)
 246     end
 247
 248 fun allowedToEdit iss =
 249     let
 250         val iss = lookupIssue iss
 251         val cat = lookupCategory (#cat iss)
 252     in
 253         Group.inGroupNum (#grp cat) orelse (Init.getUserId () = #usr iss)
 254     end
 255
 256 fun writeRecipients (mail, iss : issue, cat : category, noName) =
 257     let
 258         val query =
 259             if #priv iss then
 260                 $`SELECT name
 261                   FROM WebUser JOIN Membership ON (usr = id AND grp = ^(C.intToSql (#grp cat)))`
 262             else
 263                 $`SELECT name
 264                   FROM WebUser JOIN SupSubscription ON (usr = id AND cat = ^(C.intToSql (#id cat)))
 265                   UNION SELECT name
 266                   FROM WebUser JOIN Membership ON (usr = id AND grp = ^(C.intToSql (#grp cat)))`
 267
 268         fun doOne [name] =
 269             let
 270                 val name = C.stringFromSql name
 271             in
 272                 if name = noName then
 273                     ()
 274                 else
 275                     (Mail.mwrite (mail, name);
 276                      Mail.mwrite (mail, emailSuffix);
 277                      Mail.mwrite (mail, ","))
 278             end
 279     in
 280         Mail.mwrite (mail, "Bcc: ");
 281         C.app (getDb ()) doOne query;
 282         Mail.mwrite (mail, "\n")
 283     end
 284
 285 fun notify (prefix, f) iss =
 286     let
 287         val iss = lookupIssue iss
 288         val cat = lookupCategory (#cat iss)
 289         val user = Init.lookupUser (#usr iss)
 290
 291         val mail = Mail.mopen ()
 292     in
 293         Mail.mwrite (mail, "From: Hcoop Support System <support");
 294         Mail.mwrite (mail, emailSuffix);
 295         Mail.mwrite (mail, ">\nTo: ");
 296         Mail.mwrite (mail, #name user);
 297         Mail.mwrite (mail, emailSuffix);
 298         Mail.mwrite (mail, "\n");
 299         writeRecipients (mail, iss, cat, #name user);
 300         Mail.mwrite (mail, "Subject: ");
 301         Mail.mwrite (mail, prefix);
 302         Mail.mwrite (mail, #title iss);
 303         Mail.mwrite (mail, "\n\nURL: ");
 304         Mail.mwrite (mail, Init.urlPrefix);
 305         Mail.mwrite (mail, "issue?cat=");
 306         Mail.mwrite (mail, C.intToSql (#id cat));
 307         Mail.mwrite (mail, "&id=");
 308         Mail.mwrite (mail, C.intToSql (#id iss));
 309         Mail.mwrite (mail, "\n\nSubmitted by: ");
 310         Mail.mwrite (mail, #name user);
 311         Mail.mwrite (mail, "\n    Category: ");
 312         Mail.mwrite (mail, #name cat);
 313         Mail.mwrite (mail, "\n       Issue: ");
 314         Mail.mwrite (mail, #title iss);
 315         Mail.mwrite (mail, "\n     Private: ");
 316         Mail.mwrite (mail, if #priv iss then "yes" else "no");
 317         Mail.mwrite (mail, "\n\n");
 318
 319         f (iss, cat, user, mail);
 320
 321         OS.Process.isSuccess (Mail.mclose mail)
 322     end
 323
 324 val notifyCreation = notify ("[New] ",
 325                              fn (iss, cat, user, mail) =>
 326                                 (case listPosts (#id iss) of
 327                                      [] => ()
 328                                    | [(_, post)] => Mail.mwrite (mail, #body post)
 329                                    | _ => raise Fail "Too many posts for supposedly new support issue"))
 330
 331 fun notifyPost pid =
 332     let
 333         val post = lookupPost pid
 334         val poster = Init.lookupUser (#usr post)
 335     in
 336         notify ("[Post] ",
 337                 fn (iss, cat, user, mail) =>
 338                    (Mail.mwrite (mail, "New post by ");
 339                     Mail.mwrite (mail, #name poster);
 340                     Mail.mwrite (mail, ":\n\n");
 341                     Mail.mwrite (mail, #body post))) (#iss post)
 342     end
 343
 344 val statusToString =
 345     fn NEW => "New"
 346      | PENDING => "Pending"
 347      | CLOSED => "Closed"
 348
 349 fun notifyStatus (usr, oldStatus, newStatus, iss) =
 350     let
 351         val user = Init.lookupUser usr
 352     in
 353         notify ("[" ^ statusToString newStatus ^ "] ",
 354                 fn (iss, cat, user', mail) =>
 355                    (Mail.mwrite (mail, #name user);
 356                     Mail.mwrite (mail, " changed status from ");
 357                     Mail.mwrite (mail, statusToString oldStatus);
 358                     Mail.mwrite (mail, " to ");
 359                     Mail.mwrite (mail, statusToString newStatus);
 360                     Mail.mwrite (mail, ".\n"))) iss
 361     end
 362
 363 end