X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/d441e69fed5d0cb98549b10aa66c2637499021da..976657583f419a6a204400ea90f9758d15243acb:/src/plugins/apache.sml diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml index f497825..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 ^ " " @@ -175,6 +218,32 @@ val vhostFiles : TextIO.outstream list ref = ref [] 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 _ : {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 +258,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 @@ -208,7 +281,9 @@ val () = Env.containerV_one "vhost" file end) nodes; - write "\tSuexecUserGroup "; + write "\tServerName "; + write fullHost; + write "\n\tSuexecUserGroup "; write user; write " "; write group; @@ -216,9 +291,19 @@ val () = Env.containerV_one "vhost" write docroot; write "\n\tServerAdmin "; write sadmin; - write "\n" + write "\n\tErrorLog "; + write Config.Apache.logDir; + write "/"; + write vhostId; + write "/error.log\n\tCustomLog "; + write Config.Apache.logDir; + write "/"; + write vhostId; + 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" @@ -308,6 +393,18 @@ val () = Env.action_three "rewriteCond" write "]"); write "\n")) +val () = Env.action_one "rewriteLogLevel" + ("level", Env.int) + (fn level => + (checkRewrite (); + write "\tRewriteLog "; + write Config.Apache.logDir; + write "/"; + write (!currentVhostId); + 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) => @@ -362,4 +459,196 @@ val () = Env.action_one "unset_options" app (fn opt => (write " -"; write opt)) opts; 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 "serverAlias" + ("host", Env.string) + (fn host => + (write "\tServerAlias "; + write host; + write "\n"; + !aliaser host)) + +val authType = fn (EVar "basic", _) => SOME "basic" + | (EVar "digest", _) => SOME "digest" + | _ => NONE + +val () = Env.action_one "authType" + ("type", authType) + (fn ty => + (write "\tAuthType "; + write ty; + write "\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_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_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