1 structure Contact
:> CONTACT
=
9 type kind
= {id
:int, name
: string, makeUrl
: (string * string) option
}
11 fun makerToSql NONE
= "FALSE, NULL, NULL"
12 |
makerToSql (SOME (pre
, post
)) = $`TRUE
, ^
(C
.stringToSql pre
), ^
(C
.stringToSql post
)`
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
)`
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
)
23 | mkKindRow row
= Init
.rowError ("kind", row
)
25 fun addKind (name
, makeUrl
) =
28 val id
= nextSeq (db
, "ContactKindSeq")
30 C
.dml
db ($`INSERT INTO
ContactKind (id
, name
, url
, urlPrefix
, urlPostfix
)
31 VALUES (^
(C
.intToSql id
), ^
(C
.stringToSql name
), ^
(makerToSql makeUrl
))`
);
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
)
44 fun modKind (kind
: kind
) =
48 ignore (C
.dml
db ($`UPDATE ContactKind
49 SET name
= ^
(C
.stringToSql (#name kind
)), ^
(makerToSqlUpd (#makeUrl kind
))
50 WHERE id
= ^
(C
.intToSql (#id kind
))`
))
54 ignore (C
.dml (getDb ()) ($`DELETE FROM ContactKind WHERE id
= ^
(C
.intToSql id
)`
))
57 C
.map (getDb ()) mkKindRow ($`SELECT id
, name
, url
, urlPrefix
, urlPostfix FROM ContactKind
60 (* Managing contact entries
*)
71 | _
=> raise C
.Sql
"Bad contact private information"
73 fun privFromSql v
= privFromInt (C
.intFromSql v
)
85 type contact
= {id
:int, usr
: int, knd
: int, v
: string, priv
: priv
}
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
)
92 fun addContact (usr
, knd
, v
, priv
) =
95 val id
= nextSeq (db
, "ContactSeq")
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
))`
);
102 fun lookupContact id
=
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
)
111 fun modContact (ct
: contact
) =
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
))`
))
121 fun deleteContact id
=
122 ignore (C
.dml (getDb ()) ($`DELETE FROM Contact WHERE id
= ^
(C
.intToSql id
)`
))
124 fun mkUserContactRow r
=
125 if length r
>= 5 then
126 (mkKindRow (List.take (r
, 5)), mkContactRow (List.drop (r
, 5)))
128 Init
.rowError ("kind/contact", r
)
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
)
137 fun mkKindContactRow r
=
139 name
:: rest
=> (C
.stringFromSql name
, mkContactRow rest
)
140 | _
=> Init
.rowError ("name/contact", r
)
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
)
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
)