From ee587f7fc73f657e8c2c02d622f80069291229a5 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 15 Apr 2005 17:14:46 +0000 Subject: [PATCH] Changed to use new smlsql interface --- balance.sml | 6 ++-- contact.mlt | 48 +++++++++++++++++++++++++--- contact.sig | 17 ++++++++++ contact.sml | 90 ++++++++++++++++++++++++++++++++++++++++++++++++++--- exn.mlt | 8 +++-- group.sml | 12 +++---- init.sig | 6 ++-- init.sml | 16 +++++++--- money.sml | 24 +++++++------- poll.sml | 32 ++++++++++--------- tables.sql | 5 +-- 11 files changed, 209 insertions(+), 55 deletions(-) rewrite contact.mlt (95%) diff --git a/balance.sml b/balance.sml index b2e905c..7b25933 100644 --- a/balance.sml +++ b/balance.sml @@ -10,7 +10,7 @@ type balance = {id :int, name : string, amount : real} fun mkBalanceRow [id, name, amount] = {id = C.intFromSql id, name = C.stringFromSql name, amount = C.realFromSql amount} - | mkBalanceRow row = raise Fail ("Bad balance row : " ^ makeSet id row) + | mkBalanceRow row = Init.rowError ("balance", row) fun addBalance name = let @@ -18,8 +18,8 @@ fun addBalance name = val id = nextSeq (db, "BalanceSeq") in C.dml db ($`INSERT INTO Balance (id, name, amount) - VALUES (^id, ^(C.stringToSql name), 0.0)`); - C.intFromSql id + VALUES (^(C.intToSql id), ^(C.stringToSql name), 0.0)`); + id end fun lookupBalance id = diff --git a/contact.mlt b/contact.mlt dissimilarity index 95% index 0dc61d4..75b6978 100644 --- a/contact.mlt +++ b/contact.mlt @@ -1,5 +1,43 @@ -<% @header[("title", ["Contact information"])] %> - - - -<% @footer[] %> \ No newline at end of file +<% @header[("title", ["Contact information"])]; + +ref showNormal = true; + +if $"cmd" = "add" then + val id = Contact.addContact (Init.getUserId(), Web.stoi ($"knd"), $"v", Contact.privFromInt (Web.stoi ($"priv"))) %> +

Contact added

+<% end; + +if showNormal then %> + +

Add new contact information

+ + + +

Your contact information

+ + +<% foreach (kind, cont) in Contact.listUserContacts (Init.getUserId(), Contact.ADMINS) do %> + + +<% end %> +

<% Web.html (#name kind) %>:

<% Contact.format (kind, cont) %>

+ +<% end %> + +<% @footer[] %> \ No newline at end of file diff --git a/contact.sig b/contact.sig index 8d7a2eb..1fb0454 100644 --- a/contact.sig +++ b/contact.sig @@ -7,4 +7,21 @@ sig val modKind : kind -> unit val deleteKind : int -> unit val listKinds : unit -> kind list + + datatype priv = + PUBLIC + | MEMBERS + | ADMINS + val privToInt : priv -> int + val privFromInt : int -> priv + + type contact = {id :int, usr : int, knd : int, v : string, priv : priv} + + val addContact : int * int * string * priv -> int + val lookupContact : int -> contact + val modContact : contact -> unit + val deleteContact : int -> unit + val listUserContacts : int * priv -> (kind * contact) list + + val format : kind * contact -> string end \ No newline at end of file diff --git a/contact.sml b/contact.sml index 2214ead..345ab51 100644 --- 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,86 @@ 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 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 format (kind : kind, cont : contact) = + case #makeUrl kind of + SOME (pre, post) => String.concat ["", Web.html (#v cont), ""] + | NONE => Web.html (#v cont) + end \ No newline at end of file diff --git a/exn.mlt b/exn.mlt index e645be1..efb7dfb 100644 --- a/exn.mlt +++ b/exn.mlt @@ -1,4 +1,8 @@ -<% @header [("title", ["Exception"])] %> + +Hcoop Portal: Exception + + +

Exception

<% switch Web.getExn () of Fail msg => %> @@ -16,4 +20,4 @@ <% end end %> -<% @footer [] %> + diff --git a/group.sml b/group.sml index 8bad77f..7c24bbc 100644 --- a/group.sml +++ b/group.sml @@ -10,7 +10,7 @@ type group = {id :int, name : string} fun mkGroupRow [id, name] = {id = C.intFromSql id, name = C.stringFromSql name} - | mkGroupRow row = raise Fail ("Bad group row : " ^ makeSet id row) + | mkGroupRow row = Init.rowError ("group", row) fun addGroup name = let @@ -18,8 +18,8 @@ fun addGroup name = val id = nextSeq (db, "WebGroupSeq") in C.dml db ($`INSERT INTO WebGroup (id, name) - VALUES (^id, ^(C.stringToSql name))`); - C.intFromSql id + VALUES (^(C.intToSql id), ^(C.stringToSql name))`); + id end fun lookupGroup id = @@ -57,7 +57,7 @@ fun userInGroupNum (usr, grp) = FROM Membership WHERE grp = ^(C.intToSql grp) AND usr = ^(C.intToSql usr)`) of - SOME[x] => x <> "0" + SOME[x] => not (C.isNull x) andalso C.intFromSql x <> 0 | _ => false) end @@ -70,7 +70,7 @@ fun userInGroupName (usr, grp) = WHERE name = ^(C.stringToSql grp) AND usr = ^(C.intToSql usr) AND grp = id`) of - SOME[x] => x <> "0" + SOME[x] => not (C.isNull x) andalso C.intFromSql x <> 0 | _ => false) end @@ -106,7 +106,7 @@ fun removeFromGroup (mem : membership) = fun mkMembershipRow [grp, usr] = {grp = C.intFromSql grp, usr = C.intFromSql usr} - | mkMembershipRow row = raise Fail ("Bad membership row : " ^ makeSet id row) + | mkMembershipRow row = Init.rowError ("membership", row) fun groupMembers grp = C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined FROM Membership, WebUser diff --git a/init.sig b/init.sig index 4746bf2..08c29dd 100644 --- a/init.sig +++ b/init.sig @@ -5,13 +5,15 @@ signature INIT = sig type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp} - val mkUserRow : string list -> user + val rowError : string * C.value list -> 'a + + val mkUserRow : C.value list -> user (* Open or close a session, wrapped in a transaction *) val init : unit -> unit val done : unit -> unit - val nextSeq : C.conn * string -> string + val nextSeq : C.conn * string -> int (* Fun with users *) diff --git a/init.sml b/init.sml index 390b9a8..e0a9bb3 100644 --- a/init.sml +++ b/init.sml @@ -14,12 +14,20 @@ type user = {id : int, name : string, rname : string, bal : int, joined : C.time val db = ref (NONE : C.conn option) val user = ref (NONE : user option) +fun fromSql v = + if C.isNull v then + "NULL" + else + C.stringFromSql v + +fun rowError (tab, vs) = raise Fail ("Bad " ^ tab ^ "row: " ^ makeSet fromSql vs) + fun getDb () = valOf (!db) fun mkUserRow [id, name, rname, bal, joined] = {id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname, bal = C.intFromSql bal, joined = C.timestampFromSql joined} - | mkUserRow row = raise Fail ("Bad user row : " ^ makeSet id row) + | mkUserRow row = rowError ("user", row) fun init () = let @@ -61,7 +69,7 @@ fun listUsers () = fun nextSeq (db, seq) = case C.oneRow db ($`SELECT nextval('^(seq)')`) of - [id] => id + [id] => C.intFromSql id | _ => raise Fail "Bad next sequence val" fun addUser (name, rname, bal) = @@ -70,8 +78,8 @@ fun addUser (name, rname, bal) = val id = nextSeq (db, "WebUserSeq") in C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined) - VALUES (^id, ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal), CURRENT_TIMESTAMP)`); - C.intFromSql id + VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal), CURRENT_TIMESTAMP)`); + id end fun modUser (user : user) = diff --git a/money.sml b/money.sml index b5b20f1..056b051 100644 --- a/money.sml +++ b/money.sml @@ -11,7 +11,7 @@ type transaction = {id :int, descr : string, amount : real, d : string, stamp : fun mkTransactionRow [id, descr, amount, d, stamp] = {id = C.intFromSql id, descr = C.stringFromSql descr, amount = C.realFromSql amount, d = C.stringFromSql d, stamp = C.timestampFromSql stamp} - | mkTransactionRow row = raise Fail ("Bad transaction row : " ^ makeSet id row) + | mkTransactionRow row = Init.rowError ("transaction", row) fun addTransaction (descr, amount, d) = let @@ -19,8 +19,8 @@ fun addTransaction (descr, amount, d) = val id = nextSeq (db, "TransactionSeq") in C.dml db ($`INSERT INTO Transaction (id, descr, amount, d, stamp) - VALUES (^id, ^(C.stringToSql descr), ^(C.realToSql amount), ^(C.stringToSql d), CURRENT_TIMESTAMP)`); - C.intFromSql id + VALUES (^(C.intToSql id), ^(C.stringToSql descr), ^(C.realToSql amount), ^(C.stringToSql d), CURRENT_TIMESTAMP)`); + id end fun lookupTransaction id = @@ -83,7 +83,7 @@ val mkUserRow' = fn (trn :: rest) => (if C.isNull trn then false else true, mkUserRow rest) - | row => raise Fail ("Bad listUsers row: " ^ makeSet id row) + | row => Init.rowError ("listUsers", row) fun listUsers trn = C.map (getDb ()) mkUserRow' ($`SELECT trn, id, name, rname, bal, joined @@ -97,7 +97,7 @@ type charge = {trn : int, usr : int, amount : real} fun mkChargeRow [trn, usr, amount] = {trn = C.intFromSql trn, usr = C.intFromSql usr, amount = C.realFromSql amount} - | mkChargeRow row = raise Fail ("Bad charge row : " ^ makeSet id row) + | mkChargeRow row = Init.rowError ("charge", row) fun addCharge {trn, usr, amount} = ignore (C.dml (getDb ()) ($`INSERT INTO Charge (trn, usr, amount) @@ -109,7 +109,7 @@ fun listCharges trn = val mkChargeRow' = fn (name :: rest) => (C.stringFromSql name, mkChargeRow rest) - | row => raise Fail ("Bad name+charge row: " ^ makeSet id row) + | row => Init.rowError ("name+charge", row) fun listChargesWithNames trn = C.map (getDb ()) mkChargeRow' ($`SELECT name, trn, usr, amount FROM Charge, WebUser @@ -126,9 +126,9 @@ fun clearCharges trn = fun clearCharge [bal, amount] = ignore (C.dml db ($`UPDATE Balance - SET amount = amount - ^amount - WHERE id = ^bal`)) - | clearCharge row = raise Fail ("Bad clearCharge row : " ^ makeSet id row) + SET amount = amount - ^(C.stringFromSql amount) + WHERE id = ^(C.stringFromSql bal)`)) + | clearCharge row = Init.rowError ("clearCharge", row) in C.app db clearCharge ($`SELECT bal, SUM(amount) FROM Charge, WebUser WHERE trn = ^(C.intToSql trn) @@ -143,9 +143,9 @@ fun applyCharges trn = fun applyCharge [bal, amount] = ignore (C.dml db ($`UPDATE Balance - SET amount = amount + ^amount - WHERE id = ^bal`)) - | applyCharge row = raise Fail ("Bad applyCharge row : " ^ makeSet id row) + SET amount = amount + ^(C.stringFromSql amount) + WHERE id = ^(C.stringFromSql bal)`)) + | applyCharge row = Init.rowError ("applyCharge", row) in C.app db applyCharge ($`SELECT bal, SUM(amount) FROM Charge, WebUser WHERE trn = ^(C.intToSql trn) diff --git a/poll.sml b/poll.sml index 2800d98..987c5e2 100644 --- a/poll.sml +++ b/poll.sml @@ -9,7 +9,7 @@ fun mkPollRow [id, usr, title, descr, starts, ends, votes] = {id = C.intFromSql id, usr = C.intFromSql usr, title = C.stringFromSql title, descr = C.stringFromSql descr, starts = C.stringFromSql starts, ends = C.stringFromSql ends, votes = C.intFromSql votes} - | mkPollRow row = raise Fail ("Bad poll row : " ^ makeSet id row) + | mkPollRow row = Init.rowError ("poll", row) fun lookupPoll id = case C.oneOrNoRows (getDb ()) ($`SELECT id, usr, title, descr, starts, ends, votes @@ -42,9 +42,9 @@ fun addPoll (usr, title, descr, starts, ends, votes) = val id = nextSeq (db, "PollSeq") in C.dml db ($`INSERT INTO Poll (id, usr, title, descr, starts, ends, votes) - VALUES (^id, ^(C.intToSql usr), ^(C.stringToSql title), ^(C.stringToSql descr), + VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.stringToSql title), ^(C.stringToSql descr), ^(C.stringToSql starts), ^(C.stringToSql ends), ^(C.intToSql votes))`); - C.intFromSql id + id end fun modPoll (poll : poll) = @@ -70,7 +70,7 @@ type choice = {id : int, pol : int, seq : real, descr : string} fun mkChoiceRow [id, pol, seq, descr] = {id = C.intFromSql id, pol = C.intFromSql pol, seq = C.realFromSql seq, descr = C.stringFromSql descr} - | mkChoiceRow row = raise Fail ("Bad choice row : " ^ makeSet id row) + | mkChoiceRow row = Init.rowError ("choice", row) fun lookupChoice id = case C.oneOrNoRows (getDb ()) ($`SELECT id, pol, seq, descr @@ -86,8 +86,9 @@ fun listChoices pol = ORDER BY seq`) val mkChoiceRow' = - fn (yours :: total :: rest) => (yours <> "0", if C.isNull total then 0 else C.intFromSql total, mkChoiceRow rest) - | row => raise Fail ("Bad choice' row: " ^ makeSet id row) + fn (yours :: total :: rest) => (not (C.isNull yours) andalso C.intFromSql yours <> 0, + if C.isNull total then 0 else C.intFromSql total, mkChoiceRow rest) + | row => Init.rowError ("choice'", row) fun listChoicesWithVotes pol = C.map (getDb ()) mkChoiceRow' ($`SELECT (SELECT COUNT( * ) FROM Vote V WHERE V.cho = id AND V.usr = ^(C.intToSql (Init.getUserId ()))), @@ -97,8 +98,9 @@ fun listChoicesWithVotes pol = ORDER BY total DESC, seq`) val mkChoiceRow'' = - fn (yours :: rest) => (yours <> "0", mkChoiceRow rest) - | row => raise Fail ("Bad choice'' row: " ^ makeSet id row) + fn (yours :: rest) => (not (C.isNull yours) andalso C.intFromSql yours <> 0, + mkChoiceRow rest) + | row => Init.rowError ("choice''", row) fun listChoicesWithMyVotes pol = C.map (getDb ()) mkChoiceRow'' ($`SELECT (SELECT COUNT( * ) FROM Vote V WHERE V.cho = id AND V.usr = ^(C.intToSql (Init.getUserId ()))), @@ -113,8 +115,8 @@ fun addChoice (pol, seq, descr) = val id = nextSeq (db, "PollChoiceSeq") in C.dml db ($`INSERT INTO PollChoice (id, pol, seq, descr) - VALUES (^id, ^(C.intToSql pol), ^(C.realToSql seq), ^(C.stringToSql descr))`); - C.intFromSql id + VALUES (^(C.intToSql id), ^(C.intToSql pol), ^(C.realToSql seq), ^(C.stringToSql descr))`); + id end fun modChoice (choice : choice) = @@ -150,22 +152,22 @@ fun vote (usr, pol, chos) = fun dateLe (d1, d2) = case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM DATE ^(C.stringToSql d1)) <= EXTRACT(EPOCH FROM DATE ^(C.stringToSql d2)))`) of [res] => C.boolFromSql res - | row => raise Fail ("Bad dateLe row: " ^ makeSet id row) + | row => Init.rowError ("dateLe", row) fun dateGeNow d = case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM CURRENT_DATE) <= EXTRACT(EPOCH FROM DATE ^(C.stringToSql d)))`) of [res] => C.boolFromSql res - | row => raise Fail ("Bad dateGeNow row: " ^ makeSet id row) + | row => Init.rowError ("dateGeNow", row) fun dateLeNow d = case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM CURRENT_DATE) >= EXTRACT(EPOCH FROM DATE ^(C.stringToSql d)))`) of [res] => C.boolFromSql res - | row => raise Fail ("Bad dateLeNow row: " ^ makeSet id row) + | row => Init.rowError ("dateLeNow", row) fun dateLtNow d = case C.oneRow (getDb ()) ($`SELECT (EXTRACT(EPOCH FROM CURRENT_DATE) > EXTRACT(EPOCH FROM DATE ^(C.stringToSql d)))`) of [res] => C.boolFromSql res - | row => raise Fail ("Bad dateLtNow row: " ^ makeSet id row) + | row => Init.rowError ("dateLtNow", row) fun canModify (poll : poll) = Group.inGroupName "poll" @@ -183,7 +185,7 @@ fun nextSeq pol = FROM PollChoice WHERE pol = ^(C.intToSql pol)`) of [max] => if C.isNull max then 1.0 else C.realFromSql max - | row => raise Fail ("Bad nextSeq row: " ^ makeSet id row) + | row => Init.rowError ("nextSeq", row) fun takingVotes (poll : poll) = dateLeNow (#starts poll) andalso dateGeNow (#ends poll) diff --git a/tables.sql b/tables.sql index 5481e29..df2d5be 100644 --- a/tables.sql +++ b/tables.sql @@ -111,11 +111,12 @@ CREATE TABLE ContactKind( CREATE SEQUENCE ContactKindSeq START 1; CREATE TABLE Contact( + id INTEGER PRIMARY KEY, usr INTEGER NOT NULL, knd INTEGER NOT NULL, v TEXT NOT NULL, priv INTEGER NOT NULL, - PRIMARY KEY (usr, knd), FOREIGN KEY (usr) REFERENCES WebUser(id) ON DELETE CASCADE, FOREIGN KEY (knd) REFERENCES ContactKind(id) ON DELETE CASCADE); - \ No newline at end of file + +CREATE SEQUENCE ContactSeq START 1; -- 2.20.1

Kind:
Value:
Readable by: