cvsimport

[hcoop/zz_old/portal.git] / contact.sml

diff --git a/contact.sml b/contact.sml
index 2214ead..3c3698d 100644 (file)
--- a/contact.sml
+++ b/contact.sml
@@ -4,7 +4,7 @@ struct
 open Util Sql Init
 
 
-(* Managing transactions *)
+(* Managing kinds *)
 
 type kind = {id :int, name : string, makeUrl : (string * string) option}
 
@@ -20,7 +20,7 @@ fun mkKindRow [id, name, url, urlPrefix, urlPostfix] =
                    SOME (C.stringFromSql urlPrefix, C.stringFromSql urlPostfix)
                else
                    NONE)}
-  | mkKindRow row = raise Fail ("Bad kind row : " ^ makeSet id row)
+  | mkKindRow row = Init.rowError ("kind", row)
 
 fun addKind (name, makeUrl) =
     let
@@ -28,8 +28,8 @@ fun addKind (name, makeUrl) =
        val id = nextSeq (db, "ContactKindSeq")
     in
        C.dml db ($`INSERT INTO ContactKind (id, name, url, urlPrefix, urlPostfix)
-                    VALUES (^id, ^(C.stringToSql name), ^(makerToSql makeUrl))`);
-       C.intFromSql id
+                    VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(makerToSql makeUrl))`);
+       id
     end
 
 fun lookupKind id =
@@ -57,4 +57,98 @@ fun listKinds () =
     C.map (getDb ()) mkKindRow ($`SELECT id, name, url, urlPrefix, urlPostfix FROM ContactKind
                                  ORDER BY name`)
 
+(* Managing contact entries *)
+
+datatype priv =
+        PUBLIC
+       | MEMBERS
+       | ADMINS
+
+val privFromInt =
+    fn 0 => PUBLIC
+     | 1 => MEMBERS
+     | 2 => ADMINS
+     | _ => raise C.Sql "Bad contact private information"
+
+fun privFromSql v = privFromInt (C.intFromSql v)
+
+val privToSql =
+    fn PUBLIC => "0"
+     | MEMBERS => "1"
+     | ADMINS => "2"
+
+val privToInt =
+    fn PUBLIC => 0
+     | MEMBERS => 1
+     | ADMINS => 2
+
+type contact = {id :int, usr : int, knd : int, v : string, priv : priv}
+
+fun mkContactRow [id, usr, knd, v, priv] =
+    {id = C.intFromSql id, usr = C.intFromSql usr, knd = C.intFromSql knd,
+     v = C.stringFromSql v, priv = privFromSql priv}
+  | mkContactRow row = Init.rowError ("contact", row)
+
+fun addContact (usr, knd, v, priv) =
+    let
+       val db = getDb ()
+       val id = nextSeq (db, "ContactSeq")
+    in
+       C.dml db ($`INSERT INTO Contact (id, usr, knd, v, priv)
+                    VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql knd), ^(C.stringToSql v), ^(privToSql priv))`);
+       id
+    end
+
+fun lookupContact id =
+    let
+       val c = getDb ()
+    in
+       (case C.oneOrNoRows c ($`SELECT id, usr, knd, v, priv FROM Contact WHERE id = ^(C.intToSql id)`) of
+            NONE => raise Fail "Contact not found"
+          | SOME r => mkContactRow r)
+    end
+
+fun modContact (ct : contact) =
+    let
+       val db = getDb ()
+    in
+       ignore (C.dml db ($`UPDATE Contact
+                           SET usr = ^(C.intToSql (#usr ct)), knd = ^(C.intToSql (#knd ct)),
+                              v = ^(C.stringToSql (#v ct)), priv = ^(privToSql (#priv ct))
+                           WHERE id = ^(C.intToSql (#id ct))`))
+    end
+
+fun deleteContact id =
+    ignore (C.dml (getDb ()) ($`DELETE FROM Contact WHERE id = ^(C.intToSql id)`))
+
+fun mkUserContactRow r =
+    if length r >= 5 then
+       (mkKindRow (List.take (r, 5)), mkContactRow (List.drop (r, 5)))
+    else
+       Init.rowError ("kind/contact", r)
+
+fun listUserContacts (usr, priv) =
+    C.map (getDb ()) mkUserContactRow ($`SELECT ContactKind.id, name, url, urlPrefix, urlPostfix, Contact.id, usr, knd, v, priv
+                                        FROM Contact JOIN ContactKind ON knd = ContactKind.id
+                                        WHERE usr = ^(C.intToSql usr)
+                                           AND priv <= ^(privToSql priv)
+                                        ORDER BY name, v`)
+
+fun mkKindContactRow r =
+    case r of
+       name :: rest => (C.stringFromSql name, mkContactRow rest)
+      | _ => Init.rowError ("name/contact", r)
+
+fun listContactsByKind (knd, priv) =
+    C.map (getDb ()) mkKindContactRow ($`SELECT name, Contact.id, usr, knd, v, priv
+                                        FROM Contact JOIN WebUser ON WebUser.id = usr
+                                        WHERE knd = ^(C.intToSql knd)
+                                           AND priv <= ^(privToSql priv)
+                                        ORDER BY name`)
+
+fun format (kind : kind, cont : contact) =
+    case #makeUrl kind of
+       SOME (pre, post) => String.concat ["<a href=\"", pre, Web.html (#v cont), post, "\">", Web.html (#v cont), "</a>"]
+      | NONE => Web.html (#v cont)
+
 end
\ No newline at end of file