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
, stamp
: C
.timestamp
}
13 type post
= { id
: int, usr
: int, iss
: int, body
: string, stamp
: C
.timestamp
}
14 type subscription
= { usr
: int, cat
: int }
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
)
24 fun lookupCategory id
=
25 mkCatRow (C
.oneRow (getDb ()) ($`SELECT id
, grp
, name
, descr
27 WHERE id
= ^
(C
.intToSql id
)`
))
29 fun listCategories () =
30 C
.map (getDb ()) mkCatRow ($`SELECT id
, grp
, name
, descr
34 fun mkCatRow
' (sub
:: rest
) =
35 (not (C
.isNull sub
), mkCatRow rest
)
36 | mkCatRow
' row
= Init
.rowError ("category'", row
)
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
)
44 fun addCategory (grp
, name
, descr
) =
47 val id
= nextSeq (db
, "SupCategorySeq")
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
))`
);
54 fun modCategory (cat
: category
) =
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
))`
))
64 fun deleteCategory id
=
65 ignore (C
.dml (getDb ()) ($`DELETE FROM SupCategory WHERE id
= ^
(C
.intToSql id
)`
))
76 case C
.intFromSql v
of
80 | _
=> raise Fail
"Bad support issue status"
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
)
89 mkIssueRow (C
.oneRow (getDb ()) ($`SELECT id
, usr
, cat
, title
, priv
, status
, stamp
91 WHERE id
= ^
(C
.intToSql id
)`
))
94 C
.map (getDb ()) mkIssueRow ($`SELECT id
, usr
, cat
, title
, priv
, status
, stamp
98 fun mkIssueRow
' (name
:: rest
) = (C
.stringFromSql name
, mkIssueRow rest
)
99 | mkIssueRow
' r
= Init
.rowError ("issue'", r
)
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
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`
)
115 fun listCategoryIssues cat
=
116 C
.map (getDb ()) mkIssueRow
' ($`SELECT WebUser
.name
, SupIssue
.id
, usr
, cat
, title
, priv
, status
, stamp
118 JOIN WebUser ON WebUser
.id
= usr
119 WHERE cat
= ^
(C
.intToSql cat
)
120 ORDER BY stamp DESC`
)
122 fun listOpenCategoryIssues (cat
, usr
) =
123 C
.map (getDb ()) mkIssueRow
' ($`SELECT name
, SupIssue
.id
, usr
, cat
, title
, priv
, status
, stamp
125 JOIN WebUser ON WebUser
.id
= usr
126 WHERE cat
= ^
(C
.intToSql cat
)
128 AND (NOT priv OR usr
= ^
(C
.intToSql usr
))
129 ORDER BY stamp DESC`
)
131 fun listOpenCategoryIssuesAdmin cat
=
132 C
.map (getDb ()) mkIssueRow
' ($`SELECT name
, SupIssue
.id
, usr
, cat
, title
, priv
, status
, stamp
134 JOIN WebUser ON WebUser
.id
= usr
135 WHERE cat
= ^
(C
.intToSql cat
)
137 ORDER BY stamp DESC`
)
139 fun addIssue (usr
, cat
, title
, priv
, status
) =
142 val id
= nextSeq (db
, "SupIssueSeq")
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
)`
);
151 fun modIssue (iss
: issue
) =
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
))`
))
163 ignore (C
.dml (getDb ()) ($`DELETE FROM SupIssue WHERE id
= ^
(C
.intToSql id
)`
))
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
)
174 mkPostRow (C
.oneRow (getDb ()) ($`SELECT id
, usr
, iss
, body
, stamp
176 WHERE id
= ^
(C
.intToSql id
)`
))
178 fun mkPostRow
' (name
:: rest
) = (C
.stringFromSql name
, mkPostRow rest
)
179 | mkPostRow
' row
= Init
.rowError ("post'", row
)
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
)
187 fun addPost (usr
, iss
, body
) =
190 val id
= nextSeq (db
, "SupPostSeq")
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
)`
);
198 fun modPost (post
: post
) =
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
))`
))
209 ignore (C
.dml (getDb ()) ($`DELETE FROM SupPost WHERE id
= ^
(C
.intToSql id
)`
))
214 fun mkSubRow
[usr
, cat
] =
215 {usr
= C
.intFromSql usr
, cat
= C
.intFromSql cat
}
216 | mkSubRow row
= rowError ("subscription", row
)
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
)
224 fun subscribe (sub
as {usr
, cat
}) =
225 if subscribed sub
then
228 ignore (C
.dml (getDb ()) ($`INSERT INTO
SupSubscription (usr
, cat
)
229 VALUES (^
(C
.intToSql usr
), ^
(C
.intToSql cat
))`
))
231 fun unsubscribe
{usr
, cat
} =
232 ignore (C
.dml (getDb ()) ($`DELETE FROM SupSubscription
233 WHERE usr
= ^
(C
.intToSql usr
) AND cat
= ^
(C
.intToSql cat
)`
))
235 val okChars
= [#
" ", #
"-", #
".", #
"!", #
"?", #
":", #
";", #
"'", #
"\""]
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
240 fun allowedToSee iss
=
242 val iss
= lookupIssue iss
243 val cat
= lookupCategory (#cat iss
)
245 not (#priv iss
) orelse Group
.inGroupNum (#grp cat
) orelse (Init
.getUserId () = #usr iss
)
248 fun allowedToEdit iss
=
250 val iss
= lookupIssue iss
251 val cat
= lookupCategory (#cat iss
)
253 Group
.inGroupNum (#grp cat
) orelse (Init
.getUserId () = #usr iss
)
256 fun writeRecipients (mail
, iss
: issue
, cat
: category
, noName
) =
261 FROM WebUser JOIN Membership
ON (usr
= id AND grp
= ^
(C
.intToSql (#grp cat
)))`
264 FROM WebUser JOIN SupSubscription
ON (usr
= id AND cat
= ^
(C
.intToSql (#id cat
)))
266 FROM WebUser JOIN Membership
ON (usr
= id AND grp
= ^
(C
.intToSql (#grp cat
)))`
270 val name
= C
.stringFromSql name
272 if name
= noName
then
275 (Mail
.mwrite (mail
, name
);
276 Mail
.mwrite (mail
, ","))
279 Mail
.mwrite (mail
, "Bcc: ");
280 C
.app (getDb ()) doOne query
;
281 Mail
.mwrite (mail
, "\n")
284 fun notify (prefix
, f
) iss
=
286 val iss
= lookupIssue iss
287 val cat
= lookupCategory (#cat iss
)
288 val user
= Init
.lookupUser (#usr iss
)
290 val mail
= Mail
.mopen ()
292 Mail
.mwrite (mail
, "From: Hcoop Support System <support@hcoop.net>\nTo: ");
293 Mail
.mwrite (mail
, #name user
);
294 Mail
.mwrite (mail
, "@hcoop.net\n");
295 writeRecipients (mail
, iss
, cat
, #name user
);
296 Mail
.mwrite (mail
, "Subject: ");
297 Mail
.mwrite (mail
, prefix
);
298 Mail
.mwrite (mail
, #title iss
);
299 Mail
.mwrite (mail
, "\n\nURL: ");
300 Mail
.mwrite (mail
, Init
.urlPrefix
);
301 Mail
.mwrite (mail
, "issue?cat=");
302 Mail
.mwrite (mail
, C
.intToSql (#id cat
));
303 Mail
.mwrite (mail
, "&id=");
304 Mail
.mwrite (mail
, C
.intToSql (#id iss
));
305 Mail
.mwrite (mail
, "\n\nSubmitted by: ");
306 Mail
.mwrite (mail
, #name user
);
307 Mail
.mwrite (mail
, "\n Category: ");
308 Mail
.mwrite (mail
, #name cat
);
309 Mail
.mwrite (mail
, "\n Issue: ");
310 Mail
.mwrite (mail
, #title iss
);
311 Mail
.mwrite (mail
, "\n Private: ");
312 Mail
.mwrite (mail
, if #priv iss
then "yes" else "no");
313 Mail
.mwrite (mail
, "\n\n");
315 f (iss
, cat
, user
, mail
);
317 OS
.Process
.isSuccess (Mail
.mclose mail
)
320 val notifyCreation
= notify ("[New] ",
321 fn (iss
, cat
, user
, mail
) =>
322 (case listPosts (#id iss
) of
324 |
[(_
, post
)] => Mail
.mwrite (mail
, #body post
)
325 | _
=> raise Fail
"Too many posts for supposedly new support issue"))
329 val post
= lookupPost pid
330 val poster
= Init
.lookupUser (#usr post
)
333 fn (iss
, cat
, user
, mail
) =>
334 (Mail
.mwrite (mail
, "New post by ");
335 Mail
.mwrite (mail
, #name poster
);
336 Mail
.mwrite (mail
, ":\n\n");
337 Mail
.mwrite (mail
, #body post
))) (#iss post
)
342 | PENDING
=> "Pending"
345 fun notifyStatus (usr
, oldStatus
, newStatus
, iss
) =
347 val user
= Init
.lookupUser usr
349 notify ("[" ^ statusToString newStatus ^
"] ",
350 fn (iss
, cat
, user
, mail
) =>
351 (Mail
.mwrite (mail
, #name user
);
352 Mail
.mwrite (mail
, " changed status from ");
353 Mail
.mwrite (mail
, statusToString oldStatus
);
354 Mail
.mwrite (mail
, " to ");
355 Mail
.mwrite (mail
, statusToString newStatus
);
356 Mail
.mwrite (mail
, ".\n"))) iss