X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/60695e9923af9e74160575b5de0d5549808294b4..767fe69579cd02e13f88b59a94522a9d9b298f1b:/src/plugins/apache.sml diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml index 079afca..35d6cda 100644 --- a/src/plugins/apache.sml +++ b/src/plugins/apache.sml @@ -1,5 +1,5 @@ (* HCoop Domtool (http://hcoop.sourceforge.net/) - * Copyright (c) 2006, Adam Chlipala + * 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 @@ -22,12 +22,40 @@ 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 - (fn node => - List.exists (fn x => x = node) Config.Apache.webNodes_all - orelse (Domain.inGroup "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 @@ -40,13 +68,19 @@ val _ = Env.type_one "proxy_target" 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 ()) + "http" :: "//localhost" :: rest => + let + val rest = String.concatWith ":" rest + in + 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 () + | SOME n => n > 1024 orelse default ()) + | _ => default () + end | _ => default () end) @@ -54,48 +88,75 @@ 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 - -val _ = Env.registerFunction ("web_node_to_node", - fn [e] => SOME e - | _ => NONE) - -val _ = Defaults.registerDefault ("WebNodes", - (TList (TBase "web_node", dl), dl), - (fn () => (EList (map (fn s => (EString s, dl)) Config.Apache.webNodes_default), dl))) +fun validCert s = Acl.query {user = Domain.getUser (), + class = "cert", + value = s} -val _ = Defaults.registerDefault ("SSL", - (TBase "bool", 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))) +val _ = Env.type_one "ssl_cert_path" + Env.string + validCert -val _ = Defaults.registerDefault ("DocumentRoot", - (TBase "your_path", dl), - (fn () => (EString (Config.homeBase ^ "/" ^ Domain.getUser () ^ "/" ^ Config.Apache.public_html), 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 _ = Defaults.registerDefault ("ServerAdmin", - (TBase "email", dl), - (fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl))) +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))), + ("PhpVersion", + (TBase "php_version", dl), + (fn () => (EVar "php4", dl)))] + +val () = app Defaults.registerDefault defaults val redirect_code = fn (EVar "temp", _) => SOME "temp" | (EVar "permanent", _) => SOME "permanent" @@ -140,6 +201,7 @@ val cond_flag = fn (EVar "cond_nocase", _) => SOME "NC" 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 "*" @@ -180,9 +242,13 @@ val autoindex_option = fn (EApp ((EVar "descriptionWidth", _), w), _) => | _ => 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 @@ -192,69 +258,151 @@ fun findVhostUser fname = case TextIO.inputLine inf of NONE => NONE | SOME line => - case String.tokens Char.isSpace line of - ["SuexecUserGroup", user, _] => SOME user - | _ => loop () + 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 + 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 - case findVhostUser (#file fs) of - NONE => print ("Can't find user in " ^ #file fs ^ "! Taking no action.\n") - | SOME user => - let - val realVhostFile = OS.Path.joinDirFile - {dir = Config.Apache.confDir, - file = #file spl} - - val realLogDir = OS.Path.joinDirFile - {dir = Config.homeBase, - file = 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} - in - vhostsChanged := true; - case #action fs of - Slave.Delete => - (ignore (OS.Process.system (Config.rm - ^ " -rf " - ^ realVhostFile)); - ignore (OS.Process.system (Config.rm - ^ " -rf " - ^ realLogDir))) - | Slave.Add => - (ignore (OS.Process.system (Config.cp - ^ " " - ^ #file fs - ^ " " - ^ realVhostFile)); - OS.FileSys.mkDir realLogDir) - - | _ => - ignore (OS.Process.system (Config.cp - ^ " " - ^ #file fs - ^ " " - ^ realVhostFile)) - end + 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) @@ -262,8 +410,9 @@ 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 ())) @@ -272,8 +421,10 @@ fun write' s = app (fn (node, file) => TextIO.output (file, s node)) (!vhostFile 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 = @@ -291,6 +442,9 @@ fun registerPost f = post := (fn () => (old (); f ())) end +fun doPre x = !pre x +fun doPost () = !post () + val aliaser = ref (fn _ : string => ()) fun registerAliaser f = let @@ -299,95 +453,164 @@ fun registerAliaser f = 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 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") +fun vhostPost () = (!post (); + write "\n"; + app (TextIO.closeOut o #2) (!vhostFiles)) - 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; +val php_version = fn (EVar "php4", _) => SOME 4 + | (EVar "php5", _) => SOME 5 + | _ => NONE - rewriteEnabled := false; - vhostFiles := map (fn node => - let - val file = Domain.domainFile {node = node, - name = confFile} - in - TextIO.output (file, "\n"); - TextIO.output (file, "\tErrorLog "); - TextIO.output (file, Config.homeBase); - TextIO.output (file, "/"); +fun vhostBody (env, makeFullHost) = + let + val places = Env.env (Env.list webPlace) (env, "WebPlaces") + + val ssl = Env.env ssl (env, "SSL") + val user = Env.env Env.string (env, "User") + val group = Env.env Env.string (env, "Group") + val docroot = Env.env Env.string (env, "DocumentRoot") + val sadmin = Env.env Env.string (env, "ServerAdmin") + val suexec = Env.env Env.bool (env, "SuExec") + val php = Env.env php_version (env, "PhpVersion") + + val fullHost = makeFullHost (Domain.currentDomain ()) + val vhostId = fullHost ^ (if Option.isSome ssl then ".ssl" else "") + val confFile = fullHost ^ (if Option.isSome ssl then ".vhost_ssl" else ".vhost") + in + currentVhost := fullHost; + currentVhostId := vhostId; + sslEnabled := Option.isSome ssl; + + rewriteEnabled := false; + localRewriteEnabled := false; + vhostFiles := map (fn (node, ip) => + let + val file = Domain.domainFile {node = node, + name = confFile} + + val ld = logDir {user = user, node = node, vhostId = vhostId} + in + TextIO.output (file, "# Owner: "); + TextIO.output (file, user); + TextIO.output (file, "\n "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, "/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, "\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, "/access.log combined\n"); - (Config.homeBase ^ "/" ^ user ^ "/apache/log/" - ^ node ^ "/" ^ vhostId, 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"; - !pre {user = user, nodes = nodes, id = vhostId, hostname = fullHost} - end, - fn () => (!post (); - write "\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 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)) 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)) + +val () = Env.container_one "filesMatch" + ("regexp", Env.string) + (fn prefix => + (write "\t\n"), + fn () => (write "\t\n"; + localRewriteEnabled := 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"; @@ -397,9 +620,9 @@ 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; @@ -427,10 +650,11 @@ 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 " ["; @@ -444,10 +668,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 " ["; @@ -457,6 +682,14 @@ 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 => @@ -488,12 +721,24 @@ 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; - 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 => @@ -521,6 +766,12 @@ val () = Env.action_one "unset_options" 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 => @@ -528,7 +779,7 @@ val () = Env.action_one "directoryIndex" 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 "; @@ -536,16 +787,52 @@ val () = Env.action_one "serverAlias" 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 "\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) @@ -653,6 +940,9 @@ val () = Env.action_one "authzSvnAccessFile" 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) => @@ -664,6 +954,17 @@ val () = Env.action_two "addDescription" 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 => @@ -677,6 +978,15 @@ val () = Env.action_one "indexOptions" (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 => @@ -713,4 +1023,59 @@ val () = Env.action_one "readmeName" 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 () = 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 ^ ":"}]) + +val () = Env.action_none "testNoHtaccess" + (fn path => write "\tAllowOverride None\n") + end