Add read-only path type

diff --git a/configDefault/domtool.cfg b/configDefault/domtool.cfg
index 6e6b25e..2ecfa35 100644 (file)
--- a/configDefault/domtool.cfg
+++ b/configDefault/domtool.cfg
@@ -58,3 +58,5 @@ fun domtoolDir user =
        "domtool" => "/afs/hcoop.net/common/etc/domtool/.domtool"
       | _ => OS.Path.joinDirFile {dir = Posix.SysDB.Passwd.home (Posix.SysDB.getpwnam user),
                                  file = ".domtool"}
+
+val worldReadable = ["/usr/share/moin"]

diff --git a/configDefault/domtool.cfs b/configDefault/domtool.cfs
index ab6d470..cf42538 100644 (file)
--- a/configDefault/domtool.cfs
+++ b/configDefault/domtool.cfs
@@ -63,3 +63,5 @@ val mailNodes_all : string list
 val mailNodes_admin : string list
 
 val domtoolDir : string -> string
+
+val worldReadable : string list

diff --git a/elisp/domtool-tables.el b/elisp/domtool-tables.el
index 38acedd..a1ca9f7 100644 (file)
--- a/elisp/domtool-tables.el
+++ b/elisp/domtool-tables.el
@@ -1,5 +1,5 @@
 (defconst domtool-types-regexp
-  (domtool-syms-re "proxy_target" "proxy_port" "mod_rewrite_cond_flag" "mod_rewrite_flag" "rewrite_arg" "redirect_code" "autoindex_option" "autoindex_width" "homedir_path" "dnsRecord" "apache_option" "authType" "location" "ssl" "ssl_cert_path" "suexec_flag" "web_node" "aliasTarget" "aliasSource" "email" "emailUser" "mail_node" "dnsKind" "master" "dns_node" "soa" "serial" "your_path" "your_group" "your_user" "group" "user" "node" "your_domain_host" "your_domain" "domain" "host" "ip" "no_newlines" "no_spaces" "bool" "string" "int")
+  (domtool-syms-re "proxy_target" "proxy_port" "mod_rewrite_cond_flag" "mod_rewrite_flag" "rewrite_arg" "redirect_code" "autoindex_option" "autoindex_width" "homedir_path" "dnsRecord" "apache_option" "authType" "location" "ssl" "ssl_cert_path" "suexec_flag" "web_node" "aliasTarget" "aliasSource" "email" "emailUser" "mail_node" "dnsKind" "master" "dns_node" "soa" "serial" "readable_path" "your_path" "your_group" "your_user" "group" "user" "node" "your_domain_host" "your_domain" "domain" "host" "ip" "no_newlines" "no_spaces" "bool" "string" "int")
   "A regexp that matches Domtool types from the standard library.")
 
 (defconst domtool-contexts-regexp

diff --git a/lib/domain.dtl b/lib/domain.dtl
index f7e8a74..8be8896 100644 (file)
--- a/lib/domain.dtl
+++ b/lib/domain.dtl
@@ -36,10 +36,14 @@ extern type your_group;
 {{UNIX users and groups that you're allowed to run as}}
 
 extern type your_path;
-{{A filesystem path that you're allowed to use.
+{{A filesystem path that you're allowed to write to.
   The set of permitted values is generated from a set of roots by closing it
   under the subdirectory relation.}}
 
+extern type readable_path;
+{{Like [your_path], but also includes some paths that everyone is allowed to
+  read.}}
+
 context Domain;
 {{Configuration directives specific to an Internet domain}}
 

diff --git a/lib/urls.dtl b/lib/urls.dtl
index 89bac62..f403f21 100644 (file)
--- a/lib/urls.dtl
+++ b/lib/urls.dtl
@@ -1,6 +1,6 @@
 {{Basic Apache URL handling}}
 
-extern val alias : location -> your_path -> [Vhost];
+extern val alias : location -> readable_path -> [Vhost];
 {{All requests for the location should be served from the path.}}
 
 extern val scriptAlias : location -> your_path -> [Vhost];

diff --git a/src/domain.sml b/src/domain.sml
index b2c0c5c..4944a34 100644 (file)
--- a/src/domain.sml
+++ b/src/domain.sml
@@ -48,16 +48,26 @@ fun your_groups () = !your_grps
 val your_pths = ref SS.empty
 fun your_paths () = !your_pths
 
+val world_readable = SS.addList (SS.empty, Config.worldReadable)
+val readable_pths = ref SS.empty
+fun readable_paths () = !readable_pths
+
 fun setUser user =
-    (usr := user;
-     your_doms := Acl.class {user = getUser (),
-                            class = "domain"};
-     your_usrs := Acl.class {user = getUser (),
-                            class = "user"};
-     your_grps := Acl.class {user = getUser (),
-                            class = "group"};
-     your_pths := Acl.class {user = getUser (),
-                            class = "path"})
+    let
+       val () = usr := user
+
+       val your_paths = Acl.class {user = getUser (),
+                                   class = "path"}
+    in
+       your_doms := Acl.class {user = getUser (),
+                               class = "domain"};
+       your_usrs := Acl.class {user = getUser (),
+                               class = "user"};
+       your_grps := Acl.class {user = getUser (),
+                               class = "group"};
+       your_pths := your_paths;
+       readable_pths := SS.union (your_paths, world_readable)
+    end
 
 fun validIp s =
     case map Int.fromString (String.fields (fn ch => ch = #".") s) of
@@ -80,11 +90,13 @@ fun validNode s = List.exists (fn s' => s = s') nodes
 fun yourDomain s = SS.member (your_domains (), s)
 fun yourUser s = SS.member (your_users (), s)
 fun yourGroup s = SS.member (your_groups (), s)
-fun yourPath path =
+fun checkPath paths path =
     List.all (fn s => s <> "..") (String.fields (fn ch => ch = #"/") path)
     andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"/"
                                     orelse ch = #"-" orelse ch = #"_") path
-    andalso SS.exists (fn s' => path = s' orelse String.isPrefix (s' ^ "/") path) (your_paths ())
+    andalso SS.exists (fn s' => path = s' orelse String.isPrefix (s' ^ "/") path) (paths ())
+val yourPath = checkPath your_paths
+val readablePath = checkPath readable_paths
 
 fun yourDomainHost s =
     yourDomain s
@@ -161,6 +173,10 @@ val _ = Env.type_one "your_path"
        Env.string
        yourPath
 
+val _ = Env.type_one "readable_path"
+       Env.string
+       readablePath
+
 val _ = Env.type_one "node"
        Env.string
        validNode

diff --git a/src/main.sml b/src/main.sml
index 660c892..4198901 100644 (file)
--- a/src/main.sml
+++ b/src/main.sml
@@ -869,14 +869,20 @@ fun requestFirewall {node, uname} =
        before OpenSSL.close bio
     end
 
-fun regenerate context =
+fun regenerateEither tc checker context =
     let
+       fun ifReal f =
+           if tc then
+               ()
+           else
+               f ()
+
        val _ = ErrorMsg.reset ()
 
        val b = basis ()
        val () = Tycheck.disallowExterns ()
 
-       val () = Domain.resetGlobal ()
+       val () = ifReal Domain.resetGlobal
 
        val ok = ref true
  
@@ -934,7 +940,7 @@ fun regenerate context =
                            (ErrorMsg.reset ();
                             print ("User " ^ user ^ "'s configuration has errors!\n"))
                        else
-                           app eval' files
+                           app checker files
                    end
                else
                    ()
@@ -942,77 +948,23 @@ fun regenerate context =
            handle IO.Io {name, function, ...} =>
                   (print ("IO error processing user " ^ user ^ ": " ^ function ^ ": " ^ name ^ "\n");
                    ok := false)
-                | OS.SysErr (s, _) => (print ("System error processing user " ^ user ^ ": " ^ s ^ "\n");
-                                       ok := false)
+                | exn as OS.SysErr (s, _) => (print ("System error processing user " ^ user ^ ": " ^ s ^ "\n");
+                                              ok := false)
                 | ErrorMsg.Error => (ErrorMsg.reset ();
                                      print ("User " ^ user ^ " had a compilation error.\n");
                                      ok := false)
                 | _ => (print "Unknown exception during regeneration!\n";
                         ok := false)
     in
-       app contactNode Config.nodeIps;
-       Env.pre ();
+       ifReal (fn () => (app contactNode Config.nodeIps;
+                         Env.pre ()));
        app doUser (Acl.users ());
-       Env.post ();
+       ifReal Env.post;
        !ok
     end
 
-fun regenerateTc context =
-    let
-       val _ = ErrorMsg.reset ()
-
-       val b = basis ()
-       val () = Tycheck.disallowExterns ()
-
-       val () = Domain.resetGlobal ()
-
-       val ok = ref true
-
-       fun doUser user =
-           let
-               val _ = Domain.setUser user
-               val _ = ErrorMsg.reset ()
-
-               val dname = Config.domtoolDir user
-           in
-               if Posix.FileSys.access (dname, []) then
-                   let
-                       val dir = Posix.FileSys.opendir dname
-
-                       fun loop files =
-                           case Posix.FileSys.readdir dir of
-                               NONE => (Posix.FileSys.closedir dir;
-                                        files)
-                             | SOME fname =>
-                               if notTmp fname then
-                                   loop (OS.Path.joinDirFile {dir = dname,
-                                                              file = fname}
-                                         :: files)
-                               else
-                                   loop files
-
-                       val files = loop []
-                       val (_, files) = Order.order (SOME b) files
-                   in
-                       if !ErrorMsg.anyErrors then
-                           (ErrorMsg.reset ();
-                            print ("User " ^ user ^ "'s configuration has errors!\n");
-                            ok := false)
-                       else
-                           app (ignore o check) files
-                   end
-               else
-                   ()
-           end
-           handle IO.Io _ => ()
-                | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n")
-                | ErrorMsg.Error => (ErrorMsg.reset ();
-                                     print ("User " ^ user ^ " had a compilation error.\n"))
-                | _ => print "Unknown exception during -tc regeneration!\n"
-    in
-       app doUser (Acl.users ());
-       !ok
-    end
+val regenerate = regenerateEither false eval'
+val regenerateTc = regenerateEither true (ignore o check)
 
 fun rmuser user =
     let