X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/4cbaa5a74c199730a4601e3eff8a7512dda20165..781ebc11c3ab9b359cd0ee1cc653bd8f223a0bd8:/src/plugins/apache.sml diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml index 7183bcb..617420a 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,17 +22,41 @@ 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.hasPriv "www" - andalso List.exists (fn x => x = node) Config.Apache.webNodes_admin)) + webNode val _ = Env.registerFunction ("web_node_to_node", fn [e] => SOME e | _ => NONE) +fun webPlace (EApp ((EVar "web_place_default", _), (EString node, _)), _) = + SOME (node, Domain.nodeIp node) + | webPlace (EApp ((EApp ((EVar "web_place", _), (EString node, _)), _), (EString ip, _)), _) = + SOME (node, ip) + | webPlace _ = NONE + +fun webPlaceDefault node = (EApp ((EVar "web_place_default", dl), (EString node, dl)), dl) + +val _ = Env.registerFunction ("web_place_to_web_node", + fn [e] => Option.map (fn (node, _) => (EString node, dl)) (webPlace e) + | _ => NONE) + +val _ = Env.registerFunction ("web_place_to_node", + fn [e] => Option.map (fn (node, _) => (EString node, dl)) (webPlace e) + | _ => NONE) + +val _ = Env.registerFunction ("web_place_to_ip", + fn [e] => Option.map (fn (_, ip) => (EString ip, dl)) (webPlace e) + | _ => NONE) + val _ = Env.type_one "proxy_port" Env.int (fn n => n > 1024) @@ -87,35 +111,38 @@ fun ssl e = case e of | (EApp ((EVar "use_cert", _), s), _) => Option.map SOME (Env.string s) | _ => NONE -val dl = ErrorMsg.dummyLoc - -val _ = Defaults.registerDefault ("WebNodes", - (TList (TBase "web_node", dl), dl), - (fn () => (EList (map (fn s => (EString s, dl)) Config.Apache.webNodes_default), dl))) - -val _ = Defaults.registerDefault ("SSL", - (TBase "ssl", dl), - (fn () => (EVar "no_ssl", 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 _ = Defaults.registerDefault ("DocumentRoot", - (TBase "your_path", dl), - (fn () => (EString (Domain.homedir () ^ "/" ^ Config.Apache.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 _ = Defaults.registerDefault ("ServerAdmin", - (TBase "email", dl), - (fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl))) - -val _ = Defaults.registerDefault ("SuExec", - (TBase "suexec_flag", dl), - (fn () => (EVar "true", dl))) +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" @@ -160,6 +187,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 "*" @@ -225,6 +253,37 @@ fun findVhostUser fname = 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) @@ -236,49 +295,49 @@ val () = Slave.registerFileHandler (fn fs => file = #file spl} val user = findVhostUser (#file fs) - val oldUser = findVhostUser realVhostFile + val oldUser = case #action fs of + Slave.Delete false => user + | _ => findVhostUser realVhostFile in if (oldUser = NONE andalso #action fs <> Slave.Add) - orelse (user = NONE andalso #action fs <> Slave.Delete) then + orelse (user = NONE andalso not (Slave.isDelete (#action fs))) then print ("Can't find user in " ^ #file fs ^ " or " ^ realVhostFile ^ "! Taking no action.\n") else let + val vhostId = if OS.Path.ext (#file spl) = SOME "vhost_ssl" then + OS.Path.base (#file spl) ^ ".ssl" + else + OS.Path.base (#file spl) + fun realLogDir user = + logDir {user = valOf user, + node = Slave.hostname (), + vhostId = vhostId} + + fun backupLogs () = + OS.Path.joinDirFile + {dir = Config.Apache.backupLogDirOf + (isVersion1 (Slave.hostname ())), + file = vhostId} + in + vhostsChanged := true; + case #action fs of + Slave.Delete _ => let - val realLogDir = Domain.homedirOf (valOf user) - val realLogDir = OS.Path.joinDirFile - {dir = realLogDir, - file = "apache"} - val realLogDir = OS.Path.joinDirFile - {dir = realLogDir, - file = "log"} - val realLogDir = OS.Path.joinDirFile - {dir = realLogDir, - file = Slave.hostname ()} - val {base, ...} = OS.Path.splitBaseExt (#file spl) - - val realLogDir = OS.Path.concat (realLogDir, base) + val ldir = realLogDir oldUser in - if String.isSuffix ".vhost_ssl" (#file spl) then - realLogDir ^ ".ssl" + if !logDeleted then + () else - realLogDir + (ignore (OS.Process.system (down ())); + ignore (OS.Process.system (fixperms ())); + logDeleted := true); + ignore (OS.Process.system (Config.rm + ^ " -rf " + ^ realVhostFile)); + Slave.moveDirCreate {from = ldir, + to = backupLogs ()} end - in - vhostsChanged := true; - case #action fs of - Slave.Delete => - (if !logDeleted then - () - else - (ignore (OS.Process.system Config.Apache.down); - logDeleted := true); - ignore (OS.Process.system (Config.rm - ^ " -rf " - ^ realVhostFile)); - ignore (OS.Process.system (Config.rm - ^ " -rf " - ^ realLogDir oldUser))) | Slave.Add => let val rld = realLogDir user @@ -291,7 +350,8 @@ val () = Slave.registerFileHandler (fn fs => if Posix.FileSys.access (rld, []) then () else - OS.FileSys.mkDir rld + Slave.moveDirCreate {from = backupLogs (), + to = rld} end | _ => @@ -308,7 +368,7 @@ val () = Slave.registerFileHandler (fn fs => if !logDeleted then () else - (ignore (OS.Process.system Config.Apache.down); + (ignore (OS.Process.system (down ())); logDeleted := true); ignore (OS.Process.system (Config.rm ^ " -rf " @@ -316,7 +376,7 @@ val () = Slave.registerFileHandler (fn fs => if Posix.FileSys.access (rld, []) then () else - OS.FileSys.mkDir rld + Slave.mkDirAll rld end else ()) @@ -329,7 +389,7 @@ val () = Slave.registerFileHandler (fn fs => val () = Slave.registerPostHandler (fn () => (if !vhostsChanged then - Slave.shellF ([if !logDeleted then Config.Apache.undown else Config.Apache.reload], + Slave.shellF ([if !logDeleted then undown () else reload ()], fn cl => "Error reloading Apache with " ^ cl) else ())) @@ -342,6 +402,7 @@ 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 = @@ -359,6 +420,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 @@ -371,7 +435,7 @@ val () = Env.containerV_one "vhost" ("host", Env.string) (fn (env, host) => let - val nodes = Env.env (Env.list Env.string) (env, "WebNodes") + val places = Env.env (Env.list webPlace) (env, "WebPlaces") val ssl = Env.env ssl (env, "SSL") val user = Env.env Env.string (env, "User") @@ -386,49 +450,69 @@ val () = Env.containerV_one "vhost" in currentVhost := fullHost; currentVhostId := vhostId; + sslEnabled := Option.isSome ssl; rewriteEnabled := false; localRewriteEnabled := false; - vhostFiles := map (fn node => + 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, Domain.homedirOf user); - TextIO.output (file, "/apache/log/"); - TextIO.output (file, node); - TextIO.output (file, "/"); - TextIO.output (file, vhostId); + TextIO.output (file, ld); TextIO.output (file, "/error.log\n\tCustomLog "); - TextIO.output (file, Domain.homedirOf user); - TextIO.output (file, "/apache/log/"); - TextIO.output (file, node); - TextIO.output (file, "/"); - TextIO.output (file, vhostId); + TextIO.output (file, ld); TextIO.output (file, "/access.log combined\n"); - (Domain.homedirOf user ^ "/apache/log/" - ^ node ^ "/" ^ vhostId, file) + 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) - nodes; - write "\tServerName "; - write fullHost; - if suexec then - (write "\n\tSuexecUserGroup "; - write user; - write " "; - write group) - else - (); + places; write "\n\tDocumentRoot "; write docroot; write "\n\tServerAdmin "; @@ -439,7 +523,8 @@ val () = Env.containerV_one "vhost" write cert) | NONE => (); write "\n"; - !pre {user = user, nodes = nodes, id = vhostId, hostname = fullHost} + !pre {user = user, nodes = map #1 places, id = vhostId, hostname = fullHost}; + app (fn dom => !aliaser (host ^ "." ^ dom)) (Domain.currentAliasDomains ()) end, fn () => (!post (); write "\n"; @@ -471,7 +556,7 @@ val () = Env.container_one "directory" fun checkRewrite () = if !inLocal then - if !rewriteEnabled orelse !localRewriteEnabled then + if !localRewriteEnabled then () else (write "\tRewriteEngine on\n"; @@ -546,6 +631,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 => @@ -577,12 +670,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 => @@ -610,6 +715,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 => @@ -617,7 +728,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 "; @@ -625,16 +736,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) @@ -742,6 +889,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) => @@ -802,7 +952,22 @@ 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 () = 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