X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/d5754b53e4f119674b9d8a0bdf40bf92f6007d12..42782c7938b390dacda93c64ff4850b1a49f3c11:/src/plugins/apache.sml diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml index 4ea8f22..c4b47af 100644 --- a/src/plugins/apache.sml +++ b/src/plugins/apache.sml @@ -1,5 +1,6 @@ (* 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 @@ -22,69 +23,132 @@ 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) +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 (CharVector.all Char.isAlphaNum) +val _ = Env.type_one "suexec_flag" + 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 validLocation -val dl = ErrorMsg.dummyLoc +fun validCert s = Acl.query {user = Domain.getUser (), + class = "cert", + value = s} -val _ = Main.registerDefault ("WebNodes", - (TList (TBase "node", dl), dl), - (fn () => (EList (map (fn s => (EString s, dl)) Config.Apache.webNodes), dl))) +fun validCaCert s = Acl.query {user = Domain.getUser (), + class = "cacert", + value = s} -val _ = Main.registerDefault ("SSL", - (TBase "bool", dl), - (fn () => (EVar "false", dl))) +val _ = Env.type_one "ssl_cert_path" + Env.string + validCert -val _ = Main.registerDefault ("User", - (TBase "your_user", dl), - (fn () => (EString (Domain.getUser ()), dl))) +val _ = Env.type_one "ssl_cacert_path" + Env.string + validCaCert -val _ = Main.registerDefault ("Group", - (TBase "your_group", dl), - (fn () => (EString (Domain.getUser ()), dl))) +fun ssl e = case e of + (EVar "no_ssl", _) => SOME NONE + | (EApp ((EVar "use_cert", _), s), _) => Option.map SOME (Env.string s) + | _ => NONE -val _ = Main.registerDefault ("DocumentRoot", - (TBase "your_path", dl), - (fn () => (EString ("/home/" ^ Domain.getUser () ^ "/public_html"), dl))) +fun validExtension s = + size s > 0 + andalso size s < 20 + andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"_") s -val _ = Main.registerDefault ("ServerAdmin", - (TBase "email", dl), - (fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl))) +val _ = Env.type_one "file_extension" + Env.string + validExtension +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" @@ -96,6 +160,7 @@ val redirect_code = fn (EVar "temp", _) => SOME "temp" | (EVar "redir304", _) => SOME "304" | (EVar "redir305", _) => SOME "305" | (EVar "redir307", _) => SOME "307" + | (EVar "notfound", _) => SOME "404" | _ => NONE val flag = fn (EVar "redirect", _) => SOME "R" @@ -126,34 +191,225 @@ 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" + | (EVar "multiViews", _) => SOME "MultiViews" + | _ => 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 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) + (fn () => (vhostsChanged := false; + logDeleted := false; + delayedLogMoves := (fn () => print "Executing delayed log moves/deletes.\n"))) + +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 - (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))) + 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 + val dlm = !delayedLogMoves + 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)); + delayedLogMoves := (fn () => (dlm (); + 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 + + val dlm = !delayedLogMoves + in + if !logDeleted then + () + else + ((*ignore (OS.Process.system (down ()));*) + logDeleted := true); + delayedLogMoves := (fn () => (dlm (); + 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) @@ -161,96 +417,275 @@ val () = Slave.registerFileHandler (fn fs => val () = Slave.registerPostHandler (fn () => (if !vhostsChanged then - Slave.shellF ([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 vhostFiles : TextIO.outstream list ref = ref [] -fun write s = app (fn file => TextIO.output (file, s)) (!vhostFiles) +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 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 = + 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 + +fun vhostPost () = (!post (); + write "\n"; + app (TextIO.closeOut o #2) (!vhostFiles)) + +val php_version = fn (EVar "php5", _) => SOME 5 + | (EVar "fast_php", _) => SOME 6 + | _ => 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 "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\tGroup "); + TextIO.output (file, group)) + else + (TextIO.output (file, "\n\tSuexecUserGroup "); + TextIO.output (file, user); + TextIO.output (file, " "); + TextIO.output (file, group); + TextIO.output (file, "\n\tsuPHP_UserGroup "); + 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"); + + if php = Config.Apache.defaultPhpVersion + then + () + else if php = 6 + then + (* fastcgi php 5.6 since 6 doesn't exist *) + (TextIO.output (file, "\n\tAddHandler fcgid-script .php .phtml"); + TextIO.output (file, "\n\tFcgidWrapper \""); + TextIO.output (file, Config.Apache.fastCgiWrapperOf user); + TextIO.output (file, " "); + TextIO.output (file, Config.Apache.phpFastCgiWrapper); + TextIO.output (file, "\"")) + else + (TextIO.output (file, "\n\tAddHandler x-httpd-php"); + TextIO.output (file, Int.toString php); + TextIO.output (file, " .php .phtml")); + (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) => - let - val nodes = Env.env (Env.list Env.string) (env, "WebNodes") + (fn (env, host) => vhostBody (env, fn dom => host ^ "." ^ dom), + vhostPost) - 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 () = Env.containerV_none "vhostDefault" + (fn env => vhostBody (env, fn dom => dom), + vhostPost) - val fullHost = host ^ "." ^ Domain.currentDomain () - val confFile = fullHost ^ (if ssl then ".vhost_ssl" else ".vhost") - in - rewriteEnabled := false; - vhostFiles := map (fn node => - let - val file = Domain.domainFile {node = node, - name = confFile} - in - TextIO.output (file, "\n"); - file - end) - nodes; - write "\tSuexecUserGroup "; - write user; - write " "; - write group; - write "\n\tDocumentRoot "; - write docroot; - write "\n\tServerAdmin "; - write sadmin; - write "\n" - end, - fn () => (write "\n"; - app TextIO.closeOut (!vhostFiles))) +val inLocal = ref false val () = Env.container_one "location" ("prefix", Env.string) (fn prefix => (write "\t\n"), - fn () => write "\t\n") + write ">\n"; + inLocal := true), + fn () => (write "\t\n"; + inLocal := false; + localRewriteEnabled := false; + localExpiresEnabled := false)) val () = Env.container_one "directory" ("directory", Env.string) (fn directory => (write "\t\n"), - fn () => write "\t\n") + write ">\n"; + inLocal := true), + fn () => (write "\t\n"; + inLocal := false; + localRewriteEnabled := false; + localExpiresEnabled := false)) + +val () = Env.container_one "filesMatch" + ("regexp", Env.string) + (fn prefix => + (write "\t\n"), + fn () => (write "\t\n"; + localRewriteEnabled := false; + localExpiresEnabled := false)) fun checkRewrite () = - if !rewriteEnabled then + if !inLocal then + if !localRewriteEnabled then + () + else + (write "\tRewriteEngine on\n"; + localRewriteEnabled := true) + else if !rewriteEnabled then () else (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) => @@ -258,7 +693,7 @@ val () = Env.action_two "proxyPass" write from; write "\t"; write to; - write "\n")) + write "\tretry=0\n")) val () = Env.action_two "proxyPassReverse" ("from", Env.string, "to", Env.string) @@ -269,14 +704,22 @@ val () = Env.action_two "proxyPassReverse" write to; write "\n")) +val () = Env.action_one "proxyPreserveHost" + ("enable", Env.bool) + (fn (enable) => + (write "\tProxyPreserveHost\t"; + if enable then write "On" else write "Off"; + 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 "\tRewriteRule\t\""; write from; - write "\t"; + write "\"\t\""; write to; + write "\""; case flags of [] => () | flag::rest => (write " ["; @@ -290,10 +733,11 @@ 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 "\tRewriteCond\t\""; write from; - write "\t"; + write "\"\t\""; write to; + write "\""; case flags of [] => () | flag::rest => (write " ["; @@ -303,6 +747,24 @@ val () = Env.action_three "rewriteCond" 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) => @@ -324,11 +786,403 @@ val () = Env.action_two "scriptAlias" val () = Env.action_two "errorDocument" ("code", Env.string, "handler", Env.string) (fn (code, handler) => - (write "\tErrorDocument\t"; - write code; - write " "; - write 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 "\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) + (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_one "authGroupFile" + ("file", Env.string) + (fn name => + (write "\tAuthGroupFile "; + 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_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 => + 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 "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 => + 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 () = 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 " ^ 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_one "allowEncodedSlashes" + ("enable", Env.bool) + (fn enable => (write "\tAllowEncodedSlashes "; + write (if enable then "NoDecode" else "Off"); + write "\n")) +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, "\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\n\n"))) users; + TextIO.closeOut outf + end + +val () = Domain.registerOnUsersChange writeWaklogUserFile end