46b0c2df |
1 | structure Contact :> CONTACT = |
2 | struct |
3 | |
4 | open Util Sql Init |
5 | |
6 | |
369e1577 |
7 | (* Managing kinds *) |
46b0c2df |
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)} |
369e1577 |
23 | | mkKindRow row = Init.rowError ("kind", row) |
46b0c2df |
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) |
369e1577 |
31 | VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(makerToSql makeUrl))`); |
32 | id |
46b0c2df |
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 | |
369e1577 |
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 |
45f95cf5 |
106 | (case C.oneOrNoRows c ($`SELECT id, usr, knd, v, priv FROM Contact WHERE id = ^(C.intToSql id)`) of |
369e1577 |
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 | |
45f95cf5 |
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 | |
369e1577 |
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 | |
46b0c2df |
154 | end |