(* HCoop Domtool (http://hcoop.sourceforge.net/)
* Copyright (c) 2006, 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 _ = 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)
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 _ = Main.registerDefault ("SSL",
(TBase "bool", dl),
(fn () => (EVar "false", dl)))
val _ = Main.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 _ = Main.registerDefault ("DocumentRoot",
(TBase "your_path", dl),
(fn () => (EString ("/home/" ^ Domain.getUser () ^ "/public_html"), dl)))
val _ = Main.registerDefault ("ServerAdmin",
(TBase "email", dl),
(fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl)))
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"
| _ => NONE
val vhostsChanged = ref false
val () = Slave.registerPreHandler
(fn () => vhostsChanged := false)
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
(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.cp
^ " "
^ #file fs
^ " "
^ Config.Apache.confDir
^ "/"
^ #file spl)))
else
()
end)
val () = Slave.registerPostHandler
(fn () =>
(if !vhostsChanged then
Slave.shellF ([Config.Apache.reload],
fn cl => "Error reloading Apache with " ^ cl)
else
()))
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 () = 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 Env.bool (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 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
val file = Domain.domainFile {node = node,
name = confFile}
in
TextIO.output (file, "\n");
file
end)
nodes;
write "\tServerName ";
write fullHost;
write "\n\tSuexecUserGroup ";
write user;
write " ";
write group;
write "\n\tDocumentRoot ";
write docroot;
write "\n\tServerAdmin ";
write sadmin;
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"
end,
fn () => (write "\n";
app TextIO.closeOut (!vhostFiles)))
val () = Env.container_one "location"
("prefix", Env.string)
(fn prefix =>
(write "\t\n"),
fn () => write "\t\n")
val () = Env.container_one "directory"
("directory", Env.string)
(fn directory =>
(write "\t\n"),
fn () => write "\t\n")
fun checkRewrite () =
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 "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"))
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"))
end