Contact kind administration

[hcoop/portal.git] / contact.sml

diff --git a/contact.sml b/contact.sml
new file mode 100644 (file)
index 0000000..2214ead
--- /dev/null
+++ b/contact.sml
@@ -0,0 +1,60 @@
+structure Contact :> CONTACT =
+struct
+
+open Util Sql Init
+
+
+(* Managing transactions *)
+
+type kind = {id :int, name : string, makeUrl : (string * string) option}
+
+fun makerToSql NONE = "FALSE, NULL, NULL"
+  | makerToSql (SOME (pre, post)) = $`TRUE, ^(C.stringToSql pre), ^(C.stringToSql post)`
+
+fun makerToSqlUpd NONE = "url = FALSE, urlPrefix = NULL, urlPostfix = NULL"
+  | makerToSqlUpd (SOME (pre, post)) = $`url = TRUE, urlPrefix = ^(C.stringToSql pre), urlPostfix = ^(C.stringToSql post)`
+
+fun mkKindRow [id, name, url, urlPrefix, urlPostfix] =
+    {id = C.intFromSql id, name = C.stringFromSql name, 
+     makeUrl = (if C.boolFromSql url then
+                   SOME (C.stringFromSql urlPrefix, C.stringFromSql urlPostfix)
+               else
+                   NONE)}
+  | mkKindRow row = raise Fail ("Bad kind row : " ^ makeSet id row)
+
+fun addKind (name, makeUrl) =
+    let
+       val db = getDb ()
+       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
+    end
+
+fun lookupKind id =
+    let
+       val c = getDb ()
+    in
+       (case C.oneOrNoRows c ($`SELECT id, name, url, urlPrefix, urlPostfix FROM ContactKind WHERE id = ^(C.intToSql id)`) of
+            NONE => raise Fail "Contact kind not found"
+          | SOME r => mkKindRow r)
+    end
+
+fun modKind (kind : kind) =
+    let
+       val db = getDb ()
+    in
+       ignore (C.dml db ($`UPDATE ContactKind
+                           SET name = ^(C.stringToSql (#name kind)), ^(makerToSqlUpd (#makeUrl kind))
+                           WHERE id = ^(C.intToSql (#id kind))`))
+    end
+
+fun deleteKind id =
+    ignore (C.dml (getDb ()) ($`DELETE FROM ContactKind WHERE id = ^(C.intToSql id)`))
+
+fun listKinds () =
+    C.map (getDb ()) mkKindRow ($`SELECT id, name, url, urlPrefix, urlPostfix FROM ContactKind
+                                 ORDER BY name`)
+
+end
\ No newline at end of file