X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/c98b57cf26f5174f128602281eac7c496d254011..976657583f419a6a204400ea90f9758d15243acb:/src/plugins/apache.sml diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml index 3c29c8e..ffd18b2 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 () ^ "/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,6 +131,42 @@ 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 @@ -146,11 +182,18 @@ val () = Slave.registerFileHandler (fn fs => (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.rm + ^ " -rf " + ^ Config.Apache.confDir + ^ "/" + ^ #file spl)); + ignore (OS.Process.system (Config.rm + ^ " -rf " + ^ Config.Apache.logDir + ^ "/" + ^ #base (OS.Path.splitBaseExt + (#file spl))))) + | _ => ignore (OS.Process.system (Config.cp ^ " " @@ -178,6 +221,30 @@ val rewriteEnabled = ref false val currentVhost = ref "" val currentVhostId = ref "" +val pre = ref (fn _ : {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) (fn (env, host) => @@ -232,9 +299,11 @@ val () = Env.containerV_one "vhost" write Config.Apache.logDir; write "/"; write vhostId; - write "/access.log combined\n" + write "/access.log combined\n"; + !pre {nodes = nodes, id = vhostId, hostname = fullHost} end, - fn () => (write "\n"; + fn () => (!post (); + write "\n"; app TextIO.closeOut (!vhostFiles))) val () = Env.container_one "location" @@ -402,7 +471,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" @@ -509,4 +579,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