Commit | Line | Data |
---|---|---|
5a2812ca AC |
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 addIssue (usr, cat, title, priv, status) = | |
99 | let | |
100 | val db = getDb () | |
101 | val id = nextSeq (db, "SupIssueSeq") | |
102 | in | |
103 | C.dml db ($`INSERT INTO SupIssue (id, usr, cat, title, priv, status, stamp) | |
104 | VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql cat), | |
105 | ^(C.stringToSql title), ^(C.boolToSql priv), | |
106 | ^(statusToSql status), CURRENT_TIMESTAMP)`); | |
107 | id | |
108 | end | |
109 | ||
110 | fun modIssue (iss : issue) = | |
111 | let | |
112 | val db = getDb () | |
113 | in | |
114 | ignore (C.dml db ($`UPDATE SupIssue SET | |
115 | usr = ^(C.intToSql (#usr iss)), cat = ^(C.intToSql (#cat iss)), | |
116 | title = ^(C.stringToSql (#title iss)), priv = ^(C.boolToSql (#priv iss)), | |
117 | status = ^(statusToSql (#status iss)) | |
118 | WHERE id = ^(C.intToSql (#id iss))`)) | |
119 | end | |
120 | ||
121 | fun deleteIssue id = | |
122 | ignore (C.dml (getDb ()) ($`DELETE FROM SupIssue WHERE id = ^(C.intToSql id)`)) | |
123 | ||
124 | ||
125 | (* Posts *) | |
126 | ||
127 | fun mkPostRow [id, usr, iss, body, stamp] = | |
128 | {id = C.intFromSql id, usr = C.intFromSql usr, iss = C.intFromSql iss, | |
129 | body = C.stringFromSql body, stamp = C.timestampFromSql stamp} | |
130 | | mkPostRow row = rowError ("post", row) | |
131 | ||
132 | fun lookupPost id = | |
133 | mkPostRow (C.oneRow (getDb ()) ($`SELECT id, usr, iss, body, stamp | |
134 | FROM SupPost | |
135 | WHERE id = ^(C.intToSql id)`)) | |
136 | ||
137 | fun listPosts iss = | |
138 | C.map (getDb ()) mkPostRow ($`SELECT id, usr, iss, body, stamp | |
139 | FROM SupPost | |
140 | WHERE iss = ^(C.intToSql iss) | |
141 | ORDER BY stamp`) | |
142 | ||
143 | fun addPost (usr, iss, body) = | |
144 | let | |
145 | val db = getDb () | |
146 | val id = nextSeq (db, "SupPostSeq") | |
147 | in | |
148 | C.dml db ($`INSERT INTO SupPost (id, usr, iss, body, stamp) | |
149 | VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql iss), | |
150 | ^(C.stringToSql body), CURRENT_TIMESTAMP)`); | |
151 | id | |
152 | end | |
153 | ||
154 | fun modPost (post : post) = | |
155 | let | |
156 | val db = getDb () | |
157 | in | |
158 | ignore (C.dml db ($`UPDATE SupPost SET | |
159 | usr = ^(C.intToSql (#usr post)), iss = ^(C.intToSql (#iss post)), | |
160 | body = ^(C.stringToSql (#body post)) | |
161 | WHERE id = ^(C.intToSql (#id post))`)) | |
162 | end | |
163 | ||
164 | fun deletePost id = | |
165 | ignore (C.dml (getDb ()) ($`DELETE FROM SupPost WHERE id = ^(C.intToSql id)`)) | |
166 | ||
167 | ||
168 | (* Subscriptions *) | |
169 | ||
170 | fun mkSubRow [usr, cat] = | |
171 | {usr = C.intFromSql usr, cat = C.intFromSql cat} | |
172 | | mkSubRow row = rowError ("subscription", row) | |
173 | ||
174 | fun subscribed {usr, cat} = | |
175 | case C.oneRow (getDb ()) ($`SELECT COUNT( * ) FROM SupSubscription | |
176 | WHERE usr = ^(C.intToSql usr) AND cat = ^(C.intToSql cat)`) of | |
177 | [n] => not (C.isNull n) andalso C.intFromSql n > 0 | |
178 | | r => Init.rowError ("subscribed", r) | |
179 | ||
180 | fun subscribe (sub as {usr, cat}) = | |
181 | if subscribed sub then | |
182 | () | |
183 | else | |
184 | ignore (C.dml (getDb ()) ($`INSERT INTO SupSubscription (usr, cat) | |
185 | VALUES (^(C.intToSql usr), ^(C.intToSql cat))`)) | |
186 | ||
187 | fun unsubscribe {usr, cat} = | |
188 | ignore (C.dml (getDb ()) ($`DELETE FROM SupSubscription | |
189 | WHERE usr = ^(C.intToSql usr) AND cat = ^(C.intToSql cat)`)) | |
190 | ||
191 | ||
192 | end |