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