Contact kind administration

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

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