From 00a13ad8579e0ee0d950d3b944429551de3bf532 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sat, 17 Feb 2007 21:18:43 +0000
Subject: [PATCH] Allow vetoing of suexec

---
 lib/apache.dtl         |  8 +++++++-
 src/plugins/apache.sml | 36 ++++++++++++++++++++++++++++--------
 2 files changed, 35 insertions(+), 9 deletions(-)

diff --git a/lib/apache.dtl b/lib/apache.dtl
index 1e5d54e..d80d7ef 100644
--- a/lib/apache.dtl
+++ b/lib/apache.dtl
@@ -8,13 +8,19 @@ extern val web_node_to_node : web_node -> node;
 context Vhost;
 {{A WWW virtual host}}
 
+extern type suexec_flag;
+extern val suexec_flag : bool -> suexec_flag;
+{{Whether or not to use Suexec with a vhost.
+[suexec_flag] fails when passed [false] by a user without the 'www' privilege.}}
+
 extern val vhost : host -> Vhost => [Domain]
 	{WebNodes : [web_node],
 	 SSL : bool,
 	 User : your_user,
 	 Group : your_group,
 	 DocumentRoot : your_path,
-	 ServerAdmin : email};
+	 ServerAdmin : email,
+	 SuExec : suexec_flag};
 {{Add a new named Apache virtual host, specifying which nodes' Apache servers
   should answer requests for this host, whether it should use SSL, what UNIX
   user and group dynamic content generators should be run as, the filesystem
diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml
index 65ba7fb..3d7c199 100644
--- a/src/plugins/apache.sml
+++ b/src/plugins/apache.sml
@@ -58,6 +58,10 @@ val _ = Env.type_one "rewrite_arg"
 	Env.string
 	(CharVector.all Char.isAlphaNum)
 
+val _ = Env.type_one "suexec_flag"
+	Env.bool
+	(fn b => b orelse Domain.hasPriv "www")
+
 fun validLocation s =
     size s > 0 andalso size s < 1000 andalso CharVector.all
 						 (fn ch => Char.isAlphaNum ch
@@ -96,6 +100,10 @@ val _ = Defaults.registerDefault ("ServerAdmin",
 				  (TBase "email", dl),
 				  (fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl)))
 
+val _ = Defaults.registerDefault ("SuExec",
+				  (TBase "suexec_flag", dl),
+				  (fn () => (EApp ((EVar "suexec_flag", dl),
+						   (EVar "true", dl)), dl)))
 
 val redirect_code = fn (EVar "temp", _) => SOME "temp"
 		     | (EVar "permanent", _) => SOME "permanent"
@@ -194,9 +202,12 @@ fun findVhostUser fname =
 	    case TextIO.inputLine inf of
 		NONE => NONE
 	      | SOME line =>
-		case String.tokens Char.isSpace line of
-		    ["SuexecUserGroup", user, _] => SOME user
-		  | _ => loop ()
+		if String.isPrefix "# Owner: " line then
+		    case String.tokens Char.isSpace line of
+			[_, _, user] => SOME user
+		      | _ => NONE
+		else
+		    loop ()
     in
 	loop ()
 	before TextIO.closeIn inf
@@ -310,6 +321,9 @@ fun registerAliaser f =
 	aliaser := (fn x => (old x; f x))
     end
 
+fun suexec_flag (EApp ((EVar "suexec_flag", _), e), _) = Env.bool e
+  | suexec_flag _ = NONE
+
 val () = Env.containerV_one "vhost"
 	 ("host", Env.string)
 	 (fn (env, host) =>
@@ -321,6 +335,7 @@ val () = Env.containerV_one "vhost"
 		 val group = Env.env Env.string (env, "Group")
 		 val docroot = Env.env Env.string (env, "DocumentRoot")
 		 val sadmin = Env.env Env.string (env, "ServerAdmin")
+		 val suexec = Env.env suexec_flag (env, "SuExec")
 
 		 val fullHost = host ^ "." ^ Domain.currentDomain ()
 		 val vhostId = fullHost ^ (if ssl then ".ssl" else "")
@@ -336,7 +351,9 @@ val () = Env.containerV_one "vhost"
 					   val file = Domain.domainFile {node = node,
 									 name = confFile}
 				       in
-					   TextIO.output (file, "<VirtualHost ");
+					   TextIO.output (file, "# Owner: ");
+					   TextIO.output (file, user);
+					   TextIO.output (file, "\n<VirtualHost ");
 					   TextIO.output (file, Domain.nodeIp node);
 					   TextIO.output (file, ":");
 					   TextIO.output (file, if ssl then
@@ -367,10 +384,13 @@ val () = Env.containerV_one "vhost"
 				   nodes;
 		 write "\tServerName ";
 		 write fullHost;
-		 write "\n\tSuexecUserGroup ";
-		 write user;
-		 write " ";
-		 write group;
+		 if suexec then
+		     (write "\n\tSuexecUserGroup ";
+		      write user;
+		      write " ";
+		      write group)
+		 else
+		     ();
 		 write "\n\tDocumentRoot ";
 		 write docroot;
 		 write "\n\tServerAdmin ";
-- 
2.20.1