contact.sml

   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