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