Commit | Line | Data |
---|---|---|
d6223be9 AC |
1 | structure Contact :> CONTACT = |
2 | struct | |
3 | ||
4 | open Util Sql Init | |
5 | ||
6 | ||
ee587f7f | 7 | (* Managing kinds *) |
d6223be9 AC |
8 | |
9 | type kind = {id :int, name : string, makeUrl : (string * string) option} | |
10 | ||
11 | fun makerToSql NONE = "FALSE, NULL, NULL" | |
12 | | makerToSql (SOME (pre, post)) = $`TRUE, ^(C.stringToSql pre), ^(C.stringToSql post)` | |
13 | ||
14 | fun makerToSqlUpd NONE = "url = FALSE, urlPrefix = NULL, urlPostfix = NULL" | |
15 | | makerToSqlUpd (SOME (pre, post)) = $`url = TRUE, urlPrefix = ^(C.stringToSql pre), urlPostfix = ^(C.stringToSql post)` | |
16 | ||
17 | fun mkKindRow [id, name, url, urlPrefix, urlPostfix] = | |
18 | {id = C.intFromSql id, name = C.stringFromSql name, | |
19 | makeUrl = (if C.boolFromSql url then | |
20 | SOME (C.stringFromSql urlPrefix, C.stringFromSql urlPostfix) | |
21 | else | |
22 | NONE)} | |
ee587f7f | 23 | | mkKindRow row = Init.rowError ("kind", row) |
d6223be9 AC |
24 | |
25 | fun addKind (name, makeUrl) = | |
26 | let | |
27 | val db = getDb () | |
28 | val id = nextSeq (db, "ContactKindSeq") | |
29 | in | |
30 | C.dml db ($`INSERT INTO ContactKind (id, name, url, urlPrefix, urlPostfix) | |
ee587f7f AC |
31 | VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(makerToSql makeUrl))`); |
32 | id | |
d6223be9 AC |
33 | end |
34 | ||
35 | fun lookupKind id = | |
36 | let | |
37 | val c = getDb () | |
38 | in | |
39 | (case C.oneOrNoRows c ($`SELECT id, name, url, urlPrefix, urlPostfix FROM ContactKind WHERE id = ^(C.intToSql id)`) of | |
40 | NONE => raise Fail "Contact kind not found" | |
41 | | SOME r => mkKindRow r) | |
42 | end | |
43 | ||
44 | fun modKind (kind : kind) = | |
45 | let | |
46 | val db = getDb () | |
47 | in | |
48 | ignore (C.dml db ($`UPDATE ContactKind | |
49 | SET name = ^(C.stringToSql (#name kind)), ^(makerToSqlUpd (#makeUrl kind)) | |
50 | WHERE id = ^(C.intToSql (#id kind))`)) | |
51 | end | |
52 | ||
53 | fun deleteKind id = | |
54 | ignore (C.dml (getDb ()) ($`DELETE FROM ContactKind WHERE id = ^(C.intToSql id)`)) | |
55 | ||
56 | fun listKinds () = | |
57 | C.map (getDb ()) mkKindRow ($`SELECT id, name, url, urlPrefix, urlPostfix FROM ContactKind | |
58 | ORDER BY name`) | |
59 | ||
ee587f7f AC |
60 | (* Managing contact entries *) |
61 | ||
62 | datatype priv = | |
63 | PUBLIC | |
64 | | MEMBERS | |
65 | | ADMINS | |
66 | ||
67 | val privFromInt = | |
68 | fn 0 => PUBLIC | |
69 | | 1 => MEMBERS | |
70 | | 2 => ADMINS | |
71 | | _ => raise C.Sql "Bad contact private information" | |
72 | ||
73 | fun privFromSql v = privFromInt (C.intFromSql v) | |
74 | ||
75 | val privToSql = | |
76 | fn PUBLIC => "0" | |
77 | | MEMBERS => "1" | |
78 | | ADMINS => "2" | |
79 | ||
80 | val privToInt = | |
81 | fn PUBLIC => 0 | |
82 | | MEMBERS => 1 | |
83 | | ADMINS => 2 | |
84 | ||
85 | type contact = {id :int, usr : int, knd : int, v : string, priv : priv} | |
86 | ||
87 | fun mkContactRow [id, usr, knd, v, priv] = | |
88 | {id = C.intFromSql id, usr = C.intFromSql usr, knd = C.intFromSql knd, | |
89 | v = C.stringFromSql v, priv = privFromSql priv} | |
90 | | mkContactRow row = Init.rowError ("contact", row) | |
91 | ||
92 | fun addContact (usr, knd, v, priv) = | |
93 | let | |
94 | val db = getDb () | |
95 | val id = nextSeq (db, "ContactSeq") | |
96 | in | |
97 | C.dml db ($`INSERT INTO Contact (id, usr, knd, v, priv) | |
98 | VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql knd), ^(C.stringToSql v), ^(privToSql priv))`); | |
99 | id | |
100 | end | |
101 | ||
102 | fun lookupContact id = | |
103 | let | |
104 | val c = getDb () | |
105 | in | |
6e8dc436 | 106 | (case C.oneOrNoRows c ($`SELECT id, usr, knd, v, priv FROM Contact WHERE id = ^(C.intToSql id)`) of |
ee587f7f AC |
107 | NONE => raise Fail "Contact not found" |
108 | | SOME r => mkContactRow r) | |
109 | end | |
110 | ||
111 | fun modContact (ct : contact) = | |
112 | let | |
113 | val db = getDb () | |
114 | in | |
115 | ignore (C.dml db ($`UPDATE Contact | |
116 | SET usr = ^(C.intToSql (#usr ct)), knd = ^(C.intToSql (#knd ct)), | |
117 | v = ^(C.stringToSql (#v ct)), priv = ^(privToSql (#priv ct)) | |
118 | WHERE id = ^(C.intToSql (#id ct))`)) | |
119 | end | |
120 | ||
121 | fun deleteContact id = | |
122 | ignore (C.dml (getDb ()) ($`DELETE FROM Contact WHERE id = ^(C.intToSql id)`)) | |
123 | ||
124 | fun mkUserContactRow r = | |
125 | if length r >= 5 then | |
126 | (mkKindRow (List.take (r, 5)), mkContactRow (List.drop (r, 5))) | |
127 | else | |
128 | Init.rowError ("kind/contact", r) | |
129 | ||
130 | fun listUserContacts (usr, priv) = | |
131 | C.map (getDb ()) mkUserContactRow ($`SELECT ContactKind.id, name, url, urlPrefix, urlPostfix, Contact.id, usr, knd, v, priv | |
132 | FROM Contact JOIN ContactKind ON knd = ContactKind.id | |
133 | WHERE usr = ^(C.intToSql usr) | |
134 | AND priv <= ^(privToSql priv) | |
135 | ORDER BY name, v`) | |
136 | ||
6e8dc436 AC |
137 | fun mkKindContactRow r = |
138 | case r of | |
139 | name :: rest => (C.stringFromSql name, mkContactRow rest) | |
140 | | _ => Init.rowError ("name/contact", r) | |
141 | ||
142 | fun listContactsByKind (knd, priv) = | |
143 | C.map (getDb ()) mkKindContactRow ($`SELECT name, Contact.id, usr, knd, v, priv | |
144 | FROM Contact JOIN WebUser ON WebUser.id = usr | |
145 | WHERE knd = ^(C.intToSql knd) | |
146 | AND priv <= ^(privToSql priv) | |
147 | ORDER BY name`) | |
148 | ||
ee587f7f AC |
149 | fun format (kind : kind, cont : contact) = |
150 | case #makeUrl kind of | |
151 | SOME (pre, post) => String.concat ["<a href=\"", pre, Web.html (#v cont), post, "\">", Web.html (#v cont), "</a>"] | |
152 | | NONE => Web.html (#v cont) | |
153 | ||
d6223be9 | 154 | end |