(* HCoop Domtool (http://hcoop.sourceforge.net/)
- * Copyright (c) 2006, Adam Chlipala
+ * Copyright (c) 2006-2009, Adam Chlipala
+ * Copyright (c) 2013 Clinton Ebadi
*
* This program is free software; you can redistribute it and/or
* modify it under the terms of the GNU General Public License
open Ast
+val dl = ErrorMsg.dummyLoc
+
+fun webNode node =
+ List.exists (fn (x, _) => x = node) Config.Apache.webNodes_all
+ orelse (Domain.hasPriv "www"
+ andalso List.exists (fn (x, _) => x = node) Config.Apache.webNodes_admin)
+
val _ = Env.type_one "web_node"
Env.string
- (fn node =>
- List.exists (fn x => x = node) Config.Apache.webNodes_all
- orelse (Domain.hasPriv "www"
- andalso List.exists (fn x => x = node) Config.Apache.webNodes_admin))
+ webNode
val _ = Env.registerFunction ("web_node_to_node",
fn [e] => SOME e
| _ => NONE)
+fun webPlace (EApp ((EVar "web_place_default", _), (EString node, _)), _) =
+ SOME (node, Domain.nodeIp node)
+ | webPlace (EApp ((EApp ((EVar "web_place", _), (EString node, _)), _), (EString ip, _)), _) =
+ SOME (node, ip)
+ | webPlace _ = NONE
+
+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)
+ | _ => NONE)
+
+val _ = Env.registerFunction ("web_place_to_node",
+ fn [e] => Option.map (fn (node, _) => (EString node, dl)) (webPlace e)
+ | _ => NONE)
+
+val _ = Env.registerFunction ("web_place_to_ip",
+ fn [e] => Option.map (fn (_, ip) => (EString ip, dl)) (webPlace e)
+ | _ => NONE)
+
val _ = Env.type_one "proxy_port"
Env.int
(fn n => n > 1024)
+fun validProxyTarget default s =
+ case String.fields (fn ch => ch = #":") s of
+ "http" :: host :: rest =>
+ let
+ val rest = String.concatWith ":" rest
+ in
+ if List.exists (fn h' => host = h') (map (fn h => String.concat ["//", h]) Config.Apache.proxyHosts)
+ then
+ CharVector.all (fn ch => Char.isPrint ch andalso not (Char.isSpace ch)
+ andalso ch <> #"\"" andalso ch <> #"'") rest
+ andalso case String.fields (fn ch => ch = #"/") rest of
+ port :: _ =>
+ (case Int.fromString port of
+ NONE => default s
+ | SOME n => n > 1024 orelse default s)
+ | _ => default s
+ else
+ default s
+ end
+ | _ => default s
+
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)
+ (validProxyTarget (fn s => List.exists (fn s' => s = s') (Config.Apache.proxyTargets @ ["!"])))
+
+val _ = Env.type_one "proxy_reverse_target"
+ Env.string
+ (validProxyTarget (fn s => List.exists (fn s' => s = s') Config.Apache.proxyTargets))
val _ = Env.type_one "rewrite_arg"
Env.string
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
class = "cert",
value = s}
+fun validCaCert s = Acl.query {user = Domain.getUser (),
+ class = "cacert",
+ value = s}
+
val _ = Env.type_one "ssl_cert_path"
Env.string
validCert
+val _ = Env.type_one "ssl_cacert_path"
+ Env.string
+ validCaCert
+
fun ssl e = case e of
(EVar "no_ssl", _) => SOME NONE
| (EApp ((EVar "use_cert", _), s), _) => Option.map SOME (Env.string s)
| _ => NONE
-val dl = ErrorMsg.dummyLoc
-
-val _ = Defaults.registerDefault ("WebNodes",
- (TList (TBase "web_node", dl), dl),
- (fn () => (EList (map (fn s => (EString s, dl)) Config.Apache.webNodes_default), dl)))
-
-val _ = Defaults.registerDefault ("SSL",
- (TBase "ssl", dl),
- (fn () => (EVar "false", dl)))
-
-val _ = Defaults.registerDefault ("User",
- (TBase "your_user", dl),
- (fn () => (EString (Domain.getUser ()), dl)))
-
-val _ = Defaults.registerDefault ("Group",
- (TBase "your_group", dl),
- (fn () => (EString (Domain.getUser ()), dl)))
+fun validExtension s =
+ size s > 0
+ andalso size s < 20
+ andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"_") s
-val _ = Defaults.registerDefault ("DocumentRoot",
- (TBase "your_path", dl),
- (fn () => (EString (Config.homeBase ^ "/" ^ Domain.getUser () ^ "/" ^ Config.Apache.public_html), dl)))
-
-val _ = Defaults.registerDefault ("ServerAdmin",
- (TBase "email", dl),
- (fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl)))
+val _ = Env.type_one "file_extension"
+ Env.string
+ validExtension
-val _ = Defaults.registerDefault ("SuExec",
- (TBase "suexec_flag", dl),
- (fn () => (EVar "true", dl)))
+val _ = Env.registerFunction ("defaultServerAdmin",
+ fn [] => SOME (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl)
+ | _ => NONE)
val redirect_code = fn (EVar "temp", _) => SOME "temp"
| (EVar "permanent", _) => SOME "permanent"
val apache_option = fn (EVar "execCGI", _) => SOME "ExecCGI"
| (EVar "includesNOEXEC", _) => SOME "IncludesNOEXEC"
| (EVar "indexes", _) => SOME "Indexes"
+ | (EVar "followSymLinks", _) => SOME "FollowSymLinks"
+ | (EVar "multiViews", _) => SOME "MultiViews"
| _ => NONE
val autoindex_width = fn (EVar "autofit", _) => SOME "*"
| _ => NONE
+val interval_base = fn (EVar "access", _) => SOME "access"
+ | (EVar "modification", _) => SOME "modification"
+ | _ => NONE
+
+val interval = fn (EVar "years", _) => SOME "years"
+ | (EVar "months", _) => SOME "months"
+ | (EVar "weeks", _) => SOME "weeks"
+ | (EVar "days", _) => SOME "days"
+ | (EVar "hours", _) => SOME "hours"
+ | (EVar "minutes", _) => SOME "minutes"
+ | (EVar "seconds", _) => SOME "seconds"
+ | _ => NONE
+
val vhostsChanged = ref false
val logDeleted = ref false
+val delayedLogMoves = ref (fn () => ())
val () = Slave.registerPreHandler
(fn () => (vhostsChanged := false;
- logDeleted := false))
+ logDeleted := false;
+ delayedLogMoves := (fn () => print "Executing delayed log moves/deletes.\n")))
fun findVhostUser fname =
let
before TextIO.closeIn inf
end handle _ => NONE
+val webNodes_full = Config.Apache.webNodes_all @ Config.Apache.webNodes_admin
+
+fun isVersion1 node =
+ List.exists (fn (n, {version = ConfigTypes.APACHE_1_3, ...}) => n = node
+ | _ => false) webNodes_full
+
+fun imVersion1 () = isVersion1 (Slave.hostname ())
+
+fun isWaklog node =
+ List.exists (fn (n, {auth = ConfigTypes.MOD_WAKLOG, ...}) => n = node
+ | _ => false) webNodes_full
+
+fun down () = if imVersion1 () then Config.Apache.down1 else Config.Apache.down
+fun undown () = if imVersion1 () then Config.Apache.undown1 else Config.Apache.undown
+fun reload () = if imVersion1 () then Config.Apache.reload1 else Config.Apache.reload
+fun fixperms () = if imVersion1 () then Config.Apache.fixperms1 else Config.Apache.fixperms
+
+fun logDir {user, node, vhostId} =
+ String.concat [Config.Apache.logDirOf (isVersion1 node) user,
+ "/",
+ node,
+ "/",
+ 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)
file = #file spl}
val user = findVhostUser (#file fs)
- val oldUser = findVhostUser realVhostFile
+ val oldUser = case #action fs of
+ Slave.Delete false => user
+ | _ => findVhostUser realVhostFile
in
if (oldUser = NONE andalso #action fs <> Slave.Add)
- orelse (user = NONE andalso #action fs <> Slave.Delete) then
+ orelse (user = NONE andalso not (Slave.isDelete (#action fs))) then
print ("Can't find user in " ^ #file fs ^ " or " ^ realVhostFile ^ "! Taking no action.\n")
else
let
+ val vhostId = if OS.Path.ext (#file spl) = SOME "vhost_ssl" then
+ OS.Path.base (#file spl) ^ ".ssl"
+ else
+ OS.Path.base (#file spl)
+
fun realLogDir user =
+ logDir {user = valOf user,
+ node = Slave.hostname (),
+ vhostId = vhostId}
+
+ fun backupLogs () =
+ OS.Path.joinDirFile
+ {dir = Config.Apache.backupLogDirOf
+ (isVersion1 (Slave.hostname ())),
+ file = vhostId}
+ in
+ vhostsChanged := true;
+ case #action fs of
+ Slave.Delete _ =>
let
- val realLogDir = OS.Path.joinDirFile
- {dir = Config.homeBase,
- file = valOf user}
- val realLogDir = OS.Path.joinDirFile
- {dir = realLogDir,
- file = "apache"}
- val realLogDir = OS.Path.joinDirFile
- {dir = realLogDir,
- file = "log"}
- val realLogDir = OS.Path.joinDirFile
- {dir = realLogDir,
- file = Slave.hostname ()}
- val {base, ...} = OS.Path.splitBaseExt (#file spl)
-
- val realLogDir = OS.Path.joinDirFile
- {dir = realLogDir,
- file = base}
+ val ldir = realLogDir oldUser
+ val dlm = !delayedLogMoves
in
- if String.isSuffix ".vhost_ssl" (#file spl) then
- realLogDir ^ ".ssl"
+ if !logDeleted then
+ ()
else
- realLogDir
+ ((*ignore (OS.Process.system (down ()));*)
+ ignore (OS.Process.system (fixperms ()));
+ logDeleted := true);
+ ignore (OS.Process.system (Config.rm
+ ^ " -rf "
+ ^ realVhostFile));
+ delayedLogMoves := (fn () => (dlm ();
+ Slave.moveDirCreate {from = ldir,
+ to = backupLogs ()}))
end
- in
- vhostsChanged := true;
- case #action fs of
- Slave.Delete =>
- (if !logDeleted then
- ()
- else
- (ignore (OS.Process.system Config.Apache.down);
- logDeleted := true);
- ignore (OS.Process.system (Config.rm
- ^ " -rf "
- ^ realVhostFile));
- ignore (OS.Process.system (Config.rm
- ^ " -rf "
- ^ realLogDir oldUser)))
| Slave.Add =>
let
val rld = realLogDir user
if Posix.FileSys.access (rld, []) then
()
else
- OS.FileSys.mkDir rld
+ Slave.moveDirCreate {from = backupLogs (),
+ to = rld}
end
| _ =>
let
val old = realLogDir oldUser
val rld = realLogDir user
+
+ val dlm = !delayedLogMoves
in
if !logDeleted then
()
else
- (ignore (OS.Process.system Config.Apache.down);
+ ((*ignore (OS.Process.system (down ()));*)
logDeleted := true);
- ignore (OS.Process.system (Config.rm
- ^ " -rf "
- ^ realLogDir oldUser));
+ delayedLogMoves := (fn () => (dlm ();
+ ignore (OS.Process.system (Config.rm
+ ^ " -rf "
+ ^ realLogDir oldUser))));
if Posix.FileSys.access (rld, []) then
()
else
- OS.FileSys.mkDir rld
+ Slave.mkDirAll rld
end
else
())
val () = Slave.registerPostHandler
(fn () =>
(if !vhostsChanged then
- Slave.shellF ([if !logDeleted then Config.Apache.undown else Config.Apache.reload],
- fn cl => "Error reloading Apache with " ^ cl)
+ (Slave.shellF ([reload ()],
+ fn cl => "Error reloading Apache with " ^ cl);
+ if !logDeleted then !delayedLogMoves () else ())
else
()))
val rewriteEnabled = ref false
val localRewriteEnabled = ref false
+val expiresEnabled = ref false
+val localExpiresEnabled = ref false
val currentVhost = ref ""
val currentVhostId = ref ""
+val sslEnabled = ref false
val pre = ref (fn _ : {user : string, nodes : string list, id : string, hostname : string} => ())
fun registerPre f =
post := (fn () => (old (); f ()))
end
+fun doPre x = !pre x
+fun doPost () = !post ()
+
val aliaser = ref (fn _ : string => ())
fun registerAliaser f =
let
aliaser := (fn x => (old x; f x))
end
-val () = Env.containerV_one "vhost"
- ("host", Env.string)
- (fn (env, host) =>
- let
- val nodes = Env.env (Env.list Env.string) (env, "WebNodes")
-
- 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;
+fun vhostPost () = (!post ();
+ write "</VirtualHost>\n";
+ app (TextIO.closeOut o #2) (!vhostFiles))
- rewriteEnabled := false;
- localRewriteEnabled := false;
- vhostFiles := map (fn node =>
- let
- val file = Domain.domainFile {node = node,
- name = confFile}
- in
- TextIO.output (file, "# Owner: ");
+val php_version = fn (EVar "php5", _) => SOME 5
+ | _ => NONE
+
+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;
+ expiresEnabled := false;
+ localExpiresEnabled := 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, Domain.nodeIp node);
- TextIO.output (file, ":");
- TextIO.output (file, case ssl of
- SOME _ => "443"
- | NONE => "80");
- TextIO.output (file, ">\n");
- TextIO.output (file, "\tErrorLog ");
- TextIO.output (file, Config.homeBase);
- TextIO.output (file, "/");
+ TextIO.output (file, "\n\tGroup ");
+ TextIO.output (file, group))
+ else
+ (TextIO.output (file, "\n\tSuexecUserGroup ");
TextIO.output (file, user);
- TextIO.output (file, "/apache/log/");
- TextIO.output (file, node);
- TextIO.output (file, "/");
- TextIO.output (file, vhostId);
- TextIO.output (file, "/error.log\n\tCustomLog ");
- TextIO.output (file, Config.homeBase);
- TextIO.output (file, "/");
+ TextIO.output (file, " ");
+ TextIO.output (file, group);
+ TextIO.output (file, "\n\tsuPHP_UserGroup ");
TextIO.output (file, user);
- TextIO.output (file, "/apache/log/");
- TextIO.output (file, node);
- TextIO.output (file, "/");
- TextIO.output (file, vhostId);
- TextIO.output (file, "/access.log combined\n");
- (Config.homeBase ^ "/" ^ user ^ "/apache/log/"
- ^ node ^ "/" ^ vhostId, file)
- end)
- nodes;
- write "\tServerName ";
- write fullHost;
- if suexec then
- (write "\n\tSuexecUserGroup ";
- write user;
- write " ";
- write group)
- else
- ();
- 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 = nodes, id = vhostId, hostname = fullHost}
- end,
- fn () => (!post ();
- write "</VirtualHost>\n";
- app (TextIO.closeOut o #2) (!vhostFiles)))
+ 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
+
+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
inLocal := true),
fn () => (write "\t</Location>\n";
inLocal := false;
- localRewriteEnabled := false))
+ localRewriteEnabled := false;
+ localExpiresEnabled := false))
val () = Env.container_one "directory"
("directory", Env.string)
inLocal := true),
fn () => (write "\t</Directory>\n";
inLocal := false;
- localRewriteEnabled := false))
+ localRewriteEnabled := false;
+ localExpiresEnabled := false))
+
+val () = Env.container_one "filesMatch"
+ ("regexp", Env.string)
+ (fn prefix =>
+ (write "\t<FilesMatch \"";
+ write prefix;
+ write "\">\n"),
+ fn () => (write "\t</FilesMatch>\n";
+ localRewriteEnabled := false;
+ localExpiresEnabled := false))
fun checkRewrite () =
if !inLocal then
- if !rewriteEnabled orelse !localRewriteEnabled then
+ if !localRewriteEnabled then
()
else
(write "\tRewriteEngine on\n";
(write "\tRewriteEngine on\n";
rewriteEnabled := true)
+fun checkExpires () =
+ if !inLocal then
+ if !localExpiresEnabled then
+ ()
+ else
+ (write "\tExpiresActive on\n";
+ localExpiresEnabled := true)
+ else if !expiresEnabled then
+ ()
+ else
+ (write "\tExpiresActive on\n";
+ expiresEnabled := true)
+
val () = Env.action_three "localProxyRewrite"
("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;
write " [P]\n"))
+val () = Env.action_four "expiresByType"
+ ("mime", Env.string, "base", interval_base, "num", Env.int, "inter", interval)
+ (fn (mime, base, num, inter) =>
+ (checkExpires ();
+ write "\tExpiresByType\t\"";
+ write mime;
+ write "\"\t\"";
+ write base;
+ write " plus ";
+ if num < 0 then
+ (write "-";
+ write (Int.toString (~num)))
+ else
+ write (Int.toString num);
+ write " ";
+ write inter;
+ write "\"\n"))
+
val () = Env.action_two "proxyPass"
("from", Env.string, "to", Env.string)
(fn (from, 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 " [";
write "]");
write "\n"))
+val () = Env.action_one "rewriteBase"
+ ("prefix", Env.string)
+ (fn prefix =>
+ (checkRewrite ();
+ write "\tRewriteBase\t\"";
+ write prefix;
+ write "\"\n"))
+
val () = Env.action_one "rewriteLogLevel"
("level", Env.int)
(fn level =>
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 opt => (write " "; write opt)) opts;
write "\n"))
-val () = Env.action_one "serverAlias"
+val () = Env.action_one "serverAliasHost"
("host", Env.string)
(fn host =>
(write "\tServerAlias ";
write "\n";
!aliaser host))
+val () = Env.action_one "serverAlias"
+ ("host", Env.string)
+ (fn host =>
+ (app
+ (fn dom =>
+ let
+ val full = host ^ "." ^ dom
+ in
+ write "\tServerAlias ";
+ write full;
+ write "\n";
+ !aliaser full
+ end)
+ (Domain.currentDomains ())))
+
+val () = Env.action_none "serverAliasDefault"
+ (fn () =>
+ (app
+ (fn dom =>
+ (write "\tServerAlias ";
+ write dom;
+ write "\n";
+ !aliaser dom))
+ (Domain.currentDomains ())))
+
val authType = fn (EVar "basic", _) => SOME "basic"
| (EVar "digest", _) => SOME "digest"
+ | (EVar "kerberos", _) => SOME "kerberos"
| _ => NONE
+fun allowAuthType "kerberos" = !sslEnabled
+ | allowAuthType _ = true
+
val () = Env.action_one "authType"
("type", authType)
(fn ty =>
- (write "\tAuthType ";
- write ty;
- write "\n"))
+ if allowAuthType ty then
+ (write "\tAuthType ";
+ write ty;
+ write "\n";
+ case ty of
+ "kerberos" =>
+ write "\tKrbServiceName apache2\n\tKrb5Keytab /etc/keytabs/service/apache\n\tKrbMethodNegotiate on\n\tKrbMethodK5Passwd on\n\tKrbVerifyKDC on\n\tKrbAuthRealms HCOOP.NET\n\tKrbSaveCredentials on\n"
+ | _ => ())
+ else
+ print "WARNING: Skipped Kerberos authType because this isn't an SSL vhost.\n")
val () = Env.action_one "authName"
("name", Env.string)
write name;
write "\n"))
+val () = Env.action_one "authGroupFile"
+ ("file", Env.string)
+ (fn name =>
+ (write "\tAuthGroupFile ";
+ write name;
+ write "\n"))
+
val () = Env.action_none "requireValidUser"
(fn () => write "\tRequire valid-user\n")
write path;
write "\n"))*)
+val () = Env.action_none "davFilesystem"
+ (fn path => write "\tDAV filesystem\n")
+
val () = Env.action_two "addDescription"
("description", Env.string, "patterns", Env.list Env.string)
(fn (desc, pats) =>
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 =>
write name;
write "\n"))
+val () = Env.action_two "setEnv"
+ ("key", Env.string, "value", Env.string)
+ (fn (key, value) => (write "\tSetEnv \"";
+ write key;
+ write "\" \"";
+ write (String.translate (fn #"\"" => "\\\""
+ | 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 () = Env.action_one "sslCertificateChainFile"
+ ("ssl_cacert_path", Env.string)
+ (fn cacert =>
+ if !sslEnabled then
+ (write "\tSSLCertificateChainFile \"";
+ write cacert;
+ write "\"\n")
+ else
+ print "WARNING: Skipped sslCertificateChainFile because this isn't an SSL vhost.\n")
+
val () = Domain.registerResetLocal (fn () =>
- ignore (OS.Process.system (Config.rm ^ " -rf /var/domtool/vhosts/*")))
+ ignore (OS.Process.system (Config.rm ^ " -rf " ^ Config.Apache.confDir ^ "/*")))
+
+val () = Domain.registerDescriber (Domain.considerAll
+ [Domain.Extension {extension = "vhost",
+ heading = fn host => "Web vhost " ^ host ^ ":"},
+ Domain.Extension {extension = "vhost_ssl",
+ heading = fn host => "SSL web vhost " ^ host ^ ":"}])
+
+val () = Env.action_none "testNoHtaccess"
+ (fn path => write "\tAllowOverride None\n")
+
+fun writeWaklogUserFile () =
+ let
+ val users = Acl.users ()
+ val outf = TextIO.openOut Config.Apache.waklogUserFile
+ in
+ app (fn user => if String.isSuffix "_admin" user then
+ ()
+ else
+ (TextIO.output (outf, "<Location /~");
+ TextIO.output (outf, user);
+ TextIO.output (outf, ">\n\tWaklogEnabled on\n\tWaklogLocationPrincipal ");
+ TextIO.output (outf, user);
+ TextIO.output (outf, "/daemon@HCOOP.NET /etc/keytabs/user.daemon/");
+ TextIO.output (outf, user);
+ TextIO.output (outf, "\n</Location>\n\n"))) users;
+ TextIO.closeOut outf
+ end
+
+val () = Domain.registerOnUsersChange writeWaklogUserFile
end
HCoop / hcoop / domtool2.git / blobdiff