1 structure Support
:> SUPPORT
=
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 }
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
)
25 fun lookupCategory id
=
26 mkCatRow (C
.oneRow (getDb ()) ($`SELECT id
, grp
, name
, descr
28 WHERE id
= ^
(C
.intToSql id
)`
))
30 fun listCategories () =
31 C
.map (getDb ()) mkCatRow ($`SELECT id
, grp
, name
, descr
35 fun mkCatRow
' (sub
:: rest
) =
36 (not (C
.isNull sub
), mkCatRow rest
)
37 | mkCatRow
' row
= Init
.rowError ("category'", row
)
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
)
45 fun addCategory (grp
, name
, descr
) =
48 val id
= nextSeq (db
, "SupCategorySeq")
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
))`
);
55 fun modCategory (cat
: category
) =
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
))`
))
65 fun deleteCategory id
=
66 ignore (C
.dml (getDb ()) ($`DELETE FROM SupCategory WHERE id
= ^
(C
.intToSql id
)`
))
77 case C
.intFromSql v
of
81 | _
=> raise Fail
"Bad support issue status"
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
)}
90 | mkIssueRow row
= rowError ("issue", row
)
93 mkIssueRow (C
.oneRow (getDb ()) ($`SELECT id
, usr
, cat
, title
, priv
, status
, stamp
, pstamp
, cstamp
95 WHERE id
= ^
(C
.intToSql id
)`
))
98 C
.map (getDb ()) mkIssueRow ($`SELECT id
, usr
, cat
, title
, priv
, status
, stamp
, pstamp
, cstamp
100 ORDER BY stamp DESC`
)
102 fun mkIssueRow
' (name
:: rest
) = (C
.stringFromSql name
, mkIssueRow rest
)
103 | mkIssueRow
' r
= Init
.rowError ("issue'", r
)
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
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`
)
119 fun listCategoryIssues cat
=
120 C
.map (getDb ()) mkIssueRow
' ($`SELECT WebUser
.name
, SupIssue
.id
, usr
, cat
, title
, priv
, status
, stamp
, pstamp
, cstamp
122 JOIN WebUser ON WebUser
.id
= usr
123 WHERE cat
= ^
(C
.intToSql cat
)
124 ORDER BY stamp DESC`
)
126 fun listOpenCategoryIssues (cat
, usr
) =
127 C
.map (getDb ()) mkIssueRow
' ($`SELECT name
, SupIssue
.id
, usr
, cat
, title
, priv
, status
, stamp
, pstamp
, cstamp
129 JOIN WebUser ON WebUser
.id
= usr
130 WHERE cat
= ^
(C
.intToSql cat
)
132 AND (NOT priv OR usr
= ^
(C
.intToSql usr
))
133 ORDER BY stamp DESC`
)
135 fun listOpenCategoryIssuesAdmin cat
=
136 C
.map (getDb ()) mkIssueRow
' ($`SELECT name
, SupIssue
.id
, usr
, cat
, title
, priv
, status
, stamp
, pstamp
, cstamp
138 JOIN WebUser ON WebUser
.id
= usr
139 WHERE cat
= ^
(C
.intToSql cat
)
141 ORDER BY stamp DESC`
)
143 fun addIssue (usr
, cat
, title
, priv
, status
) =
146 val id
= nextSeq (db
, "SupIssueSeq")
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
)`
);
155 fun modIssue (iss
: issue
) =
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
))`
))
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
))`
))
171 ignore (C
.dml (getDb ()) ($`DELETE FROM SupIssue WHERE id
= ^
(C
.intToSql id
)`
))
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
)
182 mkPostRow (C
.oneRow (getDb ()) ($`SELECT id
, usr
, iss
, body
, stamp
184 WHERE id
= ^
(C
.intToSql id
)`
))
186 fun mkPostRow
' (name
:: rest
) = (C
.stringFromSql name
, mkPostRow rest
)
187 | mkPostRow
' row
= Init
.rowError ("post'", row
)
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
)
195 fun addPost (usr
, iss
, body
) =
198 val id
= nextSeq (db
, "SupPostSeq")
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
)`
);
206 fun modPost (post
: post
) =
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
))`
))
217 ignore (C
.dml (getDb ()) ($`DELETE FROM SupPost WHERE id
= ^
(C
.intToSql id
)`
))
222 fun mkSubRow
[usr
, cat
] =
223 {usr
= C
.intFromSql usr
, cat
= C
.intFromSql cat
}
224 | mkSubRow row
= rowError ("subscription", row
)
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
)
232 fun subscribe (sub
as {usr
, cat
}) =
233 if subscribed sub
then
236 ignore (C
.dml (getDb ()) ($`INSERT INTO
SupSubscription (usr
, cat
)
237 VALUES (^
(C
.intToSql usr
), ^
(C
.intToSql cat
))`
))
239 fun unsubscribe
{usr
, cat
} =
240 ignore (C
.dml (getDb ()) ($`DELETE FROM SupSubscription
241 WHERE usr
= ^
(C
.intToSql usr
) AND cat
= ^
(C
.intToSql cat
)`
))
243 val okChars
= [#
" ", #
"-", #
".", #
"!", #
"?", #
":", #
",", #
";", #
"'", #
"\"", #
"/", #
"(", #
")", #
"{", #
"}", #
"[", #
"]"]
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
248 fun allowedToSee iss
=
250 val iss
= lookupIssue iss
251 val cat
= lookupCategory (#cat iss
)
253 not (#priv iss
) orelse Group
.inGroupNum (#grp cat
) orelse (Init
.getUserId () = #usr iss
)
256 fun allowedToEdit iss
=
258 val iss
= lookupIssue iss
259 val cat
= lookupCategory (#cat iss
)
261 Group
.inGroupNum (#grp cat
) orelse (Init
.getUserId () = #usr iss
)
264 fun writeRecipients (mail
, iss
: issue
, cat
: category
, noName
) =
269 FROM WebUser JOIN Membership
ON (usr
= id AND grp
= ^
(C
.intToSql (#grp cat
)))`
272 FROM WebUser JOIN SupSubscription
ON (usr
= id AND cat
= ^
(C
.intToSql (#id cat
)))
274 FROM WebUser JOIN Membership
ON (usr
= id AND grp
= ^
(C
.intToSql (#grp cat
)))`
278 val name
= C
.stringFromSql name
280 if name
= noName
then
283 (Mail
.mwrite (mail
, name
);
284 Mail
.mwrite (mail
, emailSuffix
);
285 Mail
.mwrite (mail
, ","))
288 Mail
.mwrite (mail
, "Bcc: ");
289 C
.app (getDb ()) doOne query
;
290 Mail
.mwrite (mail
, "\n")
293 fun notify (prefix
, f
) iss
=
295 val iss
= lookupIssue iss
296 val cat
= lookupCategory (#cat iss
)
297 val user
= Init
.lookupUser (#usr iss
)
299 val mail
= Mail
.mopen ()
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");
327 f (iss
, cat
, user
, mail
);
329 OS
.Process
.isSuccess (Mail
.mclose mail
)
332 val notifyCreation
= notify ("[New] ",
333 fn (iss
, cat
, user
, mail
) =>
334 (case listPosts (#id iss
) of
336 |
[(_
, post
)] => Mail
.mwrite (mail
, #body post
)
337 | _
=> raise Fail
"Too many posts for supposedly new support issue"))
341 val post
= lookupPost pid
342 val poster
= Init
.lookupUser (#usr 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
)
354 | PENDING
=> "Pending"
357 fun notifyStatus (usr
, oldStatus
, newStatus
, iss
) =
359 val user
= Init
.lookupUser usr
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