X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/7f012ffdbae5dbee9642fee030647d558b25c8c4..de7fde3da2abb20767042276f24aae79c5925f95:/src/plugins/apache.sml diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml index 23f8dd3..6c04738 100644 --- a/src/plugins/apache.sml +++ b/src/plugins/apache.sml @@ -61,29 +61,29 @@ val _ = Env.type_one "location" 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 _ = Defaults.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 _ = Defaults.registerDefault ("SSL", + (TBase "bool", dl), + (fn () => (EVar "false", dl))) -val _ = Main.registerDefault ("User", - (TBase "your_user", dl), - (fn () => (EString (Domain.getUser ()), dl))) +val _ = Defaults.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 _ = Defaults.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 _ = Defaults.registerDefault ("DocumentRoot", + (TBase "your_path", dl), + (fn () => (EString (Config.homeBase ^ "/" ^ Domain.getUser () ^ "/" ^ Config.Apache.public_html), dl))) -val _ = Main.registerDefault ("ServerAdmin", - (TBase "email", dl), - (fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl))) +val _ = Defaults.registerDefault ("ServerAdmin", + (TBase "email", dl), + (fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl))) val redirect_code = fn (EVar "temp", _) => SOME "temp" @@ -131,34 +131,119 @@ val apache_option = fn (EVar "execCGI", _) => SOME "ExecCGI" | (EVar "indexes", _) => SOME "Indexes" | _ => 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 () = Slave.registerPreHandler (fn () => vhostsChanged := false) +fun findVhostUser fname = + let + val inf = TextIO.openIn fname + + fun loop () = + case TextIO.inputLine inf of + NONE => NONE + | SOME line => + case String.tokens Char.isSpace line of + ["SuexecUserGroup", user, _] => SOME user + | _ => loop () + in + loop () + before TextIO.closeIn inf + end + 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))) + 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 else () end) @@ -171,10 +256,37 @@ val () = Slave.registerPostHandler 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 currentVhost = ref "" +val currentVhostId = ref "" + +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 + +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) @@ -189,8 +301,12 @@ val () = Env.containerV_one "vhost" 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 @@ -205,7 +321,25 @@ val () = Env.containerV_one "vhost" else "80"); TextIO.output (file, ">\n"); - file + TextIO.output (file, "\tErrorLog "); + TextIO.output (file, Config.homeBase); + TextIO.output (file, "/"); + 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, 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 "; @@ -218,10 +352,12 @@ val () = Env.containerV_one "vhost" write docroot; write "\n\tServerAdmin "; write sadmin; - write "\n" + write "\n"; + !pre {user = user, nodes = nodes, id = vhostId, hostname = fullHost} end, - fn () => (write "\n"; - app TextIO.closeOut (!vhostFiles))) + fn () => (!post (); + write "\n"; + app (TextIO.closeOut o #2) (!vhostFiles))) val () = Env.container_one "location" ("prefix", Env.string) @@ -310,6 +446,16 @@ val () = Env.action_three "rewriteCond" write "]"); 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) => @@ -376,7 +522,8 @@ val () = Env.action_one "serverAlias" (fn host => (write "\tServerAlias "; write host; - write "\n")) + write "\n"; + !aliaser host)) val authType = fn (EVar "basic", _) => SOME "basic" | (EVar "digest", _) => SOME "digest" @@ -483,4 +630,76 @@ val () = Env.action_one "addDefaultCharset" 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_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")) + end