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
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 =
-<% @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"))) %>
+ <h3><b>Contact added</b></h3>
+<% end;
+
+if showNormal then %>
+
+<h3><b>Add new contact information</b></h3>
+
+<form action="contact">
+<input type="hidden" name="cmd" value="add">
+<table>
+<tr> <td align="right"><b>Kind</b>:</td> <td><select name="knd">
+<% foreach kind in Contact.listKinds () do %>
+ <option value="<% #id kind %>"><% Web.html (#name kind) %></option>
+<% end %>
+</select></td> </tr>
+<tr> <td align="right"><b>Value</b>:</td> <td><input name="v"></td> </tr>
+<tr> <td align="right"><b>Readable by</b>:</td> <td><select name="priv">
+ <option value="0">Anyone</option>
+ <option value="1" selected>Members only</option>
+ <option value="2">Admins only</option>
+</select></td> </tr>
+<tr> <td><input type="submit" value="Add"></td> </tr>
+</table>
+</form>
+
+<h3><b>Your contact information</b></h3>
+
+<table>
+<% foreach (kind, cont) in Contact.listUserContacts (Init.getUserId(), Contact.ADMINS) do %>
+ <tr> <td align="right" valign="top"><b><% Web.html (#name kind) %></b>:</td>
+ <td><% Contact.format (kind, cont) %></td> </tr>
+<% end %>
+</table>
+
+<% end %>
+
+<% @footer[] %>
\ No newline at end of file
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
open Util Sql Init
-(* Managing transactions *)
+(* Managing kinds *)
type kind = {id :int, name : string, makeUrl : (string * string) option}
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
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 =
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 ["<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
-<% @header [("title", ["Exception"])] %>
+<html><head>
+<title>Hcoop Portal: Exception</title>
+</head><body>
+
+<h1><b>Exception</b></h1>
<% switch Web.getExn () of
Fail msg => %>
<% end
end %>
-<% @footer [] %>
+</body></html>
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
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 =
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
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
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
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 *)
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
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) =
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) =
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
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 =
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
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)
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
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)
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)
{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
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) =
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
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 ()))),
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 ()))),
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) =
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"
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)
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;
HCoop / hcoop / zz_old / portal.git / commitdiff