fn [e] => SOME e
| _ => NONE)
-fun webPlace (EApp ((EString "web_place_default", _), (EString node, _)), _) =
+fun webPlace (EApp ((EVar "web_place_default", _), (EString node, _)), _) =
SOME (node, Domain.nodeIp node)
- | webPlace (EApp ((EApp ((EString "web_place", _), (EString node, _)), _), (EString ip, _)), _) =
+ | webPlace (EApp ((EApp ((EVar "web_place", _), (EString node, _)), _), (EString ip, _)), _) =
SOME (node, ip)
| webPlace _ = NONE
-fun webPlaceDefault node = (EApp ((EString "web_place_default", dl), (EString node, dl)), dl)
+fun webPlaceDefault node = (EApp ((EVar "web_place_default", dl), (EString node, dl)), dl)
val _ = Env.registerFunction ("web_place_to_web_node",
fn [e] => Option.map (fn (node, _) => (EString node, dl)) (webPlace e)
Env.bool
(fn b => b orelse Domain.hasPriv "www")
+val _ = Env.type_one "regexp"
+ Env.string
+ Pcre.validRegexp
+
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
+ orelse ch = #"/"
+ orelse ch = #"~") s
val _ = Env.type_one "location"
Env.string
| (EApp ((EVar "use_cert", _), s), _) => Option.map SOME (Env.string s)
| _ => NONE
+fun validExtension s =
+ size s > 0
+ andalso size s < 20
+ andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"_") s
+
+val _ = Env.type_one "file_extension"
+ Env.string
+ validExtension
+
val defaults = [("WebPlaces",
(TList (TBase "web_place", dl), dl),
(fn () => (EList (map webPlaceDefault Config.Apache.webNodes_default), dl))),
(fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl))),
("SuExec",
(TBase "suexec_flag", dl),
- (fn () => (EVar "true", dl)))]
+ (fn () => (EVar "true", dl))),
+ ("PhpVersion",
+ (TBase "php_version", dl),
+ (fn () => (EVar "php4", dl)))]
val () = app Defaults.registerDefault defaults
val apache_option = fn (EVar "execCGI", _) => SOME "ExecCGI"
| (EVar "includesNOEXEC", _) => SOME "IncludesNOEXEC"
| (EVar "indexes", _) => SOME "Indexes"
+ | (EVar "followSymLinks", _) => SOME "FollowSymLinks"
| _ => NONE
val autoindex_width = fn (EVar "autofit", _) => SOME "*"
"/",
vhostId]
+fun realLogDir {user, node, vhostId} =
+ String.concat [Config.Apache.realLogDirOf user,
+ "/",
+ node,
+ "/",
+ vhostId]
+
val () = Slave.registerFileHandler (fn fs =>
let
val spl = OS.Path.splitDirFile (#file fs)
aliaser := (fn x => (old x; f x))
end
-val () = Env.containerV_one "vhost"
- ("host", Env.string)
- (fn (env, host) =>
- let
- val places = Env.env (Env.list webPlace) (env, "WebPlaces")
-
- val ssl = Env.env ssl (env, "SSL")
- val user = Env.env Env.string (env, "User")
- 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 Env.bool (env, "SuExec")
-
- val fullHost = host ^ "." ^ Domain.currentDomain ()
- val vhostId = fullHost ^ (if Option.isSome ssl then ".ssl" else "")
- val confFile = fullHost ^ (if Option.isSome ssl then ".vhost_ssl" else ".vhost")
- in
- currentVhost := fullHost;
- currentVhostId := vhostId;
- sslEnabled := Option.isSome ssl;
+fun vhostPost () = (!post ();
+ write "</VirtualHost>\n";
+ app (TextIO.closeOut o #2) (!vhostFiles))
- rewriteEnabled := false;
- localRewriteEnabled := false;
- vhostFiles := map (fn (node, ip) =>
- let
- val file = Domain.domainFile {node = node,
- name = confFile}
+val php_version = fn (EVar "php4", _) => SOME 4
+ | (EVar "php5", _) => SOME 5
+ | _ => NONE
- val ld = logDir {user = user, node = node, vhostId = vhostId}
- in
- TextIO.output (file, "# Owner: ");
+fun vhostBody (env, makeFullHost) =
+ let
+ val places = Env.env (Env.list webPlace) (env, "WebPlaces")
+
+ val ssl = Env.env ssl (env, "SSL")
+ val user = Env.env Env.string (env, "User")
+ 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 Env.bool (env, "SuExec")
+ val php = Env.env php_version (env, "PhpVersion")
+
+ val fullHost = makeFullHost (Domain.currentDomain ())
+ val vhostId = fullHost ^ (if Option.isSome ssl then ".ssl" else "")
+ val confFile = fullHost ^ (if Option.isSome ssl then ".vhost_ssl" else ".vhost")
+ in
+ currentVhost := fullHost;
+ currentVhostId := vhostId;
+ sslEnabled := Option.isSome ssl;
+
+ rewriteEnabled := false;
+ localRewriteEnabled := false;
+ vhostFiles := map (fn (node, ip) =>
+ let
+ val file = Domain.domainFile {node = node,
+ name = confFile}
+
+ val ld = logDir {user = user, node = node, vhostId = vhostId}
+ in
+ TextIO.output (file, "# Owner: ");
+ TextIO.output (file, user);
+ TextIO.output (file, "\n<VirtualHost ");
+ TextIO.output (file, ip);
+ TextIO.output (file, ":");
+ TextIO.output (file, case ssl of
+ SOME _ => "443"
+ | NONE => "80");
+ TextIO.output (file, ">\n");
+ TextIO.output (file, "\tErrorLog ");
+ TextIO.output (file, ld);
+ TextIO.output (file, "/error.log\n\tCustomLog ");
+ TextIO.output (file, ld);
+ TextIO.output (file, "/access.log combined\n");
+ TextIO.output (file, "\tServerName ");
+ TextIO.output (file, fullHost);
+ app
+ (fn dom => (TextIO.output (file, "\n\tServerAlias ");
+ TextIO.output (file, makeFullHost dom)))
+ (Domain.currentAliasDomains ());
+
+ if suexec then
+ if isVersion1 node then
+ (TextIO.output (file, "\n\tUser ");
TextIO.output (file, user);
- TextIO.output (file, "\n<VirtualHost ");
- TextIO.output (file, ip);
- TextIO.output (file, ":");
- TextIO.output (file, case ssl of
- SOME _ => "443"
- | NONE => "80");
- TextIO.output (file, ">\n");
- TextIO.output (file, "\tErrorLog ");
- TextIO.output (file, ld);
- TextIO.output (file, "/error.log\n\tCustomLog ");
- TextIO.output (file, ld);
- TextIO.output (file, "/access.log combined\n");
- TextIO.output (file, "\tServerName ");
- TextIO.output (file, fullHost);
- app
- (fn dom => (TextIO.output (file, "\n\tServerAlias ");
- TextIO.output (file, host);
- TextIO.output (file, ".");
- TextIO.output (file, dom)))
- (Domain.currentAliasDomains ());
-
- if suexec then
- if isVersion1 node then
- (TextIO.output (file, "\n\tUser ");
- TextIO.output (file, user);
- TextIO.output (file, "\n\tGroup ");
- TextIO.output (file, group))
- else
- (TextIO.output (file, "\n\tSuexecUserGroup ");
- TextIO.output (file, user);
- TextIO.output (file, " ");
- TextIO.output (file, group))
- else
- ();
-
- if isWaklog node then
- (TextIO.output (file, "\n\tWaklogEnabled on\n\tWaklogLocationPrincipal ");
- TextIO.output (file, user);
- TextIO.output (file, "/daemon@HCOOP.NET /etc/keytabs/user.daemon/");
- TextIO.output (file, user))
- else
- ();
-
- TextIO.output (file, "\n\tDAVLockDB /var/lock/apache2/dav/");
+ TextIO.output (file, "\n\tGroup ");
+ TextIO.output (file, group))
+ else
+ (TextIO.output (file, "\n\tSuexecUserGroup ");
TextIO.output (file, user);
- TextIO.output (file, "/DAVLock");
+ TextIO.output (file, " ");
+ TextIO.output (file, group))
+ else
+ ();
+
+ if isWaklog node then
+ (TextIO.output (file, "\n\tWaklogEnabled on\n\tWaklogLocationPrincipal ");
+ TextIO.output (file, user);
+ TextIO.output (file, "/daemon@HCOOP.NET /etc/keytabs/user.daemon/");
+ TextIO.output (file, user))
+ else
+ ();
+
+ TextIO.output (file, "\n\tDAVLockDB /var/lock/apache2/dav/");
+ TextIO.output (file, user);
+ TextIO.output (file, "/DAVLock");
+
+ if php <> Config.Apache.defaultPhpVersion then
+ (TextIO.output (file, "\n\tAddHandler x-httpd-php");
+ TextIO.output (file, Int.toString php);
+ TextIO.output (file, " .php .phtml"))
+ else
+ ();
+
+ (ld, file)
+ end)
+ places;
+ write "\n\tDocumentRoot ";
+ write docroot;
+ write "\n\tServerAdmin ";
+ write sadmin;
+ case ssl of
+ SOME cert =>
+ (write "\n\tSSLEngine on\n\tSSLCertificateFile ";
+ write cert)
+ | NONE => ();
+ write "\n";
+ !pre {user = user, nodes = map #1 places, id = vhostId, hostname = fullHost};
+ app (fn dom => !aliaser (makeFullHost dom)) (Domain.currentAliasDomains ())
+ end
- (ld, file)
- end)
- places;
- write "\n\tDocumentRoot ";
- write docroot;
- write "\n\tServerAdmin ";
- write sadmin;
- case ssl of
- SOME cert =>
- (write "\n\tSSLEngine on\n\tSSLCertificateFile ";
- write cert)
- | NONE => ();
- write "\n";
- !pre {user = user, nodes = map #1 places, id = vhostId, hostname = fullHost};
- app (fn dom => !aliaser (host ^ "." ^ dom)) (Domain.currentAliasDomains ())
- end,
- fn () => (!post ();
- write "</VirtualHost>\n";
- app (TextIO.closeOut o #2) (!vhostFiles)))
+val () = Env.containerV_one "vhost"
+ ("host", Env.string)
+ (fn (env, host) => vhostBody (env, fn dom => host ^ "." ^ dom),
+ vhostPost)
+
+val () = Env.containerV_none "vhostDefault"
+ (fn env => vhostBody (env, fn dom => dom),
+ vhostPost)
val inLocal = ref false
fun checkRewrite () =
if !inLocal then
- if !rewriteEnabled orelse !localRewriteEnabled then
+ if !localRewriteEnabled then
()
else
(write "\tRewriteEngine on\n";
("from", Env.string, "to", Env.string, "port", Env.int)
(fn (from, to, port) =>
(checkRewrite ();
- write "\tRewriteRule\t";
+ write "\tRewriteRule\t\"";
write from;
- write "\thttp://localhost:";
+ write "\"\thttp://localhost:";
write (Int.toString port);
write "/";
write to;
("from", Env.string, "to", Env.string, "flags", Env.list flag)
(fn (from, to, flags) =>
(checkRewrite ();
- write "\tRewriteRule\t";
+ write "\tRewriteRule\t\"";
write from;
- write "\t";
+ write "\"\t\"";
write to;
+ write "\"";
case flags of
[] => ()
| flag::rest => (write " [";
("test", Env.string, "pattern", Env.string, "flags", Env.list cond_flag)
(fn (from, to, flags) =>
(checkRewrite ();
- write "\tRewriteCond\t";
+ write "\tRewriteCond\t\"";
write from;
- write "\t";
+ write "\"\t\"";
write to;
+ write "\"";
case flags of
[] => ()
| flag::rest => (write " [";
("prefix", Env.string)
(fn prefix =>
(checkRewrite ();
- write "\tRewriteBase\t";
+ write "\tRewriteBase\t\"";
write prefix;
- write "\n"))
+ write "\"\n"))
val () = Env.action_one "rewriteLogLevel"
("level", Env.int)
val () = Env.action_two "errorDocument"
("code", Env.string, "handler", Env.string)
(fn (code, handler) =>
- (write "\tErrorDocument\t";
- write code;
- write " ";
- write handler;
- write "\n"))
+ let
+ val hasSpaces = CharVector.exists Char.isSpace handler
+ fun maybeQuote () =
+ if hasSpaces then
+ write "\""
+ else
+ ()
+ in
+ write "\tErrorDocument\t";
+ write code;
+ write " ";
+ maybeQuote ();
+ write handler;
+ maybeQuote ();
+ write "\n"
+ end)
+
val () = Env.action_one "options"
("options", Env.list apache_option)
(fn opts =>
app (fn opt => (write " -"; write opt)) opts;
write "\n"))
+val () = Env.action_one "cgiExtension"
+ ("extension", Env.string)
+ (fn ext => (write "\tAddHandler cgi-script ";
+ write ext;
+ write "\n"))
+
val () = Env.action_one "directoryIndex"
("filenames", Env.list Env.string)
(fn opts =>
app (fn pat => (write " "; write pat)) pats;
write "\n"))
+val () = Env.action_two "addIcon"
+ ("icon", Env.string, "patterns", Env.list Env.string)
+ (fn (icon, pats) =>
+ case pats of
+ [] => ()
+ | _ => (write "\tAddIcon \"";
+ write icon;
+ write "\"";
+ app (fn pat => (write " "; write pat)) pats;
+ write "\n"))
+
val () = Env.action_one "indexOptions"
("options", Env.list autoindex_option)
(fn opts =>
(write "="; write arg)) arg)) opts;
write "\n"))
+val () = Env.action_one "indexIgnore"
+ ("patterns", Env.list Env.string)
+ (fn pats =>
+ case pats of
+ [] => ()
+ | _ => (write "\tIndexIgnore";
+ app (fn pat => (write " "; write pat)) pats;
+ write "\n"))
+
val () = Env.action_one "set_indexOptions"
("options", Env.list autoindex_option)
(fn opts =>
| ch => str ch) value);
write "\"\n"))
+val () = Env.action_one "diskCache"
+ ("path", Env.string)
+ (fn path => (write "\tCacheEnable disk \"";
+ write path;
+ write "\"\n"))
+
+val () = Env.action_one "phpVersion"
+ ("version", php_version)
+ (fn version => (write "\tAddHandler x-httpd-php";
+ write (Int.toString version);
+ write " .php .phtml\n"))
+
+val () = Env.action_two "addType"
+ ("mime type", Env.string, "extension", Env.string)
+ (fn (mt, ext) => (write "\tAddType ";
+ write mt;
+ write " ";
+ write ext;
+ write "\n"))
+
+val filter = fn (EVar "includes", _) => SOME "INCLUDES"
+ | (EVar "deflate", _) => SOME "DEFLATE"
+ | _ => NONE
+
+val () = Env.action_two "addOutputFilter"
+ ("filters", Env.list filter, "extensions", Env.list Env.string)
+ (fn (f :: fs, exts as (_ :: _)) =>
+ (write "\tAddOutputFilter ";
+ write f;
+ app (fn f => (write ";"; write f)) fs;
+ app (fn ext => (write " "; write ext)) exts;
+ write "\n")
+ | _ => ())
+
val () = Domain.registerResetLocal (fn () =>
ignore (OS.Process.system (Config.rm ^ " -rf /var/domtool/vhosts/*")))
val () = Domain.registerDescriber (Domain.considerAll
[Domain.Extension {extension = "vhost",
- heading = fn host => "Web vhost " ^ host},
+ heading = fn host => "Web vhost " ^ host ^ ":"},
Domain.Extension {extension = "vhost_ssl",
- heading = fn host => "SSL web vhost " ^ host}])
+ heading = fn host => "SSL web vhost " ^ host ^ ":"}])
+
+val () = Env.action_none "testNoHtaccess"
+ (fn path => write "\tAllowOverride None\n")
end
HCoop / hcoop / domtool2.git / blobdiff