You can subscribe to this list here.
2007 |
Jan
|
Feb
(23) |
Mar
(4) |
Apr
(60) |
May
(80) |
Jun
(24) |
Jul
(12) |
Aug
(12) |
Sep
(27) |
Oct
(59) |
Nov
(152) |
Dec
(135) |
---|---|---|---|---|---|---|---|---|---|---|---|---|
2008 |
Jan
(19) |
Feb
(41) |
Mar
(8) |
Apr
(12) |
May
(14) |
Jun
(8) |
Jul
(23) |
Aug
(3) |
Sep
(1) |
Oct
|
Nov
(2) |
Dec
(1) |
2009 |
Jan
(1) |
Feb
(8) |
Mar
(6) |
Apr
(9) |
May
(2) |
Jun
|
Jul
(2) |
Aug
(2) |
Sep
(9) |
Oct
|
Nov
(3) |
Dec
|
2010 |
Jan
(2) |
Feb
(4) |
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
(1) |
Nov
|
Dec
|
Update of /cvsroot/hcoop/portal In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv3576 Modified Files: header.mlt.in request.sig request.sml requestH.sig requestH.sml support.sml tables.sql Added Files: qos.mlt qos.sig qos.sml Log Message: Summary of recent support requests with response times Index: request.sml =================================================================== RCS file: /cvsroot/hcoop/portal/request.sml,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** request.sml 24 Sep 2005 17:51:37 -0000 1.4 --- request.sml 25 Feb 2007 23:57:45 -0000 1.5 *************** *** 12,16 **** | REJECTED ! type request = { id : int, usr : int, data : string, msg : string, status : status, stamp : C.timestamp } val statusFromInt = --- 12,17 ---- | REJECTED ! type request = { id : int, usr : int, data : string, msg : string, status : status, ! stamp : C.timestamp, cstamp : C.timestamp option } val statusFromInt = *************** *** 28,34 **** fun statusToSql s = C.intToSql (statusToInt s) ! fun mkRow [id, usr, data, msg, status, stamp] = {id = C.intFromSql id, usr = C.intFromSql usr, data = C.stringFromSql data, ! msg = C.stringFromSql msg, status = statusFromSql status, stamp = C.timestampFromSql stamp} | mkRow r = rowError ("APT request", r) --- 29,36 ---- fun statusToSql s = C.intToSql (statusToInt s) ! fun mkRow [id, usr, data, msg, status, stamp, cstamp] = {id = C.intFromSql id, usr = C.intFromSql usr, data = C.stringFromSql data, ! msg = C.stringFromSql msg, status = statusFromSql status, stamp = C.timestampFromSql stamp, ! cstamp = if C.isNull cstamp then NONE else SOME (C.timestampFromSql cstamp)} | mkRow r = rowError ("APT request", r) *************** *** 38,44 **** val id = nextSeq (db, seq) in ! C.dml db ($`INSERT INTO ^table (id, usr, data, msg, status, stamp) VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.stringToSql data), ^(C.stringToSql msg), ! 0, CURRENT_TIMESTAMP)`); id end --- 40,46 ---- val id = nextSeq (db, seq) in ! C.dml db ($`INSERT INTO ^table (id, usr, data, msg, status, stamp, cstamp) VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.stringToSql data), ^(C.stringToSql msg), ! 0, CURRENT_TIMESTAMP, NULL)`); id end *************** *** 48,51 **** --- 50,57 ---- val db = getDb () in + if #status req <> NEW then + ignore (C.dml db ($`UPDATE ^table SET cstamp = CURRENT_TIMESTAMP WHERE id = ^(C.intToSql (#id req))`)) + else + (); ignore (C.dml db ($`UPDATE ^table SET usr = ^(C.intToSql (#usr req)), data = ^(C.stringToSql (#data req)), *************** *** 58,62 **** fun lookup id = ! case C.oneOrNoRows (getDb ()) ($`SELECT id, usr, data, msg, status, stamp FROM ^table WHERE id = ^(C.intToSql id)`) of --- 64,68 ---- fun lookup id = ! case C.oneOrNoRows (getDb ()) ($`SELECT id, usr, data, msg, status, stamp, cstamp FROM ^table WHERE id = ^(C.intToSql id)`) of *************** *** 68,77 **** fun list () = ! C.map (getDb ()) mkRow' ($`SELECT name, ^table.id, usr, data, msg, status, stamp FROM ^table JOIN WebUser ON usr = WebUser.id ORDER BY stamp DESC`) fun listOpen () = ! C.map (getDb ()) mkRow' ($`SELECT name, ^table.id, usr, data, msg, status, stamp FROM ^table JOIN WebUser ON usr = WebUser.id WHERE status = 0 --- 74,83 ---- fun list () = ! C.map (getDb ()) mkRow' ($`SELECT name, ^table.id, usr, data, msg, status, stamp, cstamp FROM ^table JOIN WebUser ON usr = WebUser.id ORDER BY stamp DESC`) fun listOpen () = ! C.map (getDb ()) mkRow' ($`SELECT name, ^table.id, usr, data, msg, status, stamp, cstamp FROM ^table JOIN WebUser ON usr = WebUser.id WHERE status = 0 Index: tables.sql =================================================================== RCS file: /cvsroot/hcoop/portal/tables.sql,v retrieving revision 1.24 retrieving revision 1.25 diff -C2 -d -r1.24 -r1.25 *** tables.sql 25 Feb 2007 22:49:39 -0000 1.24 --- tables.sql 25 Feb 2007 23:57:45 -0000 1.25 *************** *** 228,231 **** --- 228,232 ---- status INTEGER NOT NULL, stamp TIMESTAMP NOT NULL, + cstamp TIMESTAMP, FOREIGN KEY (usr) REFERENCES WebUser(id) ON DELETE CASCADE, FOREIGN KEY (node) REFERENCES WebNode(id) ON DELETE CASCADE); *************** *** 240,243 **** --- 241,245 ---- status INTEGER NOT NULL, stamp TIMESTAMP NOT NULL, + cstamp TIMESTAMP, FOREIGN KEY (usr) REFERENCES WebUser(id) ON DELETE CASCADE); *************** *** 251,254 **** --- 253,257 ---- status INTEGER NOT NULL, stamp TIMESTAMP NOT NULL, + cstamp TIMESTAMP, FOREIGN KEY (usr) REFERENCES WebUser(id) ON DELETE CASCADE); *************** *** 307,310 **** --- 310,314 ---- status INTEGER NOT NULL, stamp TIMESTAMP NOT NULL, + cstamp TIMESTAMP, FOREIGN KEY (usr) REFERENCES WebUser(id) ON DELETE CASCADE, FOREIGN KEY (node) REFERENCES WebNode(id) ON DELETE CASCADE); Index: header.mlt.in =================================================================== RCS file: /cvsroot/hcoop/portal/header.mlt.in,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** header.mlt.in 18 Feb 2007 01:38:04 -0000 1.3 --- header.mlt.in 25 Feb 2007 23:57:45 -0000 1.4 *************** *** 55,58 **** --- 55,59 ---- <li> <a href="dir">Contact information directory</a></li> <li> <a href="poll">Polls</a></li> + <li> <a href="qos">Support quality statistics</a></li> </div> --- NEW FILE: qos.sml --- structure Qos :> QOS = struct open Util Sql Init type entry = { kind : string, kindUrl : string option, name : string, url : string option, usr : int, uname : string, stamp : C.timestamp, pstamp : C.timestamp option, cstamp : C.timestamp option} fun mkEntryRow [kind, kindUrl, name, url, usr, uname, stamp, pstamp, cstamp] = {kind = C.stringFromSql kind, kindUrl = if C.isNull kindUrl then NONE else SOME (C.stringFromSql kindUrl), name = C.stringFromSql name, url = if C.isNull url then NONE else SOME (C.stringFromSql url), usr = C.intFromSql usr, uname = C.stringFromSql uname, stamp = C.timestampFromSql stamp, pstamp = if C.isNull pstamp then NONE else SOME (C.timestampFromSql pstamp), cstamp = if C.isNull cstamp then NONE else SOME (C.timestampFromSql cstamp)} | mkEntryRow row = rowError ("QOS", row) fun recent days = let val usr = Init.getUserId () val db = getDb () in C.map db mkEntryRow ($`SELECT SupCategory.name, 'issue?cat=' || SupCategory.id, title, 'issue?cat=' || SupCategory.id || '&id=' || SupIssue.id, usr, WebUser.name, stamp, COALESCE(pstamp, cstamp), cstamp FROM SupIssue JOIN SupCategory ON SupCategory.id = cat JOIN WebUser ON WebUser.id = usr WHERE stamp >= CURRENT_TIMESTAMP - interval '^(C.intToSql days) DAYS' AND (NOT priv OR usr = ^(C.intToSql usr) OR (SELECT COUNT(*) FROM Membership WHERE Membership.usr = ^(C.intToSql usr) AND (Membership.grp = 0 OR Membership.grp = SupCategory.grp)) > 0) UNION SELECT 'APT package', NULL, data, NULL, usr, name, stamp, cstamp, cstamp FROM Apt JOIN WebUser ON WebUser.id = usr WHERE stamp >= CURRENT_TIMESTAMP - interval '^(C.intToSql days) DAYS' UNION SELECT 'Domain', NULL, data, NULL, usr, name, stamp, cstamp, cstamp FROM Domain JOIN WebUser ON WebUser.id = usr WHERE stamp >= CURRENT_TIMESTAMP - interval '^(C.intToSql days) DAYS' UNION SELECT 'Mailing list', NULL, data, NULL, usr, name, stamp, cstamp, cstamp FROM MailingList JOIN WebUser ON WebUser.id = usr WHERE stamp >= CURRENT_TIMESTAMP - interval '^(C.intToSql days) DAYS' UNION SELECT 'Security', NULL, data, NULL, usr, name, stamp, cstamp, cstamp FROM Sec JOIN WebUser ON WebUser.id = usr WHERE stamp >= CURRENT_TIMESTAMP - interval '^(C.intToSql days) DAYS' ORDER BY stamp DESC`) end end Index: requestH.sig =================================================================== RCS file: /cvsroot/hcoop/portal/requestH.sig,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** requestH.sig 25 Feb 2007 21:05:26 -0000 1.1 --- requestH.sig 25 Feb 2007 23:57:45 -0000 1.2 *************** *** 16,20 **** | REJECTED ! type request = { id : int, usr : int, node : int, data : string, msg : string, status : status, stamp : Init.C.timestamp } val statusFromInt : int -> status --- 16,21 ---- | REJECTED ! type request = { id : int, usr : int, node : int, data : string, msg : string, status : status, ! stamp : Init.C.timestamp, cstamp : Init.C.timestamp option } val statusFromInt : int -> status --- NEW FILE: qos.sig --- signature QOS = sig type entry = { kind : string, kindUrl : string option, name : string, url : string option, usr : int, uname : string, stamp : Init.C.timestamp, pstamp : Init.C.timestamp option, cstamp : Init.C.timestamp option} val recent : int -> entry list end --- NEW FILE: qos.mlt --- <% @header [("title", ["Support quality statistics"])]; val days = case $"days" of "" => 7 | days => Web.stoi days %> <form method="post"> Show me the entries from the last <input name="days" size="7" value="<% days %>"> days. <input type="submit" value="Show"> </form> <table> <tr><td><b>Kind</b></td> <td><b>Description</b></td> <td><b>User</b></td> <td><b>Placed</b></td> <td><b>Response</b></td> <td><b>Closed</b></td></tr> <% foreach qos in Qos.recent days do %> <tr> <td><% switch #kindUrl qos of SOME url => %><a href="<% url %>"><% end %><% Web.html (#kind qos) %><% switch #kindUrl qos of SOME _ => %></a><% end %></td> <td><% switch #url qos of SOME url => %><a href="<% url %>"><% end %><% Web.html (#name qos) %><% switch #url qos of SOME _ => %></a><% end %></td> <td><a href="user?id=<% #usr qos %>"><% Web.html (#uname qos) %></a></td> <td><% #stamp qos %></td> <td><% switch #pstamp qos of NONE => %>-<% | SOME stamp => stamp end %></td> <td><% switch #cstamp qos of NONE => %>-<% | SOME stamp => stamp end %></td> </tr> <% end %> </table> <% @footer [] %> Index: request.sig =================================================================== RCS file: /cvsroot/hcoop/portal/request.sig,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** request.sig 24 Apr 2005 23:20:04 -0000 1.1 --- request.sig 25 Feb 2007 23:57:45 -0000 1.2 *************** *** 16,20 **** | REJECTED ! type request = { id : int, usr : int, data : string, msg : string, status : status, stamp : Init.C.timestamp } val statusFromInt : int -> status --- 16,21 ---- | REJECTED ! type request = { id : int, usr : int, data : string, msg : string, status : status, ! stamp : Init.C.timestamp, cstamp : Init.C.timestamp option } val statusFromInt : int -> status Index: support.sml =================================================================== RCS file: /cvsroot/hcoop/portal/support.sml,v retrieving revision 1.11 retrieving revision 1.12 diff -C2 -d -r1.11 -r1.12 *** support.sml 25 Feb 2007 22:49:39 -0000 1.11 --- support.sml 25 Feb 2007 23:57:45 -0000 1.12 *************** *** 158,163 **** in case #status iss of ! PENDING => ignore (C.dml db ($`UPDATE SupIssue SET pstamp = CURRENT_TIMESTAMP`)) ! | CLOSED => ignore (C.dml db ($`UPDATE SupIssue SET cstamp = CURRENT_TIMESTAMP`)) | _ => (); ignore (C.dml db ($`UPDATE SupIssue SET --- 158,163 ---- in case #status iss of ! PENDING => ignore (C.dml db ($`UPDATE SupIssue SET pstamp = CURRENT_TIMESTAMP WHERE id = ^(C.intToSql (#id iss))`)) ! | CLOSED => ignore (C.dml db ($`UPDATE SupIssue SET cstamp = CURRENT_TIMESTAMP WHERE id = ^(C.intToSql (#id iss))`)) | _ => (); ignore (C.dml db ($`UPDATE SupIssue SET Index: requestH.sml =================================================================== RCS file: /cvsroot/hcoop/portal/requestH.sml,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** requestH.sml 25 Feb 2007 21:05:26 -0000 1.1 --- requestH.sml 25 Feb 2007 23:57:45 -0000 1.2 *************** *** 12,16 **** | REJECTED ! type request = { id : int, usr : int, node : int, data : string, msg : string, status : status, stamp : C.timestamp } val statusFromInt = --- 12,17 ---- | REJECTED ! type request = { id : int, usr : int, node : int, data : string, msg : string, status : status, ! stamp : C.timestamp, cstamp : C.timestamp option } val statusFromInt = *************** *** 28,35 **** fun statusToSql s = C.intToSql (statusToInt s) ! fun mkRow [id, usr, node, data, msg, status, stamp] = {id = C.intFromSql id, usr = C.intFromSql usr, node = C.intFromSql node, data = C.stringFromSql data, ! msg = C.stringFromSql msg, status = statusFromSql status, stamp = C.timestampFromSql stamp} | mkRow r = rowError ("APT request", r) --- 29,37 ---- fun statusToSql s = C.intToSql (statusToInt s) ! fun mkRow [id, usr, node, data, msg, status, stamp, cstamp] = {id = C.intFromSql id, usr = C.intFromSql usr, node = C.intFromSql node, data = C.stringFromSql data, ! msg = C.stringFromSql msg, status = statusFromSql status, stamp = C.timestampFromSql stamp, ! cstamp = if C.isNull cstamp then NONE else SOME (C.timestampFromSql cstamp)} | mkRow r = rowError ("APT request", r) *************** *** 39,45 **** val id = nextSeq (db, seq) in ! C.dml db ($`INSERT INTO ^table (id, usr, node, data, msg, status, stamp) VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql node), ^(C.stringToSql data), ^(C.stringToSql msg), ! 0, CURRENT_TIMESTAMP)`); id end --- 41,47 ---- val id = nextSeq (db, seq) in ! C.dml db ($`INSERT INTO ^table (id, usr, node, data, msg, status, stamp, cstamp) VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql node), ^(C.stringToSql data), ^(C.stringToSql msg), ! 0, CURRENT_TIMESTAMP, NULL)`); id end *************** *** 49,52 **** --- 51,59 ---- val db = getDb () in + if #status req <> NEW then + ignore (C.dml db ($`UPDATE ^table SET cstamp = CURRENT_TIMESTAMP WHERE id = ^(C.intToSql (#id req))`)) + else + (); + ignore (C.dml db ($`UPDATE ^table SET usr = ^(C.intToSql (#usr req)), data = ^(C.stringToSql (#data req)), *************** *** 60,64 **** fun lookup id = ! case C.oneOrNoRows (getDb ()) ($`SELECT id, usr, node, data, msg, status, stamp FROM ^table WHERE id = ^(C.intToSql id)`) of --- 67,71 ---- fun lookup id = ! case C.oneOrNoRows (getDb ()) ($`SELECT id, usr, node, data, msg, status, stamp, cstamp FROM ^table WHERE id = ^(C.intToSql id)`) of *************** *** 70,79 **** fun list () = ! C.map (getDb ()) mkRow' ($`SELECT name, ^table.id, usr, node, data, msg, status, stamp FROM ^table JOIN WebUser ON usr = WebUser.id ORDER BY stamp DESC`) fun listOpen () = ! C.map (getDb ()) mkRow' ($`SELECT name, ^table.id, usr, node, data, msg, status, stamp FROM ^table JOIN WebUser ON usr = WebUser.id WHERE status = 0 --- 77,86 ---- fun list () = ! C.map (getDb ()) mkRow' ($`SELECT name, ^table.id, usr, node, data, msg, status, stamp, cstamp FROM ^table JOIN WebUser ON usr = WebUser.id ORDER BY stamp DESC`) fun listOpen () = ! C.map (getDb ()) mkRow' ($`SELECT name, ^table.id, usr, node, data, msg, status, stamp, cstamp FROM ^table JOIN WebUser ON usr = WebUser.id WHERE status = 0 |
From: Adam C. <ad...@us...> - 2007-02-25 22:49:44
|
Update of /cvsroot/hcoop/portal In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv10572 Modified Files: issue.mlt sec.mlt support.sig support.sml tables.sql Log Message: Save pending/closing time stamps for misc support issues Index: support.sml =================================================================== RCS file: /cvsroot/hcoop/portal/support.sml,v retrieving revision 1.10 retrieving revision 1.11 diff -C2 -d -r1.10 -r1.11 *** support.sml 22 Oct 2005 17:33:15 -0000 1.10 --- support.sml 25 Feb 2007 22:49:39 -0000 1.11 *************** *** 10,14 **** type category = { id : int, grp : int, name : string, descr : string } ! type issue = { id : int, usr : int, cat : int, title : string, priv : bool, status : status, stamp : C.timestamp } type post = { id : int, usr : int, iss : int, body : string, stamp : C.timestamp } type subscription = { usr : int, cat : int } --- 10,15 ---- type category = { id : int, grp : int, name : string, descr : string } ! type issue = { id : int, usr : int, cat : int, title : string, priv : bool, status : status, ! stamp : C.timestamp, cstamp : C.timestamp option, pstamp : C.timestamp option } type post = { id : int, usr : int, iss : int, body : string, stamp : C.timestamp } type subscription = { usr : int, cat : int } *************** *** 80,96 **** | _ => raise Fail "Bad support issue status" ! fun mkIssueRow [id, usr, cat, title, priv, status, stamp] = {id = C.intFromSql id, usr = C.intFromSql usr, cat = C.intFromSql cat, title = C.stringFromSql title, priv = C.boolFromSql priv, ! status = statusFromSql status, stamp = C.timestampFromSql stamp} | mkIssueRow row = rowError ("issue", row) fun lookupIssue id = ! mkIssueRow (C.oneRow (getDb ()) ($`SELECT id, usr, cat, title, priv, status, stamp FROM SupIssue WHERE id = ^(C.intToSql id)`)) fun listIssues () = ! C.map (getDb ()) mkIssueRow ($`SELECT id, usr, cat, title, priv, status, stamp FROM SupIssue ORDER BY stamp DESC`) --- 81,100 ---- | _ => raise Fail "Bad support issue status" ! fun mkIssueRow [id, usr, cat, title, priv, status, stamp, pstamp, cstamp] = {id = C.intFromSql id, usr = C.intFromSql usr, cat = C.intFromSql cat, title = C.stringFromSql title, priv = C.boolFromSql priv, ! status = statusFromSql status, stamp = C.timestampFromSql stamp, ! pstamp = if C.isNull pstamp then NONE else SOME (C.timestampFromSql pstamp), ! cstamp = if C.isNull cstamp then NONE else SOME (C.timestampFromSql cstamp)} ! | mkIssueRow row = rowError ("issue", row) fun lookupIssue id = ! mkIssueRow (C.oneRow (getDb ()) ($`SELECT id, usr, cat, title, priv, status, stamp, pstamp, cstamp FROM SupIssue WHERE id = ^(C.intToSql id)`)) fun listIssues () = ! C.map (getDb ()) mkIssueRow ($`SELECT id, usr, cat, title, priv, status, stamp, pstamp, cstamp FROM SupIssue ORDER BY stamp DESC`) *************** *** 100,104 **** fun listOpenIssues usr = ! C.map (getDb ()) mkIssueRow' ($`SELECT WebUser.name, SupIssue.id, SupIssue.usr, SupIssue.cat, title, priv, status, stamp FROM SupIssue JOIN SupCategory ON cat = SupCategory.id JOIN WebUser ON WebUser.id = SupIssue.usr --- 104,108 ---- fun listOpenIssues usr = ! C.map (getDb ()) mkIssueRow' ($`SELECT WebUser.name, SupIssue.id, SupIssue.usr, SupIssue.cat, title, priv, status, stamp, pstamp, cstamp FROM SupIssue JOIN SupCategory ON cat = SupCategory.id JOIN WebUser ON WebUser.id = SupIssue.usr *************** *** 114,118 **** fun listCategoryIssues cat = ! C.map (getDb ()) mkIssueRow' ($`SELECT WebUser.name, SupIssue.id, usr, cat, title, priv, status, stamp FROM SupIssue JOIN WebUser ON WebUser.id = usr --- 118,122 ---- fun listCategoryIssues cat = ! C.map (getDb ()) mkIssueRow' ($`SELECT WebUser.name, SupIssue.id, usr, cat, title, priv, status, stamp, pstamp, cstamp FROM SupIssue JOIN WebUser ON WebUser.id = usr *************** *** 121,125 **** fun listOpenCategoryIssues (cat, usr) = ! C.map (getDb ()) mkIssueRow' ($`SELECT name, SupIssue.id, usr, cat, title, priv, status, stamp FROM SupIssue JOIN WebUser ON WebUser.id = usr --- 125,129 ---- fun listOpenCategoryIssues (cat, usr) = ! C.map (getDb ()) mkIssueRow' ($`SELECT name, SupIssue.id, usr, cat, title, priv, status, stamp, pstamp, cstamp FROM SupIssue JOIN WebUser ON WebUser.id = usr *************** *** 130,134 **** fun listOpenCategoryIssuesAdmin cat = ! C.map (getDb ()) mkIssueRow' ($`SELECT name, SupIssue.id, usr, cat, title, priv, status, stamp FROM SupIssue JOIN WebUser ON WebUser.id = usr --- 134,138 ---- fun listOpenCategoryIssuesAdmin cat = ! C.map (getDb ()) mkIssueRow' ($`SELECT name, SupIssue.id, usr, cat, title, priv, status, stamp, pstamp, cstamp FROM SupIssue JOIN WebUser ON WebUser.id = usr *************** *** 142,149 **** val id = nextSeq (db, "SupIssueSeq") in ! C.dml db ($`INSERT INTO SupIssue (id, usr, cat, title, priv, status, stamp) VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql cat), ^(C.stringToSql title), ^(C.boolToSql priv), ! ^(statusToSql status), CURRENT_TIMESTAMP)`); id end --- 146,153 ---- val id = nextSeq (db, "SupIssueSeq") in ! C.dml db ($`INSERT INTO SupIssue (id, usr, cat, title, priv, status, stamp, pstamp, cstamp) VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql cat), ^(C.stringToSql title), ^(C.boolToSql priv), ! ^(statusToSql status), CURRENT_TIMESTAMP, NULL, NULL)`); id end *************** *** 153,156 **** --- 157,164 ---- val db = getDb () in + case #status iss of + PENDING => ignore (C.dml db ($`UPDATE SupIssue SET pstamp = CURRENT_TIMESTAMP`)) + | CLOSED => ignore (C.dml db ($`UPDATE SupIssue SET cstamp = CURRENT_TIMESTAMP`)) + | _ => (); ignore (C.dml db ($`UPDATE SupIssue SET usr = ^(C.intToSql (#usr iss)), cat = ^(C.intToSql (#cat iss)), Index: sec.mlt =================================================================== RCS file: /cvsroot/hcoop/portal/sec.mlt,v retrieving revision 1.7 retrieving revision 1.8 diff -C2 -d -r1.7 -r1.8 *** sec.mlt 25 Feb 2007 22:23:48 -0000 1.7 --- sec.mlt 25 Feb 2007 22:49:39 -0000 1.8 *************** *** 252,255 **** --- 252,257 ---- <h3>Request socket permissions change</h3> + <p>Keep in mind that, if your request is granted, it will never apply to existing log-in sessions. Close them and re-connect to take advantage of your new privileges.</p> + <form action="sec" method="post"> <input type="hidden" name="node" value="<% nodeNum %>"> *************** *** 339,343 **** <p>You can find a description of rule formats <a href="http://wiki.hcoop.net/wiki/FirewallRules">on our wiki</a>. Enter here the rule you want, without the initial <tt>user</tt> portion.</p> ! <p>Please note that <b>your firewall rule will be useless</b> if you don't first request the corresponding socket privileges at the top of this page.</p> <form action="sec" method="post"> --- 341,345 ---- <p>You can find a description of rule formats <a href="http://wiki.hcoop.net/wiki/FirewallRules">on our wiki</a>. Enter here the rule you want, without the initial <tt>user</tt> portion.</p> ! <p>Please note that <b>your firewall rule will be useless</b> if you don't first request the corresponding socket privileges at the top of this page. Also, common ports like 80 (HTTP) are open to everyone with socket permissions. Verify that you can't access a port after socket permissions have been granted before requesting a special rule here.</p> <form action="sec" method="post"> Index: tables.sql =================================================================== RCS file: /cvsroot/hcoop/portal/tables.sql,v retrieving revision 1.23 retrieving revision 1.24 diff -C2 -d -r1.23 -r1.24 *** tables.sql 25 Feb 2007 22:23:48 -0000 1.23 --- tables.sql 25 Feb 2007 22:49:39 -0000 1.24 *************** *** 182,185 **** --- 182,187 ---- status INTEGER NOT NULL, stamp TIMESTAMP NOT NULL, + pstamp TIMESTAMP, + cstamp TIMESTAMP, FOREIGN KEY (usr) REFERENCES WebUser(id) ON DELETE CASCADE, FOREIGN KEY (cat) REFERENCES SupCategory(id) ON DELETE CASCADE); Index: issue.mlt =================================================================== RCS file: /cvsroot/hcoop/portal/issue.mlt,v retrieving revision 1.7 retrieving revision 1.8 diff -C2 -d -r1.7 -r1.8 *** issue.mlt 24 Jul 2006 17:21:19 -0000 1.7 --- issue.mlt 25 Feb 2007 22:49:39 -0000 1.8 *************** *** 261,264 **** --- 261,270 ---- | Support.CLOSED => %>Closed<% end %></td> </tr> + <% switch #pstamp issue of + SOME stamp => %><tr> <td>Changed to pending:</td> <td><% stamp %></td> </tr><% + end; + switch #cstamp issue of + SOME stamp => %><tr> <td>Closed:</td> <td><% stamp %></td> </tr><% + end %> </table> Index: support.sig =================================================================== RCS file: /cvsroot/hcoop/portal/support.sig,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** support.sig 18 Apr 2005 01:29:38 -0000 1.4 --- support.sig 25 Feb 2007 22:49:39 -0000 1.5 *************** *** 7,11 **** type category = { id : int, grp : int, name : string, descr : string } ! type issue = { id : int, usr : int, cat : int, title : string, priv : bool, status : status, stamp : Init.C.timestamp } type post = { id : int, usr : int, iss : int, body : string, stamp : Init.C.timestamp } type subscription = { usr : int, cat : int } --- 7,12 ---- type category = { id : int, grp : int, name : string, descr : string } ! type issue = { id : int, usr : int, cat : int, title : string, priv : bool, status : status, ! stamp : Init.C.timestamp, pstamp : Init.C.timestamp option, cstamp : Init.C.timestamp option } type post = { id : int, usr : int, iss : int, body : string, stamp : Init.C.timestamp } type subscription = { usr : int, cat : int } |
From: Adam C. <ad...@us...> - 2007-02-25 22:23:55
|
Update of /cvsroot/hcoop/portal In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv32643 Modified Files: sec.mlt sec.sig sec.sml tables.sql Log Message: Add syntax checking of proposed firewall rules Index: sec.mlt =================================================================== RCS file: /cvsroot/hcoop/portal/sec.mlt,v retrieving revision 1.6 retrieving revision 1.7 diff -C2 -d -r1.6 -r1.7 *** sec.mlt 25 Feb 2007 22:04:58 -0000 1.6 --- sec.mlt 25 Feb 2007 22:23:48 -0000 1.7 *************** *** 73,84 **** showNormal := false; val rule = $"rule"; ! %>Are you sure you want to request the firewall rule <b><% Web.html uname %> <% Web.html rule %></b> on <b><% Web.html nodeName %></b>?<br> <a href="sec?cmd=rule2&node=<% nodeNum %>&uname=<% Web.urlEncode uname %>&rule=<% Web.urlEncode rule %>&msg=<% Web.urlEncode ($"msg") %>">Yes, place the request!</a><% elseif $"cmd" = "rule2" then ! val id = Sec.Req.add {usr = you, node = nodeNum, data = String.concat ["Add firewall rule \"", uname, " ", $"rule", "\""], msg = $"msg"}; ! if not (Sec.Req.notifyNew id) then ! %><h3>Error sending e-mail notification</h3><% end - %><h3>Request added</h3><% elseif $"modRule" <> "" then --- 73,96 ---- showNormal := false; val rule = $"rule"; ! ! if Sec.validRule rule then ! %>Are you sure you want to request the firewall rule <b><% Web.html uname %> <% Web.html rule %></b> on <b><% Web.html nodeName %></b>?<br> <a href="sec?cmd=rule2&node=<% nodeNum %>&uname=<% Web.urlEncode uname %>&rule=<% Web.urlEncode rule %>&msg=<% Web.urlEncode ($"msg") %>">Yes, place the request!</a><% + else + %>"<% Web.html rule %>" is not a valid firewall rule! Please reread <a href="http://wiki.hcoop.net/wiki/FirewallRules">the instructions</a>, and remember to leave off the initial username portion.<% + end + elseif $"cmd" = "rule2" then ! val rule = $"rule"; ! ! if Sec.validRule rule then ! val id = Sec.Req.add {usr = you, node = nodeNum, data = String.concat ["Add firewall rule \"", uname, " ", rule, "\""], msg = $"msg"}; ! if not (Sec.Req.notifyNew id) then ! %><h3>Error sending e-mail notification</h3><% ! end ! %><h3>Request added</h3><% ! else ! %>"<% Web.html rule %>" is not a valid firewall rule! Please reread <a href="http://wiki.hcoop.net/wiki/FirewallRules">the instructions</a>, and remember to leave off the initial username portion.<% end elseif $"modRule" <> "" then Index: sec.sml =================================================================== RCS file: /cvsroot/hcoop/portal/sec.sml,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** sec.sml 25 Feb 2007 22:04:58 -0000 1.4 --- sec.sml 25 Feb 2007 22:23:48 -0000 1.5 *************** *** 96,98 **** --- 96,142 ---- end + fun intFromString s = + if CharVector.all Char.isDigit s andalso size s > 0 then + Int.fromString s + else + NONE + + fun validPort port = + case intFromString port of + NONE => false + | SOME n => n > 0 + + fun validPortPiece pp = + case String.fields (fn ch => ch = #":") pp of + [port] => validPort port + | [port1, port2] => validPort port1 andalso validPort port2 + + fun validPorts ports = + List.all validPortPiece (String.fields (fn ch => ch = #",") ports) + + fun validIp s = + case map intFromString (String.fields (fn ch => ch = #".") s) of + [SOME n1, SOME n2, SOME n3, SOME n4] => + n1 >= 0 andalso n1 < 256 andalso n2 >= 0 andalso n2 < 256 andalso n3 >= 0 andalso n3 < 256 andalso n4 >= 0 andalso n4 < 256 + | _ => false + + fun isIdent ch = Char.isLower ch orelse Char.isDigit ch + + fun validHost s = + size s > 0 andalso size s < 20 + andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s + + fun validDomain s = + size s > 0 andalso size s < 100 + andalso List.all validHost (String.fields (fn ch => ch = #".") s) + + val validHosts = List.all (fn x => validIp x orelse validDomain x) + + fun validRule rule = + case String.tokens Char.isSpace rule of + "Client" :: ports :: hosts => validPorts ports andalso validHosts hosts + | "Server" :: ports :: hosts => validPorts ports andalso validHosts hosts + | ["LocalServer", ports] => validPorts ports + | _ => false + end Index: tables.sql =================================================================== RCS file: /cvsroot/hcoop/portal/tables.sql,v retrieving revision 1.22 retrieving revision 1.23 diff -C2 -d -r1.22 -r1.23 *** tables.sql 25 Feb 2007 22:04:58 -0000 1.22 --- tables.sql 25 Feb 2007 22:23:48 -0000 1.23 *************** *** 226,230 **** status INTEGER NOT NULL, stamp TIMESTAMP NOT NULL, ! FOREIGN KEY (usr) REFERENCES WebUser(id) ON DELETE CASCADE); CREATE SEQUENCE AptSeq START 1; --- 226,231 ---- status INTEGER NOT NULL, stamp TIMESTAMP NOT NULL, ! FOREIGN KEY (usr) REFERENCES WebUser(id) ON DELETE CASCADE, ! FOREIGN KEY (node) REFERENCES WebNode(id) ON DELETE CASCADE); CREATE SEQUENCE AptSeq START 1; *************** *** 304,308 **** status INTEGER NOT NULL, stamp TIMESTAMP NOT NULL, ! FOREIGN KEY (usr) REFERENCES WebUser(id) ON DELETE CASCADE); CREATE SEQUENCE SecSeq START 1; --- 305,310 ---- status INTEGER NOT NULL, stamp TIMESTAMP NOT NULL, ! FOREIGN KEY (usr) REFERENCES WebUser(id) ON DELETE CASCADE, ! FOREIGN KEY (node) REFERENCES WebNode(id) ON DELETE CASCADE); CREATE SEQUENCE SecSeq START 1; Index: sec.sig =================================================================== RCS file: /cvsroot/hcoop/portal/sec.sig,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** sec.sig 25 Feb 2007 22:04:58 -0000 1.4 --- sec.sig 25 Feb 2007 22:23:48 -0000 1.5 *************** *** 16,18 **** --- 16,20 ---- val findFirewallRules : {node : int, uname : string} -> string list + + val validRule : string -> bool end |
From: Adam C. <ad...@us...> - 2007-02-25 22:05:02
|
Update of /cvsroot/hcoop/portal In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv24874 Modified Files: sec.mlt sec.sig sec.sml tables.sql Log Message: Updated security settings to handle multiple machines Index: sec.mlt =================================================================== RCS file: /cvsroot/hcoop/portal/sec.mlt,v retrieving revision 1.5 retrieving revision 1.6 diff -C2 -d -r1.5 -r1.6 *** sec.mlt 25 Feb 2007 21:05:26 -0000 1.5 --- sec.mlt 25 Feb 2007 22:04:58 -0000 1.6 *************** *** 2,13 **** val yourname = Init.getUserName (); val uname = case $"uname" of "" => yourname | uname => uname; ! val socks = Sec.socketPerms uname; ! val tpe = Sec.isTpe uname; ! val cron = Sec.cronAllowed uname; ! val ftp = Sec.ftpAllowed uname; ref showNormal = true; --- 2,18 ---- val yourname = Init.getUserName (); + val nodeNum = case $"node" of + "" => 2 + | node => Web.stoi node; + val nodeName = Init.nodeName nodeNum; + val uname = case $"uname" of "" => yourname | uname => uname; ! val socks = Sec.socketPerms {node = nodeNum, uname = uname}; ! val tpe = Sec.isTpe {node = nodeNum, uname = uname}; ! val cron = Sec.cronAllowed {node = nodeNum, uname = uname}; ! val ftp = Sec.ftpAllowed {node = nodeNum, uname = uname}; ref showNormal = true; *************** *** 18,25 **** showNormal := false; val socks = $"socks"; ! %>Are you sure you want to request that socket permissions for <b><% Web.html uname %></b> be changed to <b><% Web.html socks %></b>?<br> ! <a href="sec?cmd=socks2&uname=<% Web.urlEncode uname %>&socks=<% Web.urlEncode socks %>&msg=<% Web.urlEncode ($"msg") %>">Yes, place the request!</a><% elseif $"cmd" = "socks2" then ! val id = Sec.Req.add (you, String.concat [uname, ": change socket permissions to ", $"socks"], $"msg"); if not (Sec.Req.notifyNew id) then %><h3>Error sending e-mail notification</h3><% --- 23,30 ---- showNormal := false; val socks = $"socks"; ! %>Are you sure you want to request that socket permissions for <b><% Web.html uname %></b> on <b><% Web.html nodeName %></b> be changed to <b><% Web.html socks %></b>?<br> ! <a href="sec?cmd=socks2&node=<% nodeNum %>&uname=<% Web.urlEncode uname %>&socks=<% Web.urlEncode socks %>&msg=<% Web.urlEncode ($"msg") %>">Yes, place the request!</a><% elseif $"cmd" = "socks2" then ! val id = Sec.Req.add {usr = you, node = nodeNum, data = String.concat [uname, ": change socket permissions to ", $"socks"], msg = $"msg"}; if not (Sec.Req.notifyNew id) then %><h3>Error sending e-mail notification</h3><% *************** *** 30,37 **** showNormal := false; val tpe = iff $"tpe" = "yes" then "on" else "off"; ! %>Are you sure you want to request that trusted-path-executables-only for <b><% Web.html uname %></b> be turned <b><% tpe %></b>?<br> ! <a href="sec?cmd=tpe2&uname=<% Web.urlEncode uname %>&tpe=<% tpe %>&msg=<% Web.urlEncode ($"msg") %>">Yes, place the request!</a><% elseif $"cmd" = "tpe2" then ! val id = Sec.Req.add (you, String.concat [uname, ": turn tpe ", $"tpe"], $"msg"); if not (Sec.Req.notifyNew id) then %><h3>Error sending e-mail notification</h3><% --- 35,42 ---- showNormal := false; val tpe = iff $"tpe" = "yes" then "on" else "off"; ! %>Are you sure you want to request that trusted-path-executables-only for <b><% Web.html uname %></b> on <b><% Web.html nodeName %></b> be turned <b><% tpe %></b>?<br> ! <a href="sec?cmd=tpe2&node=<% nodeNum %>&uname=<% Web.urlEncode uname %>&tpe=<% tpe %>&msg=<% Web.urlEncode ($"msg") %>">Yes, place the request!</a><% elseif $"cmd" = "tpe2" then ! val id = Sec.Req.add {usr = you, node = nodeNum, data = String.concat [uname, ": turn tpe ", $"tpe"], msg = $"msg"}; if not (Sec.Req.notifyNew id) then %><h3>Error sending e-mail notification</h3><% *************** *** 42,50 **** showNormal := false; val cron = iff $"cron" = "yes" then "enabled" else "disabled"; ! %>Are you sure you want to request that <tt>cron</tt> permissions for <b><% Web.html uname %></b> be <b><% cron %></b>?<br> ! <a href="sec?cmd=cron2&uname=<% Web.urlEncode uname %>&cron=<% cron %>&msg=<% Web.urlEncode ($"msg") %>">Yes, place the request!</a><% elseif $"cmd" = "cron2" then val cron = iff $"cron" = "enabled" then "enable" else "disable"; ! val id = Sec.Req.add (you, String.concat [uname, ": ", cron, " cron access"], $"msg"); if not (Sec.Req.notifyNew id) then %><h3>Error sending e-mail notification</h3><% --- 47,55 ---- showNormal := false; val cron = iff $"cron" = "yes" then "enabled" else "disabled"; ! %>Are you sure you want to request that <tt>cron</tt> permissions for <b><% Web.html uname %></b> on <b><% Web.html nodeName %></b> be <b><% cron %></b>?<br> ! <a href="sec?cmd=cron2&node=<% nodeNum %>&uname=<% Web.urlEncode uname %>&cron=<% cron %>&msg=<% Web.urlEncode ($"msg") %>">Yes, place the request!</a><% elseif $"cmd" = "cron2" then val cron = iff $"cron" = "enabled" then "enable" else "disable"; ! val id = Sec.Req.add {usr = you, node = nodeNum, data = String.concat [uname, ": ", cron, " cron access"], msg = $"msg"}; if not (Sec.Req.notifyNew id) then %><h3>Error sending e-mail notification</h3><% *************** *** 55,63 **** showNormal := false; val ftp = iff $"ftp" = "yes" then "enabled" else "disabled"; ! %>Are you sure you want to request that FTP permissions for <b><% Web.html uname %></b> be <b><% ftp %></b>?<br> ! <a href="sec?cmd=ftp2&uname=<% Web.urlEncode uname %>&ftp=<% ftp %>&msg=<% Web.urlEncode ($"msg") %>">Yes, place the request!</a><% elseif $"cmd" = "ftp2" then val ftp = iff $"ftp" = "enabled" then "enable" else "disable"; ! val id = Sec.Req.add (you, String.concat [uname, ": ", ftp, " FTP access"], $"msg"); if not (Sec.Req.notifyNew id) then %><h3>Error sending e-mail notification</h3><% --- 60,68 ---- showNormal := false; val ftp = iff $"ftp" = "yes" then "enabled" else "disabled"; ! %>Are you sure you want to request that FTP permissions for <b><% Web.html uname %></b> on <b><% Web.html nodeName %></b> be <b><% ftp %></b>?<br> ! <a href="sec?cmd=ftp2&node=<% nodeNum %>&uname=<% Web.urlEncode uname %>&ftp=<% ftp %>&msg=<% Web.urlEncode ($"msg") %>">Yes, place the request!</a><% elseif $"cmd" = "ftp2" then val ftp = iff $"ftp" = "enabled" then "enable" else "disable"; ! val id = Sec.Req.add {usr = you, node = nodeNum, data = String.concat [uname, ": ", ftp, " FTP access"], msg = $"msg"}; if not (Sec.Req.notifyNew id) then %><h3>Error sending e-mail notification</h3><% *************** *** 68,75 **** showNormal := false; val rule = $"rule"; ! %>Are you sure you want to request the firewall rule <b><% Web.html uname %> <% Web.html rule %></b>?<br> ! <a href="sec?cmd=rule2&uname=<% Web.urlEncode uname %>&rule=<% Web.urlEncode rule %>&msg=<% Web.urlEncode ($"msg") %>">Yes, place the request!</a><% elseif $"cmd" = "rule2" then ! val id = Sec.Req.add (you, String.concat ["Add firewall rule \"", uname, " ", $"rule", "\""], $"msg"); if not (Sec.Req.notifyNew id) then %><h3>Error sending e-mail notification</h3><% --- 73,80 ---- showNormal := false; val rule = $"rule"; ! %>Are you sure you want to request the firewall rule <b><% Web.html uname %> <% Web.html rule %></b> on <b><% Web.html nodeName %></b>?<br> ! <a href="sec?cmd=rule2&node=<% nodeNum %>&uname=<% Web.urlEncode uname %>&rule=<% Web.urlEncode rule %>&msg=<% Web.urlEncode ($"msg") %>">Yes, place the request!</a><% elseif $"cmd" = "rule2" then ! val id = Sec.Req.add {usr = you, node = nodeNum, data = String.concat ["Add firewall rule \"", uname, " ", $"rule", "\""], msg = $"msg"}; if not (Sec.Req.notifyNew id) then %><h3>Error sending e-mail notification</h3><% *************** *** 84,92 **** %>You didn't modify the textbox for this rule before clicking the button, so there is no request to be made.<% else ! %>Are you sure you want to request that firewall rule <b><% Web.html uname %> <% Web.html oldRule %></b> be replaced by <b><% Web.html uname %> <% Web.html rule %></b>?<br> ! <a href="sec?uname=<% Web.urlEncode uname %>&modRule2=<% Web.urlEncode oldRule %>&rule=<% Web.urlEncode rule %>&msg=<% Web.urlEncode ($"msg") %>">Yes, place the request!</a><% end elseif $"modRule2" <> "" then ! val id = Sec.Req.add (you, String.concat ["Change firewall rule \"", uname, " ", $"modRule2", "\" to \"", uname, " ", $"rule", "\""], $"msg"); if not (Sec.Req.notifyNew id) then %><h3>Error sending e-mail notification</h3><% --- 89,97 ---- %>You didn't modify the textbox for this rule before clicking the button, so there is no request to be made.<% else ! %>Are you sure you want to request that firewall rule <b><% Web.html uname %> <% Web.html oldRule %></b> be replaced by <b><% Web.html uname %> <% Web.html rule %></b> on <b><% Web.html nodeName %></b>?<br> ! <a href="sec?node=<% nodeNum %>&uname=<% Web.urlEncode uname %>&modRule2=<% Web.urlEncode oldRule %>&rule=<% Web.urlEncode rule %>&msg=<% Web.urlEncode ($"msg") %>">Yes, place the request!</a><% end elseif $"modRule2" <> "" then ! val id = Sec.Req.add {usr = you, node = nodeNum, data = String.concat ["Change firewall rule \"", uname, " ", $"modRule2", "\" to \"", uname, " ", $"rule", "\""], msg = $"msg"}; if not (Sec.Req.notifyNew id) then %><h3>Error sending e-mail notification</h3><% *************** *** 97,104 **** showNormal := false; val oldRule = $"delRule"; ! %>Are you sure you want to request that firewall rule <b><% Web.html uname %> <% Web.html oldRule %></b> be <b>deleted</b>?<br> ! <a href="sec?uname=<% Web.urlEncode uname %>&delRule2=<% Web.urlEncode oldRule %>&msg=<% Web.urlEncode ($"msg") %>">Yes, place the request!</a><% elseif $"delRule2" <> "" then ! val id = Sec.Req.add (you, String.concat ["Delete firewall rule \"", uname, " ", $"delRule2", "\""], $"msg"); if not (Sec.Req.notifyNew id) then %><h3>Error sending e-mail notification</h3><% --- 102,109 ---- showNormal := false; val oldRule = $"delRule"; ! %>Are you sure you want to request that firewall rule <b><% Web.html uname %> <% Web.html oldRule %></b> on <b><% Web.html nodeName %></b> be <b>deleted</bD>?<br> ! <a href="sec?node=<% nodeNum %>&uname=<% Web.urlEncode uname %>&delRule2=<% Web.urlEncode oldRule %>&msg=<% Web.urlEncode ($"msg") %>">Yes, place the request!</a><% elseif $"delRule2" <> "" then ! val id = Sec.Req.add {usr = you, node = nodeNum, data = String.concat ["Delete firewall rule \"", uname, " ", $"delRule2", "\""], msg = $"msg"}; if not (Sec.Req.notifyNew id) then %><h3>Error sending e-mail notification</h3><% *************** *** 117,120 **** --- 122,126 ---- <tr> <td>By:</td> <td><a href="user?id=<% #usr req %>"><% name %></a></td> </tr> <tr> <td>Time:</td> <td><% #stamp req %></td> </tr> + <tr> <td>Node:</td> <td><% Web.html (Init.nodeName (#node req)) %></td> </tr> <tr> <td>Request:</td> <td><% #data req %></td> </tr> <tr> <td>Msg:</td> <td colspan="2"><% Web.html (#msg req) %></td> </tr> *************** *** 137,140 **** --- 143,147 ---- <tr> <td>By:</td> <td colspan="2"><a href="user?id=<% #usr req %>"><% name %></a></td> </tr> <tr> <td>Time:</td> <td colspan="2"><% #stamp req %></td> </tr> + <tr> <td>Node:</td> <td><% Web.html (Init.nodeName (#node req)) %></td> </tr> <tr> <td>Request:</td> <td><% #data req %></td> </tr> <tr> <td>Reason:</td> <td colspan="2"><% Web.html (#msg req) %></td> </tr> *************** *** 165,168 **** --- 172,179 ---- <option value="2"<% if #status req = Sec.Req.REJECTED then %> selected<% end %>>Rejected</option> </select></td> </tr> + <tr> <td>Node:</td> <td><select name="node"> + <% foreach node in Init.listNodes () do %> + <option value="<% #id node %>"<% if nodeNum = #node req then %> selected<% end %>><% Web.html (#name node) %> (<% Web.html (#descr node) %>)</option> + <% end %></select></td> </tr> <tr> <td>Request:</td> <td><input name="req" value="<% #data req %>"></td> </tr> <tr> <td>Message:</td> <td><textarea name="msg" rows="10" cols="80" wrap="soft"><% Web.html (#msg req) %></textarea></td> </tr> *************** *** 178,184 **** val oldStatus = #status req; val newStatus = Sec.Req.statusFromInt (Web.stoi ($"status")); ! Sec.Req.modify {req with data = $"req", msg = $"msg", status = newStatus}; if oldStatus <> newStatus then ! if not (Sec.Req.notifyMod (oldStatus, newStatus, Init.getUserName(), id)) then %><h3>Error sending e-mail notification</h3><% end --- 189,195 ---- val oldStatus = #status req; val newStatus = Sec.Req.statusFromInt (Web.stoi ($"status")); ! Sec.Req.modify {req with node = nodeNum, data = $"req", msg = $"msg", status = newStatus}; if oldStatus <> newStatus then ! if not (Sec.Req.notifyMod {old = oldStatus, new = newStatus, changer = Init.getUserName(), req = id}) then %><h3>Error sending e-mail notification</h3><% end *************** *** 193,197 **** val req = Sec.Req.lookup id; val user = Init.lookupUser (#usr req) ! %><h3>Are you sure you want to delete request by <% #name user %> for "<% #data req %>"?</h3> <a href="sec?del2=<% id %>">Yes, I'm sure!</a> --- 204,208 ---- val req = Sec.Req.lookup id; val user = Init.lookupUser (#usr req) ! %><h3>Are you sure you want to delete request by <% #name user %> for "<% #data req %>" on <% Web.html (Init.nodeName (#node req)) %>?</h3> <a href="sec?del2=<% id %>">Yes, I'm sure!</a> *************** *** 208,220 **** if showNormal then %> <form action="sec" method="post"> ! <b>Your users:</b> <select name="uname"> <% foreach name in (yourname :: Sec.findSubusers yourname) do %> <option value="<% name %>"<% if uname = name then %> selected<% end %>><% name %></option> ! <% end %></select> <input type="submit" value="Switch"> </form> <h3>Request socket permissions change</h3> <form action="sec" method="post"> <input type="hidden" name="uname" value="<% uname %>"> <input type="hidden" name="cmd" value="socks"> --- 219,245 ---- if showNormal then %> + <table class="blanks"> <form action="sec" method="post"> ! <input type="hidden" name="uname" value="<% Web.html uname %>"> ! <tr> <td>Machines:</td> <td><select name="node"> ! <% foreach node in Init.listNodes () do %> ! <option value="<% #id node %>"<% if nodeNum = #id node then %> selected<% end %>><% Web.html (#name node) %> (<% Web.html (#descr node) %>)</option> ! <% end %></select></td> ! <td><input type="submit" value="Switch"></td> </tr> ! </form> ! <form action="sec" method="post"> ! <input type="hidden" name="node" value="<% nodeNum %>"> ! <tr> <td>Your users:</td> <td><select name="uname"> <% foreach name in (yourname :: Sec.findSubusers yourname) do %> <option value="<% name %>"<% if uname = name then %> selected<% end %>><% name %></option> ! <% end %></select></td> ! <td><input type="submit" value="Switch"></td> </tr> ! </form> ! </table> <h3>Request socket permissions change</h3> <form action="sec" method="post"> + <input type="hidden" name="node" value="<% nodeNum %>"> <input type="hidden" name="uname" value="<% uname %>"> <input type="hidden" name="cmd" value="socks"> *************** *** 234,237 **** --- 259,263 ---- <form action="sec" method="post"> + <input type="hidden" name="node" value="<% nodeNum %>"> <input type="hidden" name="uname" value="<% uname %>"> <input type="hidden" name="cmd" value="tpe"> *************** *** 249,252 **** --- 275,279 ---- <form action="sec" method="post"> + <input type="hidden" name="node" value="<% nodeNum %>"> <input type="hidden" name="uname" value="<% uname %>"> <input type="hidden" name="cmd" value="cron"> *************** *** 266,269 **** --- 293,297 ---- <form action="sec" method="post"> + <input type="hidden" name="node" value="<% nodeNum %>"> <input type="hidden" name="uname" value="<% uname %>"> <input type="hidden" name="cmd" value="ftp"> *************** *** 278,282 **** </form> ! <% val rules = Sec.findFirewallRules uname; switch rules of _::_ => %> --- 306,310 ---- </form> ! <% val rules = Sec.findFirewallRules {node = nodeNum, uname = uname}; switch rules of _::_ => %> *************** *** 285,288 **** --- 313,317 ---- <% foreach rule in rules do %> <form action="sec" method="post"> + <input type="hidden" name="node" value="<% nodeNum %>"> <input type="hidden" name="uname" value="<% uname %>"> <input type="hidden" name="modRule" value="<% Web.html rule %>"> *************** *** 301,304 **** --- 330,334 ---- <form action="sec" method="post"> + <input type="hidden" name="node" value="<% nodeNum %>"> <input type="hidden" name="uname" value="<% uname %>"> <input type="hidden" name="cmd" value="rule"> Index: sec.sml =================================================================== RCS file: /cvsroot/hcoop/portal/sec.sml,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** sec.sml 9 Oct 2005 18:13:37 -0000 1.3 --- sec.sml 25 Feb 2007 22:04:58 -0000 1.4 *************** *** 3,16 **** open Init Util Sql ! structure Req = Request(struct ! val table = "Sec" ! val adminGroup = "server" ! fun subject _ = "Security permissions change request" ! val template = "sec" ! val descr = "change" ! fun body (mail, req) = ! (Mail.mwrite (mail, req); ! Mail.mwrite (mail, "\n")) ! end) fun findSubusers uname = --- 3,16 ---- open Init Util Sql ! structure Req = RequestH(struct ! val table = "Sec" ! val adminGroup = "server" ! fun subject _ = "Security permissions change request" ! val template = "sec" ! val descr = "change" ! fun body {node, mail, data = req} = ! (Mail.mwrite (mail, req); ! Mail.mwrite (mail, "\n")) ! end) fun findSubusers uname = *************** *** 42,119 **** | NADA ! fun inGroup (uname, grp) = let ! val uname_under = uname ^ "_" ! val inf = TextIO.openIn "/etc/group" ! fun loop () = ! case TextIO.inputLine inf of ! NONE => false ! | SOME line => ! case String.fields (fn ch => ch = #":") line of ! [gname, _, _, members] => ! if gname = grp then ! mem (uname, String.fields (fn ch => ch = #",") members) ! else ! loop () ! | _ => loop () in ! loop () ! before TextIO.closeIn inf ! end ! ! fun socketPerms uname = ! if inGroup (uname, "no-sockets") then ! NADA ! else if inGroup (uname, "no-cli-sockets") then ! if inGroup (uname, "no-serv-sockets") then ! NADA else ! SERVER_ONLY ! else if inGroup (uname, "no-serv-sockets") then ! CLIENT_ONLY ! else ! ANY ! ! fun isTpe uname = inGroup (uname, "only-tpe") ! fun findFirewallRules uname = ! let ! val inf = TextIO.openIn "/etc/firewall/users.rules" ! fun loop rules = ! case TextIO.inputLine inf of ! NONE => List.rev rules ! | SOME line => ! if String.sub (line, 0) = #"#" then ! loop rules ! else case String.tokens Char.isSpace line of ! uname'::rest => ! if uname = uname' then ! loop (String.concatWith " " rest :: rules) ! else ! loop rules ! | _ => loop rules ! in ! loop [] ! before TextIO.closeIn inf ! end ! fun somethingAllowed fname uname = let ! val inf = TextIO.openIn fname ! val uname' = uname ^ "\n" ! fun loop () = case TextIO.inputLine inf of ! NONE => false ! | SOME line => line = uname' orelse loop () in ! loop () ! before TextIO.closeIn inf end - val cronAllowed = somethingAllowed "/etc/cron.allow" - val ftpAllowed = somethingAllowed "/etc/ftpusers" - end --- 42,98 ---- | NADA ! fun socketPerms {node, uname} = let ! val proc = Unix.execute ("/bin/sh", ! ["-c", ! "DOMTOOL_USER=apache2.deleuze.hcoop.net /usr/local/bin/domtool-admin sockperm " ! ^ Init.nodeName node ^ " " ^ uname]) ! ! val inf = Unix.textInstreamOf proc ! val p = case TextIO.inputLine inf of ! SOME "Any\n" => ANY ! | SOME "Client\n" => CLIENT_ONLY ! | SOME "Server\n" => SERVER_ONLY ! | _ => NADA in ! TextIO.closeIn inf; ! if OS.Process.isSuccess (Unix.reap proc) then ! p else ! NADA ! end ! fun checkIt cmd {node, uname} = ! OS.Process.isSuccess (OS.Process.system ! ("DOMTOOL_USER=apache2.deleuze.hcoop.net /usr/local/bin/domtool-admin " ! ^ cmd ^ " " ^ Init.nodeName node ^ " " ^ uname ^ " >/dev/null 2>/dev/null")) ! val isTpe = checkIt "tpe" ! val cronAllowed = checkIt "cron" ! val ftpAllowed = checkIt "ftp" ! fun findFirewallRules {node, uname} = let ! val proc = Unix.execute ("/bin/sh", ! ["-c", ! "DOMTOOL_USER=apache2.deleuze.hcoop.net /usr/local/bin/domtool-admin firewall " ! ^ Init.nodeName node ^ " " ^ uname]) ! ! val inf = Unix.textInstreamOf proc ! fun readEm lines = case TextIO.inputLine inf of ! SOME line => readEm (String.substring (line, 0, size line - 1) :: lines) ! | NONE => rev lines ! ! val lines = readEm [] in ! TextIO.closeIn inf; ! if OS.Process.isSuccess (Unix.reap proc) then ! lines ! else ! [] end end Index: tables.sql =================================================================== RCS file: /cvsroot/hcoop/portal/tables.sql,v retrieving revision 1.21 retrieving revision 1.22 diff -C2 -d -r1.21 -r1.22 *** tables.sql 25 Feb 2007 21:05:26 -0000 1.21 --- tables.sql 25 Feb 2007 22:04:58 -0000 1.22 *************** *** 299,302 **** --- 299,303 ---- id INTEGER PRIMARY KEY, usr INTEGER NOT NULL, + node INTEGER NOT NULL, data TEXT NOT NULL, msg TEXT NOT NULL, Index: sec.sig =================================================================== RCS file: /cvsroot/hcoop/portal/sec.sig,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** sec.sig 9 Oct 2005 18:13:37 -0000 1.3 --- sec.sig 25 Feb 2007 22:04:58 -0000 1.4 *************** *** 1,4 **** signature SEC = sig ! structure Req : REQUEST_OUT val findSubusers : string -> string list --- 1,4 ---- signature SEC = sig ! structure Req : REQUESTH_OUT val findSubusers : string -> string list *************** *** 10,19 **** | NADA ! val inGroup : string * string -> bool ! val socketPerms : string -> socket_perms ! val isTpe : string -> bool ! val cronAllowed : string -> bool ! val ftpAllowed : string -> bool ! val findFirewallRules : string -> string list end --- 10,18 ---- | NADA ! val socketPerms : {node : int, uname : string} -> socket_perms ! val isTpe : {node : int, uname : string} -> bool ! val cronAllowed : {node : int, uname : string} -> bool ! val ftpAllowed : {node : int, uname : string} -> bool ! val findFirewallRules : {node : int, uname : string} -> string list end |
Update of /cvsroot/hcoop/portal In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv716 Modified Files: apt.mlt apt.sml aptquery.sig aptquery.sml exn.mlt init.sig init.sml sec.mlt tables.sql Added Files: requestH.sig requestH.sml Log Message: Update APT requests to take multiple servers into consideration Index: sec.mlt =================================================================== RCS file: /cvsroot/hcoop/portal/sec.mlt,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** sec.mlt 24 Nov 2005 19:45:27 -0000 1.4 --- sec.mlt 25 Feb 2007 21:05:26 -0000 1.5 *************** *** 253,257 **** <table class="blanks"> <tr> <td>Allowed to use cron?</td> <td><select name="cron"> ! option value="no"<% if not cron then %> selected<% end %>>No</option> <option value="yes"<% if cron then %> selected<% end %>>Yes</option> </select></td> </tr> --- 253,257 ---- <table class="blanks"> <tr> <td>Allowed to use cron?</td> <td><select name="cron"> ! <option value="no"<% if not cron then %> selected<% end %>>No</option> <option value="yes"<% if cron then %> selected<% end %>>Yes</option> </select></td> </tr> *************** *** 263,266 **** --- 263,268 ---- <h3>Request change to your FTP permissions</h3> + <p>Please read <a href="http://wiki.hcoop.net/wiki/FileTransfer">our wiki instructions on file transfer</a> before requesting FTP access. Almost everyone should use alternative protocols to FTP that provide superior security benefits.</p> + <form action="sec" method="post"> <input type="hidden" name="uname" value="<% uname %>"> *************** *** 296,299 **** --- 298,303 ---- <p>You can find a description of rule formats <a href="http://wiki.hcoop.net/wiki/FirewallRules">on our wiki</a>. Enter here the rule you want, without the initial <tt>user</tt> portion.</p> + <p>Please note that <b>your firewall rule will be useless</b> if you don't first request the corresponding socket privileges at the top of this page.</p> + <form action="sec" method="post"> <input type="hidden" name="uname" value="<% uname %>"> Index: aptquery.sml =================================================================== RCS file: /cvsroot/hcoop/portal/aptquery.sml,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** aptquery.sml 4 Aug 2006 00:33:23 -0000 1.3 --- aptquery.sml 25 Feb 2007 21:05:26 -0000 1.4 *************** *** 7,11 **** andalso (size s > 0 andalso String.sub (s, 0) <> #"-") ! fun query name = let val _ = --- 7,11 ---- andalso (size s > 0 andalso String.sub (s, 0) <> #"-") ! fun query {node, pkg = name} = let val _ = *************** *** 34,38 **** val _ = Unix.reap proc ! val installed = OS.Process.isSuccess (OS.Process.system ("/usr/bin/dpkg -p " ^ name ^ " >/dev/null 2>/dev/null")) in SOME {name = name, section = section, descr = descr, installed = installed} --- 34,38 ---- val _ = Unix.reap proc ! val installed = OS.Process.isSuccess (OS.Process.system ("DOMTOOL_USER=apache2.deleuze.hcoop.net /usr/local/bin/domtool-admin package " ^ Init.nodeName node ^ " " ^ name ^ " >/dev/null 2>/dev/null")) in SOME {name = name, section = section, descr = descr, installed = installed} Index: init.sig =================================================================== RCS file: /cvsroot/hcoop/portal/init.sig,v retrieving revision 1.10 retrieving revision 1.11 diff -C2 -d -r1.10 -r1.11 *** init.sig 24 Jul 2006 17:21:19 -0000 1.10 --- init.sig 25 Feb 2007 21:05:26 -0000 1.11 *************** *** 49,51 **** --- 49,57 ---- val grandfatherUsers : unit -> unit + + type node = {id : int, name : string, descr : string, debian : string} + + val listNodes : unit -> node list + val nodeName : int -> string + val nodeDebian : int -> string end --- NEW FILE: requestH.sig --- signature REQUESTH_IN = sig val table : string val adminGroup : string val subject : string -> string val body : {node : int, mail : Mail.session, data : string} -> unit val template : string val descr : string end signature REQUESTH_OUT = sig datatype status = NEW | INSTALLED | REJECTED type request = { id : int, usr : int, node : int, data : string, msg : string, status : status, stamp : Init.C.timestamp } val statusFromInt : int -> status val add : {usr : int, node : int, data : string, msg : string} -> int val lookup : int -> request val modify : request -> unit val delete : int -> unit val list : unit -> (string * request) list val listOpen : unit -> (string * request) list val notifyNew : int -> bool val notifyMod : {old : status, new : status, changer : string, req : int} -> bool end Index: tables.sql =================================================================== RCS file: /cvsroot/hcoop/portal/tables.sql,v retrieving revision 1.20 retrieving revision 1.21 diff -C2 -d -r1.20 -r1.21 *** tables.sql 24 Jul 2006 17:21:19 -0000 1.20 --- tables.sql 25 Feb 2007 21:05:26 -0000 1.21 *************** *** 205,211 **** --- 205,225 ---- FOREIGN KEY (cat) REFERENCES SupCategory(id) ON DELETE CASCADE); + CREATE TABLE WebNode( + id INTEGER PRIMARY KEY, + name TEXT NOT NULL, + descr TEXT NOT NULL, + debian TEXT NOT NULL); + + INSERT INTO WebNode (id, name, descr, debian) + VALUES (0, 'fyodor', 'old server', 'testing'); + INSERT INTO WebNode (id, name, descr, debian) + VALUES (1, 'deleuze', 'main server', 'stable'); + INSERT INTO WebNode (id, name, descr, debian) + VALUES (2, 'mire', 'member web server', 'stable'); + CREATE TABLE Apt( id INTEGER PRIMARY KEY, usr INTEGER NOT NULL, + node INTEGER NOT NULL, data TEXT NOT NULL, msg TEXT NOT NULL, Index: apt.sml =================================================================== RCS file: /cvsroot/hcoop/portal/apt.sml,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** apt.sml 24 Apr 2005 23:20:04 -0000 1.2 --- apt.sml 25 Feb 2007 21:05:26 -0000 1.3 *************** *** 1,32 **** ! structure Apt = Request(struct ! val table = "Apt" ! val adminGroup = "server" ! fun subject _ = "Apt package installation request" ! val template = "apt" ! val descr = "packages" ! fun body (mail, pkgs) = ! let ! val pkgs = String.tokens Char.isSpace pkgs ! val infos = map (valOf o AptQuery.query) pkgs ! fun rightJustify (n, s) = ! let ! fun pad n = ! if n <= 0 then ! () ! else ! (Mail.mwrite (mail, " "); ! pad (n-1)) ! in ! pad (n - size s); ! Mail.mwrite (mail, s) ! end ! in ! app (fn info => ! (rightJustify (10, #name info); ! Mail.mwrite (mail, " "); ! Mail.mwrite (mail, #descr info); ! Mail.mwrite (mail, "\n"))) infos ! end ! end) --- 1,32 ---- ! structure Apt = RequestH(struct ! val table = "Apt" ! val adminGroup = "server" ! fun subject _ = "Apt package installation request" ! val template = "apt" ! val descr = "packages" ! fun body {node, mail, data = pkgs} = ! let ! val pkgs = String.tokens Char.isSpace pkgs ! val infos = map (valOf o (fn x => AptQuery.query {node = node, pkg = x})) pkgs ! fun rightJustify (n, s) = ! let ! fun pad n = ! if n <= 0 then ! () ! else ! (Mail.mwrite (mail, " "); ! pad (n-1)) ! in ! pad (n - size s); ! Mail.mwrite (mail, s) ! end ! in ! app (fn info => ! (rightJustify (10, #name info); ! Mail.mwrite (mail, " "); ! Mail.mwrite (mail, #descr info); ! Mail.mwrite (mail, "\n"))) infos ! end ! end) Index: exn.mlt =================================================================== RCS file: /cvsroot/hcoop/portal/exn.mlt,v retrieving revision 1.5 retrieving revision 1.6 diff -C2 -d -r1.5 -r1.6 *** exn.mlt 24 Nov 2005 19:45:27 -0000 1.5 --- exn.mlt 25 Feb 2007 21:05:26 -0000 1.6 *************** *** 12,15 **** --- 12,17 ---- <% | OS.SysErr (name, SOME syserr) => %> <b>System error</b>: <% Web.html name %>: <% Web.html (OS.errorName syserr) %>: <% Web.htmlNl (OS.errorMsg syserr) %> + <% | IO.Io {name, function, ...} => %> + <b>IO error</b>: <% Web.html name %> for <% Web.html function %> <% | Init.C.Sql msg => %> <b>SQL</b>: <% Web.htmlNl msg %> Index: apt.mlt =================================================================== RCS file: /cvsroot/hcoop/portal/apt.mlt,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** apt.mlt 24 Nov 2005 19:45:27 -0000 1.4 --- apt.mlt 25 Feb 2007 21:05:26 -0000 1.5 *************** *** 4,7 **** --- 4,8 ---- if $"new" <> "" then + val node = Web.stoi ($"node"); val pkgs = String.tokens Char.isSpace ($"new"); *************** *** 10,14 **** foreach pkg in pkgs do ! switch AptQuery.query pkg of NONE => ok := false; --- 11,15 ---- foreach pkg in pkgs do ! switch AptQuery.query {node = node, pkg = pkg} of NONE => ok := false; *************** *** 24,32 **** end; ! if ok then %> Are you sure these are the packages you wanted?<br><br> <table> <% foreach info in infos do %> ! <tr> <td align="right"><a href="http://packages.debian.org/testing/<% #section info %>/<% #name info %>"><% #name info %></a></td> <td><% Web.html (#descr info) %></td> </tr> <% end %> --- 25,34 ---- end; ! if ok then ! val debian = Init.nodeDebian node %> Are you sure these are the packages you wanted?<br><br> <table> <% foreach info in infos do %> ! <tr> <td align="right"><a href="http://packages.debian.org/<% debian %>/<% #section info %>/<% #name info %>"><% #name info %></a></td> <td><% Web.html (#descr info) %></td> </tr> <% end %> *************** *** 34,42 **** <br> <b>Reason:</b> <blockquote><% Web.htmlNl ($"msg") %></blockquote><br> ! <a href="apt?req=<% foreach info in infos do %><% #name info %>+<% end %>&msg=<% Web.urlEncode ($"msg") %>">Yes, I want to request these packages.</a> <% end elseif $"req" <> "" then val pkgs = String.tokens Char.isSpace ($"req"); --- 36,45 ---- <br> <b>Reason:</b> <blockquote><% Web.htmlNl ($"msg") %></blockquote><br> ! <a href="apt?node=<% node %>&req=<% foreach info in infos do %><% #name info %>+<% end %>&msg=<% Web.urlEncode ($"msg") %>">Yes, I want to request these packages.</a> <% end elseif $"req" <> "" then + val node = Web.stoi ($"node"); val pkgs = String.tokens Char.isSpace ($"req"); *************** *** 44,48 **** foreach pkg in pkgs do ! switch AptQuery.query pkg of NONE => ok := false; --- 47,51 ---- foreach pkg in pkgs do ! switch AptQuery.query {node = node, pkg = pkg} of NONE => ok := false; *************** *** 57,61 **** if ok then ! val id = Apt.add (Init.getUserId(), $"req", $"msg"); if not (Apt.notifyNew id) then %><h3>Error sending e-mail notification</h3><% --- 60,64 ---- if ok then ! val id = Apt.add {usr = Init.getUserId(), node = node, data = $"req", msg = $"msg"}; if not (Apt.notifyNew id) then %><h3>Error sending e-mail notification</h3><% *************** *** 73,80 **** --- 76,85 ---- <tr> <td>By:</td> <td colspan="2"><a href="user?id=<% #usr req %>"><% name %></a></td> </tr> <tr> <td>Time:</td> <td colspan="2"><% #stamp req %></td> </tr> + <tr> <td>Node:</td> <td colspan="2"><% Web.html (Init.nodeName (#node req)) %></td> </tr> <tr> <td>Packages:</td><% ref first = true; val pkgs = String.tokens Char.isSpace (#data req); + val debian = Init.nodeDebian (#node req); foreach pkg in pkgs do *************** *** 84,92 **** %></tr><tr> <td></td><% end; ! switch AptQuery.query pkg of NONE => %><td></td> <td><b>Error</b>: Unknown package "<% Web.html pkg %>."</td><% | SOME info => ! %><td align="right"><a href="http://packages.debian.org/testing/<% #section info %>/<% #name info %>"><% #name info %></a></td> <td><% Web.html (#descr info) %></td><% end --- 89,97 ---- %></tr><tr> <td></td><% end; ! switch AptQuery.query {node = #node req, pkg = pkg} of NONE => %><td></td> <td><b>Error</b>: Unknown package "<% Web.html pkg %>."</td><% | SOME info => ! %><td align="right"><a href="http://packages.debian.org/<% debian %>/<% #section info %>/<% #name info %>"><% #name info %></a></td> <td><% Web.html (#descr info) %></td><% end *************** *** 113,120 **** --- 118,127 ---- <tr> <td>By:</td> <td colspan="2"><a href="user?id=<% #usr req %>"><% name %></a></td> </tr> <tr> <td>Time:</td> <td colspan="2"><% #stamp req %></td> </tr> + <tr> <td>Node:</td> <td colspan="2"><% Web.html (Init.nodeName (#node req)) %></td> </tr> <tr> <td>Packages:</td><% ref first = true; val pkgs = String.tokens Char.isSpace (#data req); + val debian = Init.nodeDebian (#node req); foreach pkg in pkgs do *************** *** 124,132 **** %></tr><tr> <td></td><% end; ! switch AptQuery.query pkg of NONE => %><td></td> <td><b>Error</b>: Unknown package "<% Web.html pkg %>."</td><% | SOME info => ! %><td align="right"><a href="http://packages.debian.org/testing/<% #section info %>/<% #name info %>"><% #name info %></a></td> <td><% Web.html (#descr info) %></td><% end --- 131,139 ---- %></tr><tr> <td></td><% end; ! switch AptQuery.query {node = #node req, pkg = pkg} of NONE => %><td></td> <td><b>Error</b>: Unknown package "<% Web.html pkg %>."</td><% | SOME info => ! %><td align="right"><a href="http://packages.debian.org/<% debian %>/<% #section info %>/<% #name info %>"><% #name info %></a></td> <td><% Web.html (#descr info) %></td><% end *************** *** 156,159 **** --- 163,171 ---- <tr> <td>Requestor:</td> <td><a href="user?id=<% #usr req %>"><% #name user %></a></td> </tr> <tr> <td>Time:</td> <td><% #stamp req %></td> </tr> + <tr> <td>Node:</td> <td><select name="node"> + <% foreach node in Init.listNodes () do %> + <option value="<% #id node %>"<% if #id node = #node req then %> selected<% end %>><% Web.html (#name node) %> (<% Web.html (#descr node) %>; Debian <% Web.html (#debian node) %>)</option> + <% end %> + </select> <tr> <td>Status:</td> <td><select name="status"> <option value="0"<% if #status req = Apt.NEW then %> selected<% end %>>New</option> *************** *** 170,179 **** Group.requireGroupName "server"; val id = Web.stoi ($"save"); val req = Apt.lookup id; val oldStatus = #status req; val newStatus = Apt.statusFromInt (Web.stoi ($"status")); ! Apt.modify {req with data = $"pkgs", msg = $"msg", status = newStatus}; if oldStatus <> newStatus then ! if not (Apt.notifyMod (oldStatus, newStatus, Init.getUserName(), id)) then %><h3>Error sending e-mail notification</h3><% end --- 182,192 ---- Group.requireGroupName "server"; val id = Web.stoi ($"save"); + val node = Web.stoi ($"node"); val req = Apt.lookup id; val oldStatus = #status req; val newStatus = Apt.statusFromInt (Web.stoi ($"status")); ! Apt.modify {req with node = node, data = $"pkgs", msg = $"msg", status = newStatus}; if oldStatus <> newStatus then ! if not (Apt.notifyMod {old = oldStatus, new = newStatus, changer = Init.getUserName(), req = id}) then %><h3>Error sending e-mail notification</h3><% end *************** *** 205,208 **** --- 218,226 ---- <form action="apt" method="post"> <table class="blanks"> + <tr> <td>Machine:</td> <td><select name="node"> + <% foreach node in Init.listNodes () do %> + <option value="<% #id node %>"><% Web.html (#name node) %> (<% Web.html (#descr node) %>; Debian <% Web.html (#debian node) %>)</option> + <% end %> + </select></td></tr> <tr> <td>Packages:</td> <td><textarea name="new" rows="10" cols="40" wrap="soft"></textarea></td> </tr> <tr> <td>Reason:</td> <td><textarea name="msg" rows="5" cols="80" wrap="soft"></textarea></td> </tr> --- NEW FILE: requestH.sml --- functor RequestH (T : REQUESTH_IN) :> REQUESTH_OUT = struct open Util Sql Init val table = T.table val seq = table ^ "Seq" datatype status = NEW | INSTALLED | REJECTED type request = { id : int, usr : int, node : int, data : string, msg : string, status : status, stamp : C.timestamp } val statusFromInt = fn 0 => NEW | 1 => INSTALLED | 2 => REJECTED | _ => raise C.Sql "Bad APT request status" val statusToInt = fn NEW => 0 | INSTALLED => 1 | REJECTED => 2 fun statusFromSql v = statusFromInt (C.intFromSql v) fun statusToSql s = C.intToSql (statusToInt s) fun mkRow [id, usr, node, data, msg, status, stamp] = {id = C.intFromSql id, usr = C.intFromSql usr, node = C.intFromSql node, data = C.stringFromSql data, msg = C.stringFromSql msg, status = statusFromSql status, stamp = C.timestampFromSql stamp} | mkRow r = rowError ("APT request", r) fun add {usr, node, data, msg} = let val db = getDb () val id = nextSeq (db, seq) in C.dml db ($`INSERT INTO ^table (id, usr, node, data, msg, status, stamp) VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql node), ^(C.stringToSql data), ^(C.stringToSql msg), 0, CURRENT_TIMESTAMP)`); id end fun modify (req : request) = let val db = getDb () in ignore (C.dml db ($`UPDATE ^table SET usr = ^(C.intToSql (#usr req)), data = ^(C.stringToSql (#data req)), node = ^(C.intToSql (#node req)), msg = ^(C.stringToSql (#msg req)), status = ^(statusToSql (#status req)) WHERE id = ^(C.intToSql (#id req))`)) end fun delete id = ignore (C.dml (getDb ()) ($`DELETE FROM ^table WHERE id = ^(C.intToSql id)`)) fun lookup id = case C.oneOrNoRows (getDb ()) ($`SELECT id, usr, node, data, msg, status, stamp FROM ^table WHERE id = ^(C.intToSql id)`) of SOME row => mkRow row | NONE => raise Fail ($`^table request not found`) fun mkRow' (name :: rest) = (C.stringFromSql name, mkRow rest) | mkRow' r = rowError ("Apt.request'", r) fun list () = C.map (getDb ()) mkRow' ($`SELECT name, ^table.id, usr, node, data, msg, status, stamp FROM ^table JOIN WebUser ON usr = WebUser.id ORDER BY stamp DESC`) fun listOpen () = C.map (getDb ()) mkRow' ($`SELECT name, ^table.id, usr, node, data, msg, status, stamp FROM ^table JOIN WebUser ON usr = WebUser.id WHERE status = 0 ORDER BY stamp DESC`) fun notify f req = let val grp = case Group.groupNameToId T.adminGroup of NONE => 0 | SOME grp => grp val req = lookup req val user = Init.lookupUser (#usr req) val mail = Mail.mopen () fun doOne [name] = let val name = C.stringFromSql name in if name = #name user then () else (Mail.mwrite (mail, name); Mail.mwrite (mail, emailSuffix); Mail.mwrite (mail, ",")) end | doOne r = rowError (table ^ ".doOne", r) in Mail.mwrite (mail, "From: Hcoop Portal <portal"); Mail.mwrite (mail, emailSuffix); Mail.mwrite (mail, ">\nTo: "); Mail.mwrite (mail, #name user); Mail.mwrite (mail, emailSuffix); Mail.mwrite (mail, "\nBcc: "); C.app (getDb ()) doOne ($`SELECT name FROM WebUser JOIN Membership ON (usr = id AND grp = ^(C.intToSql grp))`); Mail.mwrite (mail, "\nSubject: "); Mail.mwrite (mail, T.subject (#data req)); Mail.mwrite (mail, "\n\n"); Mail.mwrite (mail, "Machine: "); Mail.mwrite (mail, Init.nodeName (#node req)); Mail.mwrite (mail, "\n\n"); f (user, mail); T.body {node = #node req, mail = mail, data = #data req}; Mail.mwrite (mail, "\n"); Mail.mwrite (mail, #msg req); Mail.mwrite (mail, "\n\nOpen requests: "); Mail.mwrite (mail, urlPrefix); Mail.mwrite (mail, T.template); Mail.mwrite (mail, "?cmd=open\n"); OS.Process.isSuccess (Mail.mclose mail) end val notifyNew = notify (fn (user, mail) => (Mail.mwrite (mail, #name user); Mail.mwrite (mail, " has requested the following "); Mail.mwrite (mail, T.descr); Mail.mwrite (mail, ":\n\n"))) val statusToString = fn NEW => "New" | INSTALLED => "Installed" | REJECTED => "Rejected" fun notifyMod {old, new, changer, req} = notify (fn (_, mail) => (Mail.mwrite (mail, changer); Mail.mwrite (mail, " has changed the status of this request from "); Mail.mwrite (mail, statusToString old); Mail.mwrite (mail, " to "); Mail.mwrite (mail, statusToString new); Mail.mwrite (mail, ".\n\n"))) req end Index: init.sml =================================================================== RCS file: /cvsroot/hcoop/portal/init.sml,v retrieving revision 1.14 retrieving revision 1.15 diff -C2 -d -r1.14 -r1.15 *** init.sml 30 Aug 2006 04:08:40 -0000 1.14 --- init.sml 25 Feb 2007 21:05:26 -0000 1.15 *************** *** 169,171 **** --- 169,198 ---- C.app db mkApp "SELECT id, name, rname FROM WebUser WHERE app IS NULL" end + + type node = {id : int, name : string, descr : string, debian : string} + + fun mkNodeRow [id, name, descr, debian] = + {id = C.intFromSql id, name = C.stringFromSql name, descr = C.stringFromSql descr, + debian = C.stringFromSql debian} + | mkNodeRow row = rowError ("node", row) + + fun listNodes () = + C.map (getDb ()) mkNodeRow ($`SELECT id, name, descr, debian + FROM WebNode + ORDER BY name`) + + fun nodeName id = + case C.oneRow (getDb ()) ($`SELECT name + FROM WebNode + WHERE id = ^(C.intToSql id)`) of + [name] => C.stringFromSql name + | row => rowError ("nodeName", row) + + fun nodeDebian id = + case C.oneRow (getDb ()) ($`SELECT debian + FROM WebNode + WHERE id = ^(C.intToSql id)`) of + [debian] => C.stringFromSql debian + | row => rowError ("nodeDebian", row) + end Index: aptquery.sig =================================================================== RCS file: /cvsroot/hcoop/portal/aptquery.sig,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** aptquery.sig 19 Apr 2005 19:00:48 -0000 1.1 --- aptquery.sig 25 Feb 2007 21:05:26 -0000 1.2 *************** *** 4,7 **** val validName : string -> bool ! val query : string -> info option end \ No newline at end of file --- 4,7 ---- val validName : string -> bool ! val query : {node : int, pkg : string} -> info option end \ No newline at end of file |
From: Adam C. <ad...@us...> - 2007-02-25 21:04:36
|
Update of /cvsroot/hcoop/domtool2/src In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv326/src Modified Files: main.sml Log Message: Allow DOMTOOL_USER environment variable, to specify Domtool identity Index: main.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/main.sml,v retrieving revision 1.60 retrieving revision 1.61 diff -C2 -d -r1.60 -r1.61 *** main.sml 25 Feb 2007 19:10:37 -0000 1.60 --- main.sml 25 Feb 2007 21:04:33 -0000 1.61 *************** *** 173,178 **** fun requestContext f = let ! val uid = Posix.ProcEnv.getuid () ! val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid) val () = Acl.read Config.aclFile --- 173,185 ---- fun requestContext f = let ! val user = ! case Posix.ProcEnv.getenv "DOMTOOL_USER" of ! NONE => ! let ! val uid = Posix.ProcEnv.getuid () ! in ! Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid) ! end ! | SOME user => user val () = Acl.read Config.aclFile |
From: Adam C. <ad...@us...> - 2007-02-25 19:10:41
|
Update of /cvsroot/hcoop/domtool2/src In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv18972/src Modified Files: main-admin.sml main.sig main.sml msg.sml msgTypes.sml sources Log Message: Firewall rule look-up Index: main.sig =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/main.sig,v retrieving revision 1.36 retrieving revision 1.37 diff -C2 -d -r1.36 -r1.37 *** main.sig 25 Feb 2007 18:43:17 -0000 1.36 --- main.sig 25 Feb 2007 19:10:37 -0000 1.37 *************** *** 75,77 **** --- 75,78 ---- val requestTrustedPath : {node : string, uname : string} -> OS.Process.status val requestSocketPerm : {node : string, uname : string} -> OS.Process.status + val requestFirewall : {node : string, uname : string} -> OS.Process.status end Index: msgTypes.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/msgTypes.sml,v retrieving revision 1.24 retrieving revision 1.25 diff -C2 -d -r1.24 -r1.25 *** msgTypes.sml 25 Feb 2007 18:43:17 -0000 1.24 --- msgTypes.sml 25 Feb 2007 19:10:37 -0000 1.25 *************** *** 38,41 **** --- 38,43 ---- | QSocket of string (* What socket permissions does this user have? *) + | QFirewall of string + (* What firewall rules does this user have? *) datatype msg = *************** *** 109,112 **** --- 111,116 ---- | MsgSocket of socket_permission (* Answer to a QSocket query *) + | MsgFirewall of string list + (* Answer to a QFirewall query *) end Index: main-admin.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/main-admin.sml,v retrieving revision 1.16 retrieving revision 1.17 diff -C2 -d -r1.16 -r1.17 *** main-admin.sml 25 Feb 2007 18:43:16 -0000 1.16 --- main-admin.sml 25 Feb 2007 19:10:37 -0000 1.17 *************** *** 54,56 **** --- 54,57 ---- | ["tpe", node, uname] => OS.Process.exit (Main.requestTrustedPath {node = node, uname = uname}) | ["sockperm", node, uname] => OS.Process.exit (Main.requestSocketPerm {node = node, uname = uname}) + | ["firewall", node, uname] => OS.Process.exit (Main.requestFirewall {node = node, uname = uname}) | _ => print "Invalid command-line arguments\n" Index: sources =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/sources,v retrieving revision 1.12 retrieving revision 1.13 diff -C2 -d -r1.12 -r1.13 *** sources 25 Feb 2007 18:43:17 -0000 1.12 --- sources 25 Feb 2007 19:10:37 -0000 1.13 *************** *** 102,105 **** --- 102,108 ---- plugins/socketPerm.sml + plugins/firewall.sig + plugins/firewall.sml + mail/vmail.sig mail/vmail.sml Index: main.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/main.sml,v retrieving revision 1.59 retrieving revision 1.60 diff -C2 -d -r1.59 -r1.60 *** main.sml 25 Feb 2007 18:43:17 -0000 1.59 --- main.sml 25 Feb 2007 19:10:37 -0000 1.60 *************** *** 752,755 **** --- 752,782 ---- end + fun requestFirewall {node, uname} = + let + val (user, context) = requestContext (fn () => ()) + val bio = OpenSSL.connect (context, if node = Config.masterNode then + dispatcher + else + Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + + val _ = Msg.send (bio, MsgQuery (QFirewall uname)) + + fun loop () = + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + OS.Process.failure) + | SOME m => + case m of + MsgFirewall ls => (app (fn s => (print s; print "\n")) ls; + OS.Process.success) + | MsgError s => (print ("Firewall query failed: " ^ s ^ "\n"); + OS.Process.failure) + | _ => (print "Unexpected server reply.\n"; + OS.Process.failure) + in + loop () + before OpenSSL.close bio + end + fun regenerate context = let *************** *** 842,845 **** --- 869,873 ---- | QTrustedPath user => if TrustedPath.query user then MsgYes else MsgNo | QSocket user => MsgSocket (SocketPerm.query user) + | QFirewall user => MsgFirewall (Firewall.query user) fun describeQuery q = *************** *** 850,853 **** --- 878,882 ---- | QTrustedPath user => "Asked about trusted path settings for user " ^ user | QSocket user => "Asked about socket permissions for user " ^ user + | QFirewall user => "Asked about firewall rules for user " ^ user fun service () = Index: msg.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/msg.sml,v retrieving revision 1.24 retrieving revision 1.25 diff -C2 -d -r1.24 -r1.25 *** msg.sml 25 Feb 2007 18:43:17 -0000 1.24 --- msg.sml 25 Feb 2007 19:10:37 -0000 1.25 *************** *** 116,119 **** --- 116,121 ---- | QSocket s => (OpenSSL.writeInt (bio, 4); OpenSSL.writeString (bio, s)) + | QFirewall s => (OpenSSL.writeInt (bio, 5); + OpenSSL.writeString (bio, s)) fun recvQuery bio = *************** *** 126,129 **** --- 128,132 ---- | 3 => Option.map QTrustedPath (OpenSSL.readString bio) | 4 => Option.map QSocket (OpenSSL.readString bio) + | 5 => Option.map QFirewall (OpenSSL.readString bio) | _ => NONE) | NONE => NONE *************** *** 217,220 **** --- 220,225 ---- | MsgSocket p => (OpenSSL.writeInt (bio, 33); sendSockPerm (bio, p)) + | MsgFirewall ls => (OpenSSL.writeInt (bio, 34); + sendList OpenSSL.writeString (bio, ls)) fun checkIt v = *************** *** 316,319 **** --- 321,325 ---- | 32 => Option.map MsgQuery (recvQuery bio) | 33 => Option.map MsgSocket (recvSockPerm bio) + | 34 => Option.map MsgFirewall (recvList OpenSSL.readString bio) | _ => NONE) |
From: Adam C. <ad...@us...> - 2007-02-25 19:10:41
|
Update of /cvsroot/hcoop/domtool2/src/plugins In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv18972/src/plugins Added Files: firewall.sig firewall.sml Log Message: Firewall rule look-up --- NEW FILE: firewall.sml --- (* HCoop Domtool (http://hcoop.sourceforge.net/) * Copyright (c) 2006-2007, Adam Chlipala * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *) (* Firewall rule querying *) structure Firewall :> FIREWALL = struct fun query uname = let val inf = TextIO.openIn "/etc/firewall/users.rules" fun loop rules = case TextIO.inputLine inf of NONE => List.rev rules | SOME line => if String.sub (line, 0) = #"#" then loop rules else case String.tokens Char.isSpace line of uname'::rest => if uname = uname' then loop (String.concatWith " " rest :: rules) else loop rules | _ => loop rules in loop [] before TextIO.closeIn inf end handle IO.Io _ => [] end --- NEW FILE: firewall.sig --- (* HCoop Domtool (http://hcoop.sourceforge.net/) * Copyright (c) 2006-2007, Adam Chlipala * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *) (* Firewall rule querying *) signature FIREWALL = sig val query : string -> string list (* List a user's local firewall rules. *) end |
From: Adam C. <ad...@us...> - 2007-02-25 18:43:24
|
Update of /cvsroot/hcoop/domtool2/src/plugins In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv7912/src/plugins Modified Files: trustedPath.sml Added Files: socketPerm.sig socketPerm.sml Log Message: Socket permission querying --- NEW FILE: socketPerm.sig --- (* HCoop Domtool (http://hcoop.sourceforge.net/) * Copyright (c) 2006-2007, Adam Chlipala * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *) (* Socket permission settings querying *) signature SOCKET_PERM = sig val query : string -> MsgTypes.socket_permission (* What socket permissions does the named user have on this host? *) end Index: trustedPath.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/plugins/trustedPath.sml,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** trustedPath.sml 25 Feb 2007 18:24:53 -0000 1.1 --- trustedPath.sml 25 Feb 2007 18:43:17 -0000 1.2 *************** *** 21,27 **** structure TrustedPath :> TRUSTED_PATH = struct ! fun query uname = List.exists (fn x => x = uname) ! (Posix.SysDB.Group.members (Posix.SysDB.getgrnam "only-tpe")) ! handle OS.SysErr _ => false end --- 21,25 ---- structure TrustedPath :> TRUSTED_PATH = struct ! fun query uname = Slave.inGroup {group = "only-tpe", user = uname} end --- NEW FILE: socketPerm.sml --- (* HCoop Domtool (http://hcoop.sourceforge.net/) * Copyright (c) 2006-2007, Adam Chlipala * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *) (* Trusted path settings querying *) structure SocketPerm :> SOCKET_PERM = struct open MsgTypes fun query uname = if Slave.inGroup {user = uname, group = "no-sockets"} then Nada else if Slave.inGroup {user = uname, group = "no-cli-sockets"} then if Slave.inGroup {user = uname, group = "no-serv-sockets"} then Nada else Server else if Slave.inGroup {user = uname, group = "no-serv-sockets"} then Client else Any end |
From: Adam C. <ad...@us...> - 2007-02-25 18:43:21
|
Update of /cvsroot/hcoop/domtool2/src In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv7912/src Modified Files: main-admin.sml main.sig main.sml msg.sml msgTypes.sml slave.sig slave.sml sources Log Message: Socket permission querying Index: slave.sig =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/slave.sig,v retrieving revision 1.7 retrieving revision 1.8 diff -C2 -d -r1.7 -r1.8 *** slave.sig 21 Feb 2007 04:22:56 -0000 1.7 --- slave.sig 25 Feb 2007 18:43:17 -0000 1.8 *************** *** 65,67 **** --- 65,70 ---- (* Is there a line in the file (first arg) that matches that given? *) + val inGroup : {user : string, group : string} -> bool + (* Check membership in a UNIX group. *) + end Index: main.sig =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/main.sig,v retrieving revision 1.35 retrieving revision 1.36 diff -C2 -d -r1.35 -r1.36 *** main.sig 25 Feb 2007 18:24:53 -0000 1.35 --- main.sig 25 Feb 2007 18:43:17 -0000 1.36 *************** *** 74,76 **** --- 74,77 ---- val requestFtp : {node : string, uname : string} -> OS.Process.status val requestTrustedPath : {node : string, uname : string} -> OS.Process.status + val requestSocketPerm : {node : string, uname : string} -> OS.Process.status end Index: msgTypes.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/msgTypes.sml,v retrieving revision 1.23 retrieving revision 1.24 diff -C2 -d -r1.23 -r1.24 *** msgTypes.sml 25 Feb 2007 18:24:53 -0000 1.23 --- msgTypes.sml 25 Feb 2007 18:43:17 -0000 1.24 *************** *** 21,24 **** --- 21,30 ---- structure MsgTypes = struct + datatype socket_permission = + Any + | Client + | Server + | Nada + datatype query = QApt of string *************** *** 30,33 **** --- 36,41 ---- | QTrustedPath of string (* Is this user restricted to trusted-path executables? *) + | QSocket of string + (* What socket permissions does this user have? *) datatype msg = *************** *** 99,102 **** --- 107,112 ---- | MsgQuery of query (* Ask for host-specific information *) + | MsgSocket of socket_permission + (* Answer to a QSocket query *) end Index: main-admin.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/main-admin.sml,v retrieving revision 1.15 retrieving revision 1.16 diff -C2 -d -r1.15 -r1.16 *** main-admin.sml 25 Feb 2007 18:24:53 -0000 1.15 --- main-admin.sml 25 Feb 2007 18:43:16 -0000 1.16 *************** *** 53,55 **** --- 53,56 ---- | ["ftp", node, uname] => OS.Process.exit (Main.requestFtp {node = node, uname = uname}) | ["tpe", node, uname] => OS.Process.exit (Main.requestTrustedPath {node = node, uname = uname}) + | ["sockperm", node, uname] => OS.Process.exit (Main.requestSocketPerm {node = node, uname = uname}) | _ => print "Invalid command-line arguments\n" Index: sources =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/sources,v retrieving revision 1.11 retrieving revision 1.12 diff -C2 -d -r1.11 -r1.12 *** sources 25 Feb 2007 18:24:53 -0000 1.11 --- sources 25 Feb 2007 18:43:17 -0000 1.12 *************** *** 99,102 **** --- 99,105 ---- plugins/trustedPath.sml + plugins/socketPerm.sig + plugins/socketPerm.sml + mail/vmail.sig mail/vmail.sml Index: slave.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/slave.sml,v retrieving revision 1.10 retrieving revision 1.11 diff -C2 -d -r1.10 -r1.11 *** slave.sml 21 Feb 2007 04:22:56 -0000 1.10 --- slave.sml 25 Feb 2007 18:43:17 -0000 1.11 *************** *** 196,198 **** --- 196,203 ---- end handle IO.Io _ => false + fun inGroup {user, group} = + List.exists (fn x => x = user) + (Posix.SysDB.Group.members (Posix.SysDB.getgrnam group)) + handle OS.SysErr _ => false + end Index: main.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/main.sml,v retrieving revision 1.58 retrieving revision 1.59 diff -C2 -d -r1.58 -r1.59 *** main.sml 25 Feb 2007 18:24:53 -0000 1.58 --- main.sml 25 Feb 2007 18:43:17 -0000 1.59 *************** *** 721,724 **** --- 721,755 ---- end + fun requestSocketPerm {node, uname} = + let + val (user, context) = requestContext (fn () => ()) + val bio = OpenSSL.connect (context, if node = Config.masterNode then + dispatcher + else + Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + + val _ = Msg.send (bio, MsgQuery (QSocket uname)) + + fun loop () = + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + OS.Process.failure) + | SOME m => + case m of + MsgSocket p => (case p of + Any => print "Any\n" + | Client => print "Client\n" + | Server => print "Server\n" + | Nada => print "Nada\n"; + OS.Process.success) + | MsgError s => (print ("Socket permission query failed: " ^ s ^ "\n"); + OS.Process.failure) + | _ => (print "Unexpected server reply.\n"; + OS.Process.failure) + in + loop () + before OpenSSL.close bio + end + fun regenerate context = let *************** *** 810,813 **** --- 841,845 ---- | QFtp user => if Ftp.allowed user then MsgYes else MsgNo | QTrustedPath user => if TrustedPath.query user then MsgYes else MsgNo + | QSocket user => MsgSocket (SocketPerm.query user) fun describeQuery q = *************** *** 817,820 **** --- 849,853 ---- | QFtp user => "Asked about FTP permissions for user " ^ user | QTrustedPath user => "Asked about trusted path settings for user " ^ user + | QSocket user => "Asked about socket permissions for user " ^ user fun service () = Index: msg.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/msg.sml,v retrieving revision 1.23 retrieving revision 1.24 diff -C2 -d -r1.23 -r1.24 *** msg.sml 25 Feb 2007 18:24:53 -0000 1.23 --- msg.sml 25 Feb 2007 18:43:17 -0000 1.24 *************** *** 89,92 **** --- 89,107 ---- | _ => NONE + fun sendSockPerm (bio, p) = + case p of + Any => OpenSSL.writeInt (bio, 0) + | Client => OpenSSL.writeInt (bio, 1) + | Server => OpenSSL.writeInt (bio, 2) + | Nada => OpenSSL.writeInt (bio, 3) + + fun recvSockPerm bio = + case OpenSSL.readInt bio of + SOME 0 => SOME Any + | SOME 1 => SOME Client + | SOME 2 => SOME Server + | SOME 3 => SOME Nada + | _ => NONE + fun sendQuery (bio, q) = case q of *************** *** 99,102 **** --- 114,119 ---- | QTrustedPath s => (OpenSSL.writeInt (bio, 3); OpenSSL.writeString (bio, s)) + | QSocket s => (OpenSSL.writeInt (bio, 4); + OpenSSL.writeString (bio, s)) fun recvQuery bio = *************** *** 108,111 **** --- 125,129 ---- | 2 => Option.map QFtp (OpenSSL.readString bio) | 3 => Option.map QTrustedPath (OpenSSL.readString bio) + | 4 => Option.map QSocket (OpenSSL.readString bio) | _ => NONE) | NONE => NONE *************** *** 197,200 **** --- 215,220 ---- | MsgQuery q => (OpenSSL.writeInt (bio, 32); sendQuery (bio, q)) + | MsgSocket p => (OpenSSL.writeInt (bio, 33); + sendSockPerm (bio, p)) fun checkIt v = *************** *** 295,298 **** --- 315,319 ---- | 31 => SOME MsgNo | 32 => Option.map MsgQuery (recvQuery bio) + | 33 => Option.map MsgSocket (recvSockPerm bio) | _ => NONE) |
From: Adam C. <ad...@us...> - 2007-02-25 18:24:57
|
Update of /cvsroot/hcoop/domtool2/src In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv326/src Modified Files: main-admin.sml main.sig main.sml msg.sml msgTypes.sml sources Log Message: Trusted-path permission checking Index: main.sig =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/main.sig,v retrieving revision 1.34 retrieving revision 1.35 diff -C2 -d -r1.34 -r1.35 *** main.sig 21 Feb 2007 04:22:56 -0000 1.34 --- main.sig 25 Feb 2007 18:24:53 -0000 1.35 *************** *** 73,75 **** --- 73,76 ---- val requestCron : {node : string, uname : string} -> OS.Process.status val requestFtp : {node : string, uname : string} -> OS.Process.status + val requestTrustedPath : {node : string, uname : string} -> OS.Process.status end Index: msgTypes.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/msgTypes.sml,v retrieving revision 1.22 retrieving revision 1.23 diff -C2 -d -r1.22 -r1.23 *** msgTypes.sml 21 Feb 2007 04:22:56 -0000 1.22 --- msgTypes.sml 25 Feb 2007 18:24:53 -0000 1.23 *************** *** 28,31 **** --- 28,33 ---- | QFtp of string (* Is this user allowed to use FTP? *) + | QTrustedPath of string + (* Is this user restricted to trusted-path executables? *) datatype msg = Index: main-admin.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/main-admin.sml,v retrieving revision 1.14 retrieving revision 1.15 diff -C2 -d -r1.14 -r1.15 *** main-admin.sml 21 Feb 2007 04:22:56 -0000 1.14 --- main-admin.sml 25 Feb 2007 18:24:53 -0000 1.15 *************** *** 52,54 **** --- 52,55 ---- | ["cron", node, uname] => OS.Process.exit (Main.requestCron {node = node, uname = uname}) | ["ftp", node, uname] => OS.Process.exit (Main.requestFtp {node = node, uname = uname}) + | ["tpe", node, uname] => OS.Process.exit (Main.requestTrustedPath {node = node, uname = uname}) | _ => print "Invalid command-line arguments\n" Index: sources =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/sources,v retrieving revision 1.10 retrieving revision 1.11 diff -C2 -d -r1.10 -r1.11 *** sources 21 Feb 2007 04:22:56 -0000 1.10 --- sources 25 Feb 2007 18:24:53 -0000 1.11 *************** *** 96,99 **** --- 96,102 ---- plugins/ftp.sml + plugins/trustedPath.sig + plugins/trustedPath.sml + mail/vmail.sig mail/vmail.sml Index: main.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/main.sml,v retrieving revision 1.57 retrieving revision 1.58 diff -C2 -d -r1.57 -r1.58 *** main.sml 21 Feb 2007 04:22:56 -0000 1.57 --- main.sml 25 Feb 2007 18:24:53 -0000 1.58 *************** *** 692,695 **** --- 692,724 ---- end + fun requestTrustedPath {node, uname} = + let + val (user, context) = requestContext (fn () => ()) + val bio = OpenSSL.connect (context, if node = Config.masterNode then + dispatcher + else + Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + + val _ = Msg.send (bio, MsgQuery (QTrustedPath uname)) + + fun loop () = + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + OS.Process.failure) + | SOME m => + case m of + MsgYes => (print "User has trusted path restriction.\n"; + OS.Process.success) + | MsgNo => (print "User does not have trusted path restriction.\n"; + OS.Process.failure) + | MsgError s => (print ("Trusted path query failed: " ^ s ^ "\n"); + OS.Process.failure) + | _ => (print "Unexpected server reply.\n"; + OS.Process.failure) + in + loop () + before OpenSSL.close bio + end + fun regenerate context = let *************** *** 780,783 **** --- 809,813 ---- | QCron user => if Cron.allowed user then MsgYes else MsgNo | QFtp user => if Ftp.allowed user then MsgYes else MsgNo + | QTrustedPath user => if TrustedPath.query user then MsgYes else MsgNo fun describeQuery q = *************** *** 786,789 **** --- 816,820 ---- | QCron user => "Asked about cron permissions for user " ^ user | QFtp user => "Asked about FTP permissions for user " ^ user + | QTrustedPath user => "Asked about trusted path settings for user " ^ user fun service () = Index: msg.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/msg.sml,v retrieving revision 1.22 retrieving revision 1.23 diff -C2 -d -r1.22 -r1.23 *** msg.sml 21 Feb 2007 04:22:56 -0000 1.22 --- msg.sml 25 Feb 2007 18:24:53 -0000 1.23 *************** *** 97,100 **** --- 97,102 ---- | QFtp s => (OpenSSL.writeInt (bio, 2); OpenSSL.writeString (bio, s)) + | QTrustedPath s => (OpenSSL.writeInt (bio, 3); + OpenSSL.writeString (bio, s)) fun recvQuery bio = *************** *** 105,108 **** --- 107,111 ---- | 1 => Option.map QCron (OpenSSL.readString bio) | 2 => Option.map QFtp (OpenSSL.readString bio) + | 3 => Option.map QTrustedPath (OpenSSL.readString bio) | _ => NONE) | NONE => NONE |
From: Adam C. <ad...@us...> - 2007-02-25 18:24:57
|
Update of /cvsroot/hcoop/domtool2/src/plugins In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv326/src/plugins Added Files: trustedPath.sig trustedPath.sml Log Message: Trusted-path permission checking --- NEW FILE: trustedPath.sig --- (* HCoop Domtool (http://hcoop.sourceforge.net/) * Copyright (c) 2006-2007, Adam Chlipala * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *) (* Trusted path settings querying *) signature TRUSTED_PATH = sig val query : string -> bool (* Is the named user restricted to trusted-path executables on this host? *) end --- NEW FILE: trustedPath.sml --- (* HCoop Domtool (http://hcoop.sourceforge.net/) * Copyright (c) 2006-2007, Adam Chlipala * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *) (* Trusted path settings querying *) structure TrustedPath :> TRUSTED_PATH = struct fun query uname = List.exists (fn x => x = uname) (Posix.SysDB.Group.members (Posix.SysDB.getgrnam "only-tpe")) handle OS.SysErr _ => false end |
Update of /cvsroot/hcoop/domtool2/src In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv14710/src Modified Files: compat_mlton.sml main-admin.sml main.sig main.sml msg.sml msgTypes.sml prefix.mlb slave.sig slave.sml sources Log Message: Cron and FTP queries Index: slave.sig =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/slave.sig,v retrieving revision 1.6 retrieving revision 1.7 diff -C2 -d -r1.6 -r1.7 *** slave.sig 10 Dec 2006 21:36:28 -0000 1.6 --- slave.sig 21 Feb 2007 04:22:56 -0000 1.7 *************** *** 61,63 **** --- 61,67 ---- val writeList : string * string list -> unit (* Reading and writing lists of strings stored on separate lines in files *) + + val lineInFile : string -> string -> bool + (* Is there a line in the file (first arg) that matches that given? *) + end Index: main.sig =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/main.sig,v retrieving revision 1.33 retrieving revision 1.34 diff -C2 -d -r1.33 -r1.34 *** main.sig 21 Feb 2007 03:14:52 -0000 1.33 --- main.sig 21 Feb 2007 04:22:56 -0000 1.34 *************** *** 71,73 **** --- 71,75 ---- val requestApt : {node : string, pkg : string} -> OS.Process.status + val requestCron : {node : string, uname : string} -> OS.Process.status + val requestFtp : {node : string, uname : string} -> OS.Process.status end Index: msgTypes.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/msgTypes.sml,v retrieving revision 1.21 retrieving revision 1.22 diff -C2 -d -r1.21 -r1.22 *** msgTypes.sml 21 Feb 2007 03:43:07 -0000 1.21 --- msgTypes.sml 21 Feb 2007 04:22:56 -0000 1.22 *************** *** 24,27 **** --- 24,31 ---- QApt of string (* Is this apt package installed? *) + | QCron of string + (* Is this user allowed to use cron? *) + | QFtp of string + (* Is this user allowed to use FTP? *) datatype msg = Index: main-admin.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/main-admin.sml,v retrieving revision 1.13 retrieving revision 1.14 diff -C2 -d -r1.13 -r1.14 *** main-admin.sml 21 Feb 2007 03:14:52 -0000 1.13 --- main-admin.sml 21 Feb 2007 04:22:56 -0000 1.14 *************** *** 50,52 **** --- 50,54 ---- | ["slave-ping"] => OS.Process.exit (Main.requestSlavePing ()) | ["package", node, pkg] => OS.Process.exit (Main.requestApt {node = node, pkg = pkg}) + | ["cron", node, uname] => OS.Process.exit (Main.requestCron {node = node, uname = uname}) + | ["ftp", node, uname] => OS.Process.exit (Main.requestFtp {node = node, uname = uname}) | _ => print "Invalid command-line arguments\n" Index: sources =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/sources,v retrieving revision 1.9 retrieving revision 1.10 diff -C2 -d -r1.9 -r1.10 *** sources 21 Feb 2007 03:14:52 -0000 1.9 --- sources 21 Feb 2007 04:22:56 -0000 1.10 *************** *** 90,93 **** --- 90,99 ---- plugins/apt.sml + plugins/cron.sig + plugins/cron.sml + + plugins/ftp.sig + plugins/ftp.sml + mail/vmail.sig mail/vmail.sml Index: slave.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/slave.sml,v retrieving revision 1.9 retrieving revision 1.10 diff -C2 -d -r1.9 -r1.10 *** slave.sml 15 Dec 2006 22:21:39 -0000 1.9 --- slave.sml 21 Feb 2007 04:22:56 -0000 1.10 *************** *** 182,184 **** --- 182,198 ---- end + fun lineInFile fname line = + let + val inf = TextIO.openIn fname + val line' = line ^ "\n" + + fun loop () = + case TextIO.inputLine inf of + NONE => false + | SOME line => line = line' orelse loop () + in + loop () + before TextIO.closeIn inf + end handle IO.Io _ => false + end Index: compat_mlton.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/compat_mlton.sml,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** compat_mlton.sml 9 Dec 2006 02:41:53 -0000 1.1 --- compat_mlton.sml 21 Feb 2007 04:22:56 -0000 1.2 *************** *** 20,21 **** --- 20,27 ---- structure Char = MLRep.Char.Unsigned end + + val _ = let + open MLton.Signal + in + setHandler (Posix.Signal.pipe, Handler.ignore) + end Index: main.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/main.sml,v retrieving revision 1.56 retrieving revision 1.57 diff -C2 -d -r1.56 -r1.57 *** main.sml 21 Feb 2007 03:43:07 -0000 1.56 --- main.sml 21 Feb 2007 04:22:56 -0000 1.57 *************** *** 634,637 **** --- 634,695 ---- end + fun requestCron {node, uname} = + let + val (user, context) = requestContext (fn () => ()) + val bio = OpenSSL.connect (context, if node = Config.masterNode then + dispatcher + else + Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + + val _ = Msg.send (bio, MsgQuery (QCron uname)) + + fun loop () = + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + OS.Process.failure) + | SOME m => + case m of + MsgYes => (print "User has cron permissions.\n"; + OS.Process.success) + | MsgNo => (print "User does not have cron permissions.\n"; + OS.Process.failure) + | MsgError s => (print ("Cron query failed: " ^ s ^ "\n"); + OS.Process.failure) + | _ => (print "Unexpected server reply.\n"; + OS.Process.failure) + in + loop () + before OpenSSL.close bio + end + + fun requestFtp {node, uname} = + let + val (user, context) = requestContext (fn () => ()) + val bio = OpenSSL.connect (context, if node = Config.masterNode then + dispatcher + else + Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + + val _ = Msg.send (bio, MsgQuery (QFtp uname)) + + fun loop () = + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + OS.Process.failure) + | SOME m => + case m of + MsgYes => (print "User has FTP permissions.\n"; + OS.Process.success) + | MsgNo => (print "User does not have FTP permissions.\n"; + OS.Process.failure) + | MsgError s => (print ("FTP query failed: " ^ s ^ "\n"); + OS.Process.failure) + | _ => (print "Unexpected server reply.\n"; + OS.Process.failure) + in + loop () + before OpenSSL.close bio + end + fun regenerate context = let *************** *** 720,727 **** --- 778,789 ---- case q of QApt pkg => if Apt.installed pkg then MsgYes else MsgNo + | QCron user => if Cron.allowed user then MsgYes else MsgNo + | QFtp user => if Ftp.allowed user then MsgYes else MsgNo fun describeQuery q = case q of QApt pkg => "Requested installation status of package " ^ pkg + | QCron user => "Asked about cron permissions for user " ^ user + | QFtp user => "Asked about FTP permissions for user " ^ user fun service () = Index: msg.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/msg.sml,v retrieving revision 1.21 retrieving revision 1.22 diff -C2 -d -r1.21 -r1.22 *** msg.sml 21 Feb 2007 03:43:07 -0000 1.21 --- msg.sml 21 Feb 2007 04:22:56 -0000 1.22 *************** *** 93,96 **** --- 93,100 ---- QApt s => (OpenSSL.writeInt (bio, 0); OpenSSL.writeString (bio, s)) + | QCron s => (OpenSSL.writeInt (bio, 1); + OpenSSL.writeString (bio, s)) + | QFtp s => (OpenSSL.writeInt (bio, 2); + OpenSSL.writeString (bio, s)) fun recvQuery bio = *************** *** 99,102 **** --- 103,108 ---- (case n of 0 => Option.map QApt (OpenSSL.readString bio) + | 1 => Option.map QCron (OpenSSL.readString bio) + | 2 => Option.map QFtp (OpenSSL.readString bio) | _ => NONE) | NONE => NONE Index: prefix.mlb =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/prefix.mlb,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** prefix.mlb 9 Dec 2006 02:41:53 -0000 1.1 --- prefix.mlb 21 Feb 2007 04:22:56 -0000 1.2 *************** *** 10,13 **** compat.sig - compat_mlton.sml --- 10,17 ---- compat.sig + local + $(SML_LIB)/basis/mlton.mlb + in + compat_mlton.sml + end |
From: Adam C. <ad...@us...> - 2007-02-21 04:22:59
|
Update of /cvsroot/hcoop/domtool2/src/plugins In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv14710/src/plugins Added Files: cron.sig cron.sml ftp.sig ftp.sml Log Message: Cron and FTP queries --- NEW FILE: ftp.sig --- (* HCoop Domtool (http://hcoop.sourceforge.net/) * Copyright (c) 2006-2007, Adam Chlipala * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *) (* FTP permissions querying *) signature FTP = sig val allowed : string -> bool (* Is the named user allowed to use FTP here? *) end --- NEW FILE: cron.sml --- (* HCoop Domtool (http://hcoop.sourceforge.net/) * Copyright (c) 2006-2007, Adam Chlipala * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *) (* Cron permissions querying *) structure Cron :> CRON = struct val allowed = Slave.lineInFile "/etc/cron.allow" end --- NEW FILE: cron.sig --- (* HCoop Domtool (http://hcoop.sourceforge.net/) * Copyright (c) 2006-2007, Adam Chlipala * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *) (* Cron permissions querying *) signature CRON = sig val allowed : string -> bool (* Is the named user allowed to use cron here? *) end --- NEW FILE: ftp.sml --- (* HCoop Domtool (http://hcoop.sourceforge.net/) * Copyright (c) 2006-2007, Adam Chlipala * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *) (* FTP permissions querying *) structure Ftp :> FTP = struct val allowed = Slave.lineInFile "/etc/ftpusers" end |
From: Adam C. <ad...@us...> - 2007-02-21 03:43:10
|
Update of /cvsroot/hcoop/domtool2/src In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv31999/src Modified Files: main.sml msg.sml msgTypes.sml Log Message: Testing queries on slave servers Index: msgTypes.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/msgTypes.sml,v retrieving revision 1.20 retrieving revision 1.21 diff -C2 -d -r1.20 -r1.21 *** msgTypes.sml 21 Feb 2007 03:14:52 -0000 1.20 --- msgTypes.sml 21 Feb 2007 03:43:07 -0000 1.21 *************** *** 21,24 **** --- 21,28 ---- structure MsgTypes = struct + datatype query = + QApt of string + (* Is this apt package installed? *) + datatype msg = MsgOk *************** *** 87,92 **** | MsgNo (* Answers to boolean queries *) ! | MsgApt of string ! (* Is this apt package installed on your host? *) end --- 91,96 ---- | MsgNo (* Answers to boolean queries *) ! | MsgQuery of query ! (* Ask for host-specific information *) end Index: main.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/main.sml,v retrieving revision 1.55 retrieving revision 1.56 diff -C2 -d -r1.55 -r1.56 *** main.sml 21 Feb 2007 03:14:52 -0000 1.55 --- main.sml 21 Feb 2007 03:43:07 -0000 1.56 *************** *** 607,613 **** fun requestApt {node, pkg} = let ! val (_, bio) = requestBio (fn () => ()) ! val _ = Msg.send (bio, MsgApt pkg) fun loop () = --- 607,617 ---- fun requestApt {node, pkg} = let ! val (user, context) = requestContext (fn () => ()) ! val bio = OpenSSL.connect (context, if node = Config.masterNode then ! dispatcher ! else ! Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) ! val _ = Msg.send (bio, MsgQuery (QApt pkg)) fun loop () = *************** *** 713,716 **** --- 717,728 ---- fun now () = Date.toString (Date.fromTimeUniv (Time.now ())) + fun answerQuery q = + case q of + QApt pkg => if Apt.installed pkg then MsgYes else MsgNo + + fun describeQuery q = + case q of + QApt pkg => "Requested installation status of package " ^ pkg + fun service () = let *************** *** 1056,1065 **** (fn () => ()) ! | MsgApt pkg => ! doIt (fn () => (Msg.send (bio, if Apt.installed pkg then ! MsgYes ! else ! MsgNo); ! ("User requested installation status of package " ^ pkg, NONE))) (fn () => ()) --- 1068,1074 ---- (fn () => ()) ! | MsgQuery q => ! doIt (fn () => (Msg.send (bio, answerQuery q); ! (describeQuery q, NONE))) (fn () => ()) *************** *** 1135,1141 **** loop ()) else ! (print "Not authorized!\n"; ! OpenSSL.close bio; ! loop ()) end handle OpenSSL.OpenSSL s => (print ("OpenSSL error: "^ s ^ "\n"); --- 1144,1155 ---- loop ()) else ! case Msg.recv bio of ! SOME (MsgQuery q) => (print (describeQuery q ^ "\n"); ! Msg.send (bio, answerQuery q); ! ignore (OpenSSL.readChar bio); ! OpenSSL.close bio; ! loop ()) ! | _ => (OpenSSL.close bio; ! loop ()) end handle OpenSSL.OpenSSL s => (print ("OpenSSL error: "^ s ^ "\n"); Index: msg.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/msg.sml,v retrieving revision 1.20 retrieving revision 1.21 diff -C2 -d -r1.20 -r1.21 *** msg.sml 21 Feb 2007 03:14:52 -0000 1.20 --- msg.sml 21 Feb 2007 03:43:07 -0000 1.21 *************** *** 89,92 **** --- 89,105 ---- | _ => NONE + fun sendQuery (bio, q) = + case q of + QApt s => (OpenSSL.writeInt (bio, 0); + OpenSSL.writeString (bio, s)) + + fun recvQuery bio = + case OpenSSL.readInt bio of + SOME n => + (case n of + 0 => Option.map QApt (OpenSSL.readString bio) + | _ => NONE) + | NONE => NONE + fun send (bio, m) = case m of *************** *** 173,178 **** | MsgYes => OpenSSL.writeInt (bio, 30) | MsgNo => OpenSSL.writeInt (bio, 31) ! | MsgApt s => (OpenSSL.writeInt (bio, 32); ! OpenSSL.writeString (bio, s)) fun checkIt v = --- 186,191 ---- | MsgYes => OpenSSL.writeInt (bio, 30) | MsgNo => OpenSSL.writeInt (bio, 31) ! | MsgQuery q => (OpenSSL.writeInt (bio, 32); ! sendQuery (bio, q)) fun checkIt v = *************** *** 272,276 **** | 30 => SOME MsgYes | 31 => SOME MsgNo ! | 32 => Option.map MsgApt (OpenSSL.readString bio) | _ => NONE) --- 285,289 ---- | 30 => SOME MsgYes | 31 => SOME MsgNo ! | 32 => Option.map MsgQuery (recvQuery bio) | _ => NONE) |
From: Adam C. <ad...@us...> - 2007-02-21 03:14:57
|
Update of /cvsroot/hcoop/domtool2/src/plugins In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv20690/src/plugins Added Files: apt.sig apt.sml Log Message: Apt package installation querying of dispatcher --- NEW FILE: apt.sig --- (* HCoop Domtool (http://hcoop.sourceforge.net/) * Copyright (c) 2006-2007, Adam Chlipala * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *) (* APT package database querying *) signature APT = sig val installed : string -> bool (* Is the named package installed on this host? *) end --- NEW FILE: apt.sml --- (* HCoop Domtool (http://hcoop.sourceforge.net/) * Copyright (c) 2006-2007, Adam Chlipala * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *) (* APT package database querying *) structure Apt :> APT = struct fun validName s = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"_" orelse ch = #"-" orelse ch = #".") s andalso (size s > 0 andalso String.sub (s, 0) <> #"-") fun installed name = validName name andalso OS.Process.isSuccess (OS.Process.system ("/usr/bin/dpkg -p " ^ name ^ " >/dev/null 2>/dev/null")) end |
From: Adam C. <ad...@us...> - 2007-02-21 03:14:57
|
Update of /cvsroot/hcoop/domtool2/src In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv20690/src Modified Files: main-admin.sml main.sig main.sml msg.sml msgTypes.sml sources Log Message: Apt package installation querying of dispatcher Index: main.sig =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/main.sig,v retrieving revision 1.32 retrieving revision 1.33 diff -C2 -d -r1.32 -r1.33 *** main.sig 12 Feb 2007 03:09:02 -0000 1.32 --- main.sig 21 Feb 2007 03:14:52 -0000 1.33 *************** *** 69,71 **** --- 69,73 ---- val requestSmtpLog : string -> unit + + val requestApt : {node : string, pkg : string} -> OS.Process.status end Index: msgTypes.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/msgTypes.sml,v retrieving revision 1.19 retrieving revision 1.20 diff -C2 -d -r1.19 -r1.20 *** msgTypes.sml 11 Feb 2007 22:12:07 -0000 1.19 --- msgTypes.sml 21 Feb 2007 03:14:52 -0000 1.20 *************** *** 84,87 **** --- 84,92 ---- | MsgShutdown (* Halt the server *) + | MsgYes + | MsgNo + (* Answers to boolean queries *) + | MsgApt of string + (* Is this apt package installed on your host? *) end Index: main-admin.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/main-admin.sml,v retrieving revision 1.12 retrieving revision 1.13 diff -C2 -d -r1.12 -r1.13 *** main-admin.sml 12 Feb 2007 03:09:02 -0000 1.12 --- main-admin.sml 21 Feb 2007 03:14:52 -0000 1.13 *************** *** 49,51 **** --- 49,52 ---- | ["slave-shutdown"] => Main.requestSlaveShutdown () | ["slave-ping"] => OS.Process.exit (Main.requestSlavePing ()) + | ["package", node, pkg] => OS.Process.exit (Main.requestApt {node = node, pkg = pkg}) | _ => print "Invalid command-line arguments\n" Index: sources =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/sources,v retrieving revision 1.8 retrieving revision 1.9 diff -C2 -d -r1.8 -r1.9 *** sources 24 Dec 2006 03:30:44 -0000 1.8 --- sources 21 Feb 2007 03:14:52 -0000 1.9 *************** *** 87,90 **** --- 87,93 ---- plugins/mysql.sml + plugins/apt.sig + plugins/apt.sml + mail/vmail.sig mail/vmail.sml Index: main.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/main.sml,v retrieving revision 1.54 retrieving revision 1.55 diff -C2 -d -r1.54 -r1.55 *** main.sml 18 Feb 2007 01:14:28 -0000 1.54 --- main.sml 21 Feb 2007 03:14:52 -0000 1.55 *************** *** 605,608 **** --- 605,633 ---- end + fun requestApt {node, pkg} = + let + val (_, bio) = requestBio (fn () => ()) + + val _ = Msg.send (bio, MsgApt pkg) + + fun loop () = + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + OS.Process.failure) + | SOME m => + case m of + MsgYes => (print "Package is installed.\n"; + OS.Process.success) + | MsgNo => (print "Package is not installed.\n"; + OS.Process.failure) + | MsgError s => (print ("APT query failed: " ^ s ^ "\n"); + OS.Process.failure) + | _ => (print "Unexpected server reply.\n"; + OS.Process.failure) + in + loop () + before OpenSSL.close bio + end + fun regenerate context = let *************** *** 1031,1034 **** --- 1056,1068 ---- (fn () => ()) + | MsgApt pkg => + doIt (fn () => (Msg.send (bio, if Apt.installed pkg then + MsgYes + else + MsgNo); + ("User requested installation status of package " ^ pkg, + NONE))) + (fn () => ()) + | _ => doIt (fn () => ("Unexpected command", Index: msg.sml =================================================================== RCS file: /cvsroot/hcoop/domtool2/src/msg.sml,v retrieving revision 1.19 retrieving revision 1.20 diff -C2 -d -r1.19 -r1.20 *** msg.sml 11 Feb 2007 22:12:07 -0000 1.19 --- msg.sml 21 Feb 2007 03:14:52 -0000 1.20 *************** *** 171,174 **** --- 171,178 ---- OpenSSL.writeString (bio, passwd)) | MsgShutdown => OpenSSL.writeInt (bio, 29) + | MsgYes => OpenSSL.writeInt (bio, 30) + | MsgNo => OpenSSL.writeInt (bio, 31) + | MsgApt s => (OpenSSL.writeInt (bio, 32); + OpenSSL.writeString (bio, s)) fun checkIt v = *************** *** 266,269 **** --- 270,276 ---- | _ => NONE) | 29 => SOME MsgShutdown + | 30 => SOME MsgYes + | 31 => SOME MsgNo + | 32 => Option.map MsgApt (OpenSSL.readString bio) | _ => NONE) |
From: Adam C. <ad...@us...> - 2007-02-21 01:53:37
|
Update of /cvsroot/hcoop/portal In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv21251 Modified Files: config.sml mail.sml mlt.conf money.sml Log Message: Start of modifications for Peer1 migration: hosting bills are apportioned based on pledges Index: config.sml =================================================================== RCS file: /cvsroot/hcoop/portal/config.sml,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** config.sml 22 Oct 2005 17:33:15 -0000 1.1 --- config.sml 21 Feb 2007 01:53:31 -0000 1.2 *************** *** 1,10 **** structure Config :> CONFIG = struct ! val scratchDir = "/home/hcoop" ! val urlPrefix = "https://members.hcoop.net/portal/" val emailSuffix = "@hcoop.net" val boardEmail = "board" ^ emailSuffix ! val dbstring = "dbname='hcoop_hcoop'" end --- 1,10 ---- structure Config :> CONFIG = struct ! val scratchDir = "/afs/hcoop.net/usr/hcoop" ! val urlPrefix = "https://members2.hcoop.net/portal/" val emailSuffix = "@hcoop.net" val boardEmail = "board" ^ emailSuffix ! val dbstring = "dbname='hcoop_hcoop' user='www-data'" end Index: money.sml =================================================================== RCS file: /cvsroot/hcoop/portal/money.sml,v retrieving revision 1.10 retrieving revision 1.11 diff -C2 -d -r1.10 -r1.11 *** money.sml 31 Oct 2006 02:51:07 -0000 1.10 --- money.sml 21 Feb 2007 01:53:31 -0000 1.11 *************** *** 214,232 **** val (umap, amount) = walkNvs (nvs, SM.empty, #amount tran) ! val payers = Group.groupMembers paying ! val even = amount / real (length payers) ! fun doUser (usr : Init.user, umap) = let val (charge, umap) = ! case SM.find (umap, #name usr) of ! NONE => (even, umap) ! | SOME extra => (even - extra, #1 (SM.remove (umap, #name usr))) in ! addCharge {trn = trn, usr = #id usr, amount = charge}; umap end ! val _ = if SM.numItems (foldl doUser umap payers) = 0 then applyCharges trn else --- 214,246 ---- val (umap, amount) = walkNvs (nvs, SM.empty, #amount tran) ! val db = getDb () ! val shares = ! case C.oneRow db ($`SELECT SUM(shares) ! FROM WebUser JOIN Membership ON usr = WebUser.id AND grp = ^(C.intToSql paying)`) of ! [n] => C.intFromSql n ! | row => Init.rowError ("Bad addHostingCharges share count result", row) ! ! val even = amount / real shares ! ! fun doUser ([uid, uname, shares], umap) = let + val uid = C.intFromSql uid + val uname = C.stringFromSql uname + val shares = C.intFromSql shares + val (charge, umap) = ! case SM.find (umap, uname) of ! NONE => (even * real shares, umap) ! | SOME extra => (even * real shares - extra, #1 (SM.remove (umap, uname))) in ! addCharge {trn = trn, usr = uid, amount = charge}; umap end ! val _ = if SM.numItems (C.fold db doUser umap ! ($`SELECT id, name, shares ! FROM WebUser JOIN Membership ON usr = WebUser.id AND grp = ^(C.intToSql paying)`)) ! = 0 then applyCharges trn else Index: mail.sml =================================================================== RCS file: /cvsroot/hcoop/portal/mail.sml,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** mail.sml 24 Sep 2005 17:51:37 -0000 1.2 --- mail.sml 21 Feb 2007 01:53:31 -0000 1.3 *************** *** 4,8 **** fun writeToLog s = let ! val outf = TextIO.openAppend "/home/hcoop/mail.log" in TextIO.output (outf, s); --- 4,8 ---- fun writeToLog s = let ! val outf = TextIO.openAppend (Init.scratchDir ^ "/log/mail.log") in TextIO.output (outf, s); Index: mlt.conf =================================================================== RCS file: /cvsroot/hcoop/portal/mlt.conf,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** mlt.conf 13 Aug 2005 16:26:18 -0000 1.3 --- mlt.conf 21 Feb 2007 01:53:31 -0000 1.4 *************** *** 7,11 **** out out ! pub /home/hcoop/public_html/cgi-bin/portal cm $/smlnj-lib.cm --- 7,11 ---- out out ! pub /afs/hcoop.net/usr/hcoop/home/public_html/cgi-bin/portal cm $/smlnj-lib.cm |
From: Adam C. <ad...@us...> - 2007-02-19 15:56:11
|
Update of /cvsroot/hcoop/portal In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv6985 Modified Files: granter.sh Log Message: Change granter.sh to give permissions to user specified on command line Index: granter.sh =================================================================== RCS file: /cvsroot/hcoop/portal/granter.sh,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** granter.sh 18 Feb 2007 01:47:32 -0000 1.1 --- granter.sh 19 Feb 2007 15:56:03 -0000 1.2 *************** *** 2,6 **** grep "CREATE" tables.sql \ ! | sed 's/^CREATE TABLE \(.*\)($/GRANT SELECT,UPDATE,INSERT,DELETE ON \1 TO "www-data";/g' \ ! | sed 's/^CREATE VIEW \(.*\)$/GRANT SELECT,UPDATE,INSERT,DELETE ON \1 TO "www-data";/g' \ ! | sed 's/^CREATE SEQUENCE \(.*\) START.*$/GRANT SELECT,UPDATE,INSERT,DELETE ON \1 TO "www-data";/g' --- 2,6 ---- grep "CREATE" tables.sql \ ! | sed "s/^CREATE TABLE \(.*\)($/GRANT SELECT,UPDATE,INSERT,DELETE ON \1 TO \"$1\";/g" \ ! | sed "s/^CREATE VIEW \(.*\)$/GRANT SELECT,UPDATE,INSERT,DELETE ON \1 TO \"$1\";/g" \ ! | sed "s/^CREATE SEQUENCE \(.*\) START.*$/GRANT SELECT,UPDATE,INSERT,DELETE ON \1 TO \"$1\";/g" |