From 998ed17495b77c478978f547c154e28d96a03357 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 15 Nov 2007 13:47:11 +0000 Subject: [PATCH] Add read-only path type --- configDefault/domtool.cfg | 2 + configDefault/domtool.cfs | 2 + elisp/domtool-tables.el | 2 +- lib/domain.dtl | 6 ++- lib/urls.dtl | 2 +- src/domain.sml | 38 +++++++++++++------ src/main.sml | 80 ++++++++------------------------------- 7 files changed, 54 insertions(+), 78 deletions(-) diff --git a/configDefault/domtool.cfg b/configDefault/domtool.cfg index 6e6b25e..2ecfa35 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 -- 2.20.1