X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/f8dfbbcc29a40de94580697e610db6254b85f0fb..976657583f419a6a204400ea90f9758d15243acb:/src/plugins/apache.sml

diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml
index faa2c65..ffd18b2 100644
--- a/src/plugins/apache.sml
+++ b/src/plugins/apache.sml
@@ -24,37 +24,66 @@ open Ast
 
 val _ = Env.type_one "proxy_port"
 	Env.int
-	(fn n => n >= 1024)
+	(fn n => n > 1024)
+
+val _ = Env.type_one "proxy_target"
+	Env.string
+	(fn s =>
+	    let
+		fun default () = List.exists (fn s' => s = s') Config.Apache.proxyTargets
+	    in
+		case String.fields (fn ch => ch = #":") s of
+		    ["http", "//localhost", rest] =>
+		    (case String.fields (fn ch => ch = #"/") rest of
+			 port :: _ =>
+			 (case Int.fromString port of
+			      NONE => default ()
+			    | SOME n => n > 1024 orelse default ())
+		       | _ => default ())
+		  | _ => default ()
+	    end)
 
 val _ = Env.type_one "rewrite_arg"
 	Env.string
 	(CharVector.all Char.isAlphaNum)
 
+fun validLocation s =
+    size s > 0 andalso size s < 1000 andalso CharVector.all
+						 (fn ch => Char.isAlphaNum ch
+							   orelse ch = #"-"
+							   orelse ch = #"_"
+							   orelse ch = #"."
+							   orelse ch = #"/") s
+
+val _ = Env.type_one "location"
+	Env.string
+	validLocation
+
 val dl = ErrorMsg.dummyLoc
 
-val _ = Main.registerDefault ("WebNodes",
-			      (TList (TBase "node", dl), dl),
-			      (fn () => (EList (map (fn s => (EString s, dl)) Config.Apache.webNodes), dl)))
+val _ = Defaults.registerDefault ("WebNodes",
+				  (TList (TBase "node", dl), dl),
+				  (fn () => (EList (map (fn s => (EString s, dl)) Config.Apache.webNodes), dl)))
 
-val _ = Main.registerDefault ("SSL",
-			      (TBase "bool", dl),
-			      (fn () => (EVar "false", dl)))
+val _ = Defaults.registerDefault ("SSL",
+				  (TBase "bool", dl),
+				  (fn () => (EVar "false", dl)))
 
-val _ = Main.registerDefault ("User",
-			      (TBase "your_user", dl),
-			      (fn () => (EString (Domain.getUser ()), dl)))
+val _ = Defaults.registerDefault ("User",
+				  (TBase "your_user", dl),
+				  (fn () => (EString (Domain.getUser ()), dl)))
 
-val _ = Main.registerDefault ("Group",
-			      (TBase "your_group", dl),
-			      (fn () => (EString (Domain.getUser ()), dl)))
+val _ = Defaults.registerDefault ("Group",
+				  (TBase "your_group", dl),
+				  (fn () => (EString (Domain.getUser ()), dl)))
 
-val _ = Main.registerDefault ("DocumentRoot",
-			      (TBase "your_path", dl),
-			      (fn () => (EString ("/home/" ^ Domain.getUser () ^ "/public_html"), dl)))
+val _ = Defaults.registerDefault ("DocumentRoot",
+				  (TBase "your_path", dl),
+				  (fn () => (EString (Config.homeBase ^ "/" ^ Domain.getUser () ^ "/public_html"), dl)))
 
-val _ = Main.registerDefault ("ServerAdmin",
-			      (TBase "email", dl),
-			      (fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl)))
+val _ = Defaults.registerDefault ("ServerAdmin",
+				  (TBase "email", dl),
+				  (fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl)))
 
 
 val redirect_code = fn (EVar "temp", _) => SOME "temp"
@@ -93,6 +122,51 @@ val flag = fn (EVar "redirect", _) => SOME "R"
 
 	    | _ => NONE
 
+val cond_flag = fn (EVar "cond_nocase", _) => SOME "NC"
+	    | (EVar "ornext", _) => SOME "OR"
+	    | _ => NONE
+
+val apache_option = fn (EVar "execCGI", _) => SOME "ExecCGI"
+		     | (EVar "includesNOEXEC", _) => SOME "IncludesNOEXEC"
+		     | (EVar "indexes", _) => SOME "Indexes"
+		     | _ => NONE
+
+val autoindex_width = fn (EVar "autofit", _) => SOME "*"
+		       | (EApp ((EVar "characters", _), n), _) =>
+			 Option.map Int.toString (Env.int n)
+		       | _ => NONE
+
+val autoindex_option = fn (EApp ((EVar "descriptionWidth", _), w), _) =>
+			  Option.map (fn w => ("DescriptionWidth", SOME w))
+			  (autoindex_width w)
+			| (EVar "fancyIndexing", _) => SOME ("FancyIndexing", NONE)
+			| (EVar "foldersFirst", _) => SOME ("FoldersFirst", NONE)
+			| (EVar "htmlTable", _) => SOME ("HTMLTable", NONE)
+			| (EVar "iconsAreLinks", _) => SOME ("IconsAreLinks", NONE)
+			| (EApp ((EVar "iconHeight", _), n), _) =>
+			  Option.map (fn w => ("IconHeight", SOME (Int.toString w)))
+				     (Env.int n)
+			| (EApp ((EVar "iconWidth", _), n), _) =>
+			  Option.map (fn w => ("IconWidth", SOME (Int.toString w)))
+				     (Env.int n)
+			| (EVar "ignoreCase", _) => SOME ("IgnoreCase", NONE)
+			| (EVar "ignoreClient", _) => SOME ("IgnoreClient", NONE)
+			| (EApp ((EVar "nameWidth", _), w), _) =>
+			  Option.map (fn w => ("NameWidth", SOME w))
+				     (autoindex_width w)
+			| (EVar "scanHtmlTitles", _) => SOME ("ScanHTMLTitles", NONE)
+			| (EVar "suppressColumnSorting", _) => SOME ("SuppressColumnSorting", NONE)
+			| (EVar "suppressDescription", _) => SOME ("SuppressDescription", NONE)
+			| (EVar "suppressHtmlPreamble", _) => SOME ("SuppressHTMLPreamble", NONE)
+			| (EVar "suppressIcon", _) => SOME ("SuppressIcon", NONE)
+			| (EVar "suppressLastModified", _) => SOME ("SuppressLastModified", NONE)
+			| (EVar "suppressRules", _) => SOME ("SuppressRules", NONE)
+			| (EVar "suppressSize", _) => SOME ("SuppressSize", NONE)
+			| (EVar "trackModified", _) => SOME ("TrackModified", NONE)
+			| (EVar "versionSort", _) => SOME ("VersionSort", NONE)
+			| (EVar "xhtml", _) => SOME ("XHTML", NONE)
+
+			| _ => NONE
 
 val vhostsChanged = ref false
 
@@ -108,11 +182,18 @@ val () = Slave.registerFileHandler (fn fs =>
 					       (vhostsChanged := true;
 						case #action fs of
 						    Slave.Delete =>
-						    ignore (OS.Process.system (Config.rm
-									       ^ " -rf "
-									       ^ Config.Apache.confDir
-									       ^ "/"
-									       ^ #file spl))
+						    (ignore (OS.Process.system (Config.rm
+										^ " -rf "
+										^ Config.Apache.confDir
+										^ "/"
+										^ #file spl));
+						     ignore (OS.Process.system (Config.rm
+										^ " -rf "
+										^ Config.Apache.logDir
+										^ "/"
+										^ #base (OS.Path.splitBaseExt 
+											     (#file spl)))))
+							    
 						  | _ =>
 						    ignore (OS.Process.system (Config.cp
 									       ^ " "
@@ -137,6 +218,32 @@ val vhostFiles : TextIO.outstream list ref = ref []
 fun write s = app (fn file => TextIO.output (file, s)) (!vhostFiles)
 
 val rewriteEnabled = ref false
+val currentVhost = ref ""
+val currentVhostId = ref ""
+
+val pre = ref (fn _ : {nodes : string list, id : string, hostname : string} => ())
+fun registerPre f =
+    let
+	val old = !pre
+    in
+	pre := (fn x => (old x; f x))
+    end
+
+val post = ref (fn () => ())
+fun registerPost f =
+    let
+	val old = !post
+    in
+	post := (fn () => (old (); f ()))
+    end
+
+val aliaser = ref (fn _ : string => ())
+fun registerAliaser f =
+    let
+	val old = !aliaser
+    in
+	aliaser := (fn x => (old x; f x))
+    end
 
 val () = Env.containerV_one "vhost"
 	 ("host", Env.string)
@@ -151,8 +258,12 @@ val () = Env.containerV_one "vhost"
 		 val sadmin = Env.env Env.string (env, "ServerAdmin")
 
 		 val fullHost = host ^ "." ^ Domain.currentDomain ()
+		 val vhostId = fullHost ^ (if ssl then ".ssl" else "")
 		 val confFile = fullHost ^ (if ssl then ".vhost_ssl" else ".vhost")
 	     in
+		 currentVhost := fullHost;
+		 currentVhostId := vhostId;
+
 		 rewriteEnabled := false;
 		 vhostFiles := map (fn node =>
 				       let
@@ -170,7 +281,9 @@ val () = Env.containerV_one "vhost"
 					   file
 				       end)
 				   nodes;
-		 write "\tSuexecUserGroup ";
+		 write "\tServerName ";
+		 write fullHost;
+		 write "\n\tSuexecUserGroup ";
 		 write user;
 		 write " ";
 		 write group;
@@ -178,11 +291,37 @@ val () = Env.containerV_one "vhost"
 		 write docroot;
 		 write "\n\tServerAdmin ";
 		 write sadmin;
-		 write "\n"
+		 write "\n\tErrorLog ";
+		 write Config.Apache.logDir;
+		 write "/";
+		 write vhostId;
+		 write "/error.log\n\tCustomLog ";
+		 write Config.Apache.logDir;
+		 write "/";
+		 write vhostId;
+		 write "/access.log combined\n";
+		 !pre {nodes = nodes, id = vhostId, hostname = fullHost}
 	     end,
-	  fn () => (write "</VirtualHost>\n";
+	  fn () => (!post ();
+		    write "</VirtualHost>\n";
 		    app TextIO.closeOut (!vhostFiles)))
 
+val () = Env.container_one "location"
+	 ("prefix", Env.string)
+	 (fn prefix =>
+	     (write "\t<Location ";
+	      write prefix;
+	      write ">\n"),
+	  fn () => write "\t</Location>\n")
+
+val () = Env.container_one "directory"
+	 ("directory", Env.string)
+	 (fn directory =>
+	     (write "\t<Directory ";
+	      write directory;
+	      write ">\n"),
+	  fn () => write "\t</Directory>\n")
+
 fun checkRewrite () =
     if !rewriteEnabled then
 	()
@@ -202,45 +341,23 @@ val () = Env.action_three "localProxyRewrite"
 	      write to;
 	      write " [P]\n"))
 
-val () = Env.action_three "localProxyPass"
-	 ("from", Env.string, "to", Env.string, "port", Env.int)
-	 (fn (from, to, port) =>
-	     let
-		 val to =
-		     case to of
-			 "" => "/"
-		       | _ => if String.sub (to, 0) = #"/" then
-				  to
-			      else
-				  "/" ^ to
-	     in
-		 write "\tProxyPass\t";
-		 write from;
-		 write "\thttp://localhost:";
-		 write (Int.toString port);
-		 write to;
-		 write "\n"
-	     end)
-
-val () = Env.action_three "localProxyPassReverse"
-	 ("from", Env.string, "to", Env.string, "port", Env.int)
-	 (fn (from, to, port) =>
-	     let
-		 val to =
-		     case to of
-			 "" => "/"
-		       | _ => if String.sub (to, 0) = #"/" then
-				  to
-			      else
-				  "/" ^ to
-	     in
-		 write "\tProxyPassReverse\t";
-		 write from;
-		 write "\thttp://localhost:";
-		 write (Int.toString port);
-		 write to;
-		 write "\n"
-	     end)
+val () = Env.action_two "proxyPass"
+	 ("from", Env.string, "to", Env.string)
+	 (fn (from, to) =>
+		 (write "\tProxyPass\t";
+		  write from;
+		  write "\t";
+		  write to;
+		  write "\n"))
+
+val () = Env.action_two "proxyPassReverse"
+	 ("from", Env.string, "to", Env.string)
+	 (fn (from, to) =>
+		 (write "\tProxyPassReverse\t";
+		  write from;
+		  write "\t";
+		  write to;
+		  write "\n"))
 
 val () = Env.action_three "rewriteRule"
 	 ("from", Env.string, "to", Env.string, "flags", Env.list flag)
@@ -259,4 +376,279 @@ val () = Env.action_three "rewriteRule"
 				 write "]");
 	      write "\n"))
 
+val () = Env.action_three "rewriteCond"
+	 ("test", Env.string, "pattern", Env.string, "flags", Env.list cond_flag)
+	 (fn (from, to, flags) =>
+	     (checkRewrite ();
+	      write "\tRewriteCond\t";
+	      write from;
+	      write "\t";
+	      write to;
+	      case flags of
+		  [] => ()
+		| flag::rest => (write " [";
+				 write flag;
+				 app (fn flag => (write ",";
+						  write flag)) rest;
+				 write "]");
+	      write "\n"))
+
+val () = Env.action_one "rewriteLogLevel"
+	 ("level", Env.int)
+	 (fn level =>
+	     (checkRewrite ();
+	      write "\tRewriteLog ";
+	      write Config.Apache.logDir;
+	      write "/";
+	      write (!currentVhostId);
+	      write "/rewrite.log\n\tRewriteLogLevel ";
+	      write (Int.toString level);
+	      write "\n"))
+
+val () = Env.action_two "alias"
+	 ("from", Env.string, "to", Env.string)
+	 (fn (from, to) =>
+	     (write "\tAlias\t";
+	      write from;
+	      write " ";
+	      write to;
+	      write "\n"))
+
+val () = Env.action_two "scriptAlias"
+	 ("from", Env.string, "to", Env.string)
+	 (fn (from, to) =>
+	     (write "\tScriptAlias\t";
+	      write from;
+	      write " ";
+	      write to;
+	      write "\n"))
+
+val () = Env.action_two "errorDocument"
+	 ("code", Env.string, "handler", Env.string)
+	 (fn (code, handler) =>
+	     (write "\tErrorDocument\t";
+	      write code;
+	      write " ";
+	      write handler;
+	      write "\n"))
+
+val () = Env.action_one "options"
+	 ("options", Env.list apache_option)
+	 (fn opts =>
+	     case opts of
+		 [] => ()
+	       | _ => (write "\tOptions";
+		       app (fn opt => (write " "; write opt)) opts;
+		       write "\n"))
+
+val () = Env.action_one "set_options"
+	 ("options", Env.list apache_option)
+	 (fn opts =>
+	     case opts of
+		 [] => ()
+	       | _ => (write "\tOptions";
+		       app (fn opt => (write " +"; write opt)) opts;
+		       write "\n"))
+
+val () = Env.action_one "unset_options"
+	 ("options", Env.list apache_option)
+	 (fn opts =>
+	     case opts of
+		 [] => ()
+	       | _ => (write "\tOptions";
+		       app (fn opt => (write " -"; write opt)) opts;
+		       write "\n"))
+
+val () = Env.action_one "directoryIndex"
+	 ("filenames", Env.list Env.string)
+	 (fn opts =>
+	     (write "\tDirectoryIndex";
+	      app (fn opt => (write " "; write opt)) opts;
+	      write "\n"))
+
+val () = Env.action_one "serverAlias"
+	 ("host", Env.string)
+	 (fn host =>
+	     (write "\tServerAlias ";
+	      write host;
+	      write "\n";
+	      !aliaser host))
+
+val authType = fn (EVar "basic", _) => SOME "basic"
+		| (EVar "digest", _) => SOME "digest"
+		| _ => NONE
+
+val () = Env.action_one "authType"
+	 ("type", authType)
+	 (fn ty =>
+	     (write "\tAuthType ";
+	      write ty;
+	      write "\n"))
+
+val () = Env.action_one "authName"
+	 ("name", Env.string)
+	 (fn name =>
+	     (write "\tAuthName \"";
+	      write name;
+	      write "\"\n"))
+
+val () = Env.action_one "authUserFile"
+	 ("file", Env.string)
+	 (fn name =>
+	     (write "\tAuthUserFile ";
+	      write name;
+	      write "\n"))
+
+val () = Env.action_none "requireValidUser"
+	 (fn () => write "\tRequire valid-user\n")
+
+val () = Env.action_one "requireUser"
+	 ("users", Env.list Env.string)
+	 (fn names =>
+	     case names of
+		 [] => ()
+	       | _ => (write "\tRequire user";
+		       app (fn name => (write " "; write name)) names;
+		       write "\n"))
+
+val () = Env.action_one "requireGroup"
+	 ("groups", Env.list Env.string)
+	 (fn names =>
+	     case names of
+		 [] => ()
+	       | _ => (write "\tRequire group";
+		       app (fn name => (write " "; write name)) names;
+		       write "\n"))
+
+val () = Env.action_none "orderAllowDeny"
+	 (fn () => write "\tOrder allow,deny\n")
+
+val () = Env.action_none "orderDenyAllow"
+	 (fn () => write "\tOrder deny,allow\n")
+
+val () = Env.action_none "allowFromAll"
+	 (fn () => write "\tAllow from all\n")
+
+val () = Env.action_one "allowFrom"
+	 ("entries", Env.list Env.string)
+	 (fn names =>
+	     case names of
+		 [] => ()
+	       | _ => (write "\tAllow from";
+		       app (fn name => (write " "; write name)) names;
+		       write "\n"))
+
+val () = Env.action_none "denyFromAll"
+	 (fn () => write "\tDeny from all\n")
+
+val () = Env.action_one "denyFrom"
+	 ("entries", Env.list Env.string)
+	 (fn names =>
+	     case names of
+		 [] => ()
+	       | _ => (write "\tDeny from";
+		       app (fn name => (write " "; write name)) names;
+		       write "\n"))
+
+val () = Env.action_none "satisfyAll"
+	 (fn () => write "\tSatisfy all\n")
+
+val () = Env.action_none "satisfyAny"
+	 (fn () => write "\tSatisfy any\n")
+
+val () = Env.action_one "forceType"
+	 ("type", Env.string)
+	 (fn ty => (write "\tForceType ";
+		    write ty;
+		    write "\n"))
+
+val () = Env.action_none "forceTypeOff"
+	 (fn () => write "\tForceType None\n")
+
+val () = Env.action_two "action"
+	 ("what", Env.string, "how", Env.string)
+	 (fn (what, how) => (write "\tAction ";
+			     write what;
+			     write " ";
+			     write how;
+			     write "\n"))
+
+val () = Env.action_one "addDefaultCharset"
+	 ("charset", Env.string)
+	 (fn ty => (write "\tAddDefaultCharset ";
+		    write ty;
+		    write "\n"))
+
+val () = Env.action_one "davSvn"
+	 ("path", Env.string)
+	 (fn path => (write "\tDAV svn\n\tSVNPath ";
+		      write path;
+		      write "\n"))
+
+val () = Env.action_one "authzSvnAccessFile"
+	 ("path", Env.string)
+	 (fn path => (write "\tAuthzSVNAccessFile ";
+		      write path;
+		      write "\n"))
+
+val () = Env.action_two "addDescription"
+	 ("description", Env.string, "patterns", Env.list Env.string)
+	 (fn (desc, pats) =>
+	     case pats of
+		 [] => ()
+	       | _ => (write "\tAddDescription \"";
+		       write (String.toString desc);
+		       write "\"";
+		       app (fn pat => (write " "; write pat)) pats;
+		       write "\n"))
+
+val () = Env.action_one "indexOptions"
+	 ("options", Env.list autoindex_option)
+	 (fn opts =>
+	     case opts of
+		 [] => ()
+	       | _ => (write "\tIndexOptions";
+		       app (fn (opt, arg) =>
+			       (write " ";
+				write opt;
+				Option.app (fn arg =>
+					       (write "="; write arg)) arg)) opts;
+		       write "\n"))
+
+val () = Env.action_one "set_indexOptions"
+	 ("options", Env.list autoindex_option)
+	 (fn opts =>
+	     case opts of
+		 [] => ()
+	       | _ => (write "\tIndexOptions";
+		       app (fn (opt, arg) =>
+			       (write " +";
+				write opt;
+				Option.app (fn arg =>
+					       (write "="; write arg)) arg)) opts;
+		       write "\n"))
+
+val () = Env.action_one "unset_indexOptions"
+	 ("options", Env.list autoindex_option)
+	 (fn opts =>
+	     case opts of
+		 [] => ()
+	       | _ => (write "\tIndexOptions";
+		       app (fn (opt, _) =>
+			       (write " -";
+				write opt)) opts;
+		       write "\n"))
+
+val () = Env.action_one "headerName"
+	 ("name", Env.string)
+	 (fn name => (write "\tHeaderName ";
+		      write name;
+		      write "\n"))
+
+val () = Env.action_one "readmeName"
+	 ("name", Env.string)
+	 (fn name => (write "\tReadmeName ";
+		      write name;
+		      write "\n"))
+
 end