(* HCoop Domtool (http://hcoop.sourceforge.net/)
* Copyright (c) 2006-2007, Adam Chlipala
*
* This program is free software; you can redistribute it and/or
* modify it under the terms of the GNU General Public License
* as published by the Free Software Foundation; either version 2
* of the License, or (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*)
(* Apache HTTPD handling *)
structure Apache :> APACHE = struct
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
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)
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)
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
orelse ch = #"-"
orelse ch = #"_"
orelse ch = #"."
orelse ch = #"/") s
val _ = Env.type_one "location"
Env.string
validLocation
fun validCert s = Acl.query {user = Domain.getUser (),
class = "cert",
value = s}
val _ = Env.type_one "ssl_cert_path"
Env.string
validCert
fun ssl e = case e of
(EVar "no_ssl", _) => SOME NONE
| (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))),
("SSL",
(TBase "ssl", dl),
(fn () => (EVar "no_ssl", dl))),
("User",
(TBase "your_user", dl),
(fn () => (EString (Domain.getUser ()), dl))),
("Group",
(TBase "your_group", dl),
(fn () => (EString "nogroup", dl))),
("DocumentRoot",
(TBase "your_path", dl),
(fn () => (EString (Domain.homedir () ^ "/" ^ Config.Apache.public_html), dl))),
("ServerAdmin",
(TBase "email", dl),
(fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl))),
("SuExec",
(TBase "suexec_flag", dl),
(fn () => (EVar "true", dl)))]
val () = app Defaults.registerDefault defaults
val redirect_code = fn (EVar "temp", _) => SOME "temp"
| (EVar "permanent", _) => SOME "permanent"
| (EVar "seeother", _) => SOME "seeother"
| (EVar "redir300", _) => SOME "300"
| (EVar "redir301", _) => SOME "301"
| (EVar "redir302", _) => SOME "302"
| (EVar "redir303", _) => SOME "303"
| (EVar "redir304", _) => SOME "304"
| (EVar "redir305", _) => SOME "305"
| (EVar "redir307", _) => SOME "307"
| _ => NONE
val flag = fn (EVar "redirect", _) => SOME "R"
| (EVar "forbidden", _) => SOME "F"
| (EVar "gone", _) => SOME "G"
| (EVar "last", _) => SOME "L"
| (EVar "chain", _) => SOME "C"
| (EVar "nosubreq", _) => SOME "NS"
| (EVar "nocase", _) => SOME "NC"
| (EVar "qsappend", _) => SOME "QSA"
| (EVar "noescape", _) => SOME "NE"
| (EVar "passthrough", _) => SOME "PT"
| (EApp ((EVar "mimeType", _), e), _) =>
Option.map (fn s => "T=" ^ s) (Env.string e)
| (EApp ((EVar "redirectWith", _), e), _) =>
Option.map (fn s => "R=" ^ s) (redirect_code e)
| (EApp ((EVar "skip", _), e), _) =>
Option.map (fn n => "S=" ^ Int.toString n) (Env.int e)
| (EApp ((EApp ((EVar "env", _), e1), _), e2), _) =>
(case Env.string e1 of
NONE => NONE
| SOME s1 => Option.map (fn s2 => "E=" ^ s1 ^ ":" ^ s2)
(Env.string e2))
| _ => 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"
| (EVar "followSymLinks", _) => SOME "FollowSymLinks"
| _ => 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
val logDeleted = ref false
val () = Slave.registerPreHandler
(fn () => (vhostsChanged := false;
logDeleted := false))
fun findVhostUser fname =
let
val inf = TextIO.openIn fname
fun loop () =
case TextIO.inputLine inf of
NONE => NONE
| SOME line =>
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
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)
in
if String.isSuffix ".vhost" (#file spl)
orelse String.isSuffix ".vhost_ssl" (#file spl) then let
val realVhostFile = OS.Path.joinDirFile
{dir = Config.Apache.confDir,
file = #file spl}
val user = findVhostUser (#file fs)
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 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 ldir = realLogDir oldUser
in
if !logDeleted then
()
else
(ignore (OS.Process.system (down ()));
ignore (OS.Process.system (fixperms ()));
logDeleted := true);
ignore (OS.Process.system (Config.rm
^ " -rf "
^ realVhostFile));
Slave.moveDirCreate {from = ldir,
to = backupLogs ()}
end
| Slave.Add =>
let
val rld = realLogDir user
in
ignore (OS.Process.system (Config.cp
^ " "
^ #file fs
^ " "
^ realVhostFile));
if Posix.FileSys.access (rld, []) then
()
else
Slave.moveDirCreate {from = backupLogs (),
to = rld}
end
| _ =>
(ignore (OS.Process.system (Config.cp
^ " "
^ #file fs
^ " "
^ realVhostFile));
if user <> oldUser then
let
val old = realLogDir oldUser
val rld = realLogDir user
in
if !logDeleted then
()
else
(ignore (OS.Process.system (down ()));
logDeleted := true);
ignore (OS.Process.system (Config.rm
^ " -rf "
^ realLogDir oldUser));
if Posix.FileSys.access (rld, []) then
()
else
Slave.mkDirAll rld
end
else
())
end
end
else
()
end)
val () = Slave.registerPostHandler
(fn () =>
(if !vhostsChanged then
Slave.shellF ([if !logDeleted then undown () else reload ()],
fn cl => "Error reloading Apache with " ^ cl)
else
()))
val vhostFiles : (string * TextIO.outstream) list ref = ref []
fun write' s = app (fn (node, file) => TextIO.output (file, s node)) (!vhostFiles)
fun write s = app (fn (_, file) => TextIO.output (file, s)) (!vhostFiles)
val rewriteEnabled = ref false
val localRewriteEnabled = 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 =
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
fun doPre x = !pre x
fun doPost () = !post ()
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)
(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;
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 "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, user);
TextIO.output (file, "/DAVLock");
(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 "\n";
app (TextIO.closeOut o #2) (!vhostFiles)))
val inLocal = ref false
val () = Env.container_one "location"
("prefix", Env.string)
(fn prefix =>
(write "\t\n";
inLocal := true),
fn () => (write "\t\n";
inLocal := false;
localRewriteEnabled := false))
val () = Env.container_one "directory"
("directory", Env.string)
(fn directory =>
(write "\t\n";
inLocal := true),
fn () => (write "\t\n";
inLocal := false;
localRewriteEnabled := false))
fun checkRewrite () =
if !inLocal then
if !localRewriteEnabled then
()
else
(write "\tRewriteEngine on\n";
localRewriteEnabled := true)
else if !rewriteEnabled then
()
else
(write "\tRewriteEngine on\n";
rewriteEnabled := true)
val () = Env.action_three "localProxyRewrite"
("from", Env.string, "to", Env.string, "port", Env.int)
(fn (from, to, port) =>
(checkRewrite ();
write "\tRewriteRule\t";
write from;
write "\thttp://localhost:";
write (Int.toString port);
write "/";
write to;
write " [P]\n"))
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)
(fn (from, to, flags) =>
(checkRewrite ();
write "\tRewriteRule\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_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 "rewriteBase"
("prefix", Env.string)
(fn prefix =>
(checkRewrite ();
write "\tRewriteBase\t";
write prefix;
write "\n"))
val () = Env.action_one "rewriteLogLevel"
("level", Env.int)
(fn level =>
(checkRewrite ();
write "\tRewriteLog ";
write' (fn x => x);
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) =>
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 =>
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 "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 =>
(write "\tDirectoryIndex";
app (fn opt => (write " "; write opt)) opts;
write "\n"))
val () = Env.action_one "serverAliasHost"
("host", Env.string)
(fn host =>
(write "\tServerAlias ";
write host;
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 =>
if allowAuthType ty then
(write "\tAuthType ";
write ty;
write "\n";
case ty of
"kerberos" =>
write "\tKrbMethodNegotiate off\n\tKrbMethodK5Passwd on\n\tKrbVerifyKDC off\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)
(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_none "davFilesystem"
(fn path => write "\tDAV filesystem\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"))
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 () = 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 ^ ":"},
Domain.Extension {extension = "vhost_ssl",
heading = fn host => "SSL web vhost " ^ host ^ ":"}])
end