(* HCoop Domtool (http://hcoop.sourceforge.net/) * Copyright (c) 2006, Adam Chlipala * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *) (* Apache HTTPD handling *) structure Apache :> APACHE = struct open Ast val _ = Env.type_one "proxy_port" Env.int (fn n => n > 1024) val _ = Env.type_one "proxy_target" Env.string (fn s => let 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 ()) | _ => default () end) val _ = Env.type_one "rewrite_arg" Env.string (CharVector.all Char.isAlphaNum) 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 _ = Main.registerDefault ("SSL", (TBase "bool", dl), (fn () => (EVar "false", dl))) val _ = Main.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 _ = Main.registerDefault ("DocumentRoot", (TBase "your_path", dl), (fn () => (EString ("/home/" ^ Domain.getUser () ^ "/public_html"), dl))) val _ = Main.registerDefault ("ServerAdmin", (TBase "email", dl), (fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl))) val redirect_code = fn (EVar "temp", _) => SOME "temp" | (EVar "permanent", _) => SOME "permanent" | (EVar "seeother", _) => SOME "seeother" | (EVar "redir300", _) => SOME "300" | (EVar "redir301", _) => SOME "301" | (EVar "redir302", _) => SOME "302" | (EVar "redir303", _) => SOME "303" | (EVar "redir304", _) => SOME "304" | (EVar "redir305", _) => SOME "305" | (EVar "redir307", _) => SOME "307" | _ => NONE val flag = fn (EVar "redirect", _) => SOME "R" | (EVar "forbidden", _) => SOME "F" | (EVar "gone", _) => SOME "G" | (EVar "last", _) => SOME "L" | (EVar "chain", _) => SOME "C" | (EVar "nosubreq", _) => SOME "NS" | (EVar "nocase", _) => SOME "NC" | (EVar "qsappend", _) => SOME "QSA" | (EVar "noescape", _) => SOME "NE" | (EVar "passthrough", _) => SOME "PT" | (EApp ((EVar "mimeType", _), e), _) => Option.map (fn s => "T=" ^ s) (Env.string e) | (EApp ((EVar "redirectWith", _), e), _) => Option.map (fn s => "R=" ^ s) (redirect_code e) | (EApp ((EVar "skip", _), e), _) => Option.map (fn n => "S=" ^ Int.toString n) (Env.int e) | (EApp ((EApp ((EVar "env", _), e1), _), e2), _) => (case Env.string e1 of NONE => NONE | SOME s1 => Option.map (fn s2 => "E=" ^ s1 ^ ":" ^ s2) (Env.string e2)) | _ => NONE val cond_flag = fn (EVar "cond_nocase", _) => SOME "NC" | (EVar "ornext", _) => SOME "OR" | _ => NONE val vhostsChanged = ref false val () = Slave.registerPreHandler (fn () => vhostsChanged := false) 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))) else () end) val () = Slave.registerPostHandler (fn () => (if !vhostsChanged then Slave.shellF ([Config.Apache.reload], fn cl => "Error reloading Apache with " ^ cl) else ())) val vhostFiles : TextIO.outstream list ref = ref [] fun write s = app (fn file => TextIO.output (file, s)) (!vhostFiles) val rewriteEnabled = ref false 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") val fullHost = host ^ "." ^ Domain.currentDomain () val confFile = fullHost ^ (if ssl then ".vhost_ssl" else ".vhost") in rewriteEnabled := false; vhostFiles := map (fn node => let val file = Domain.domainFile {node = node, name = confFile} in TextIO.output (file, "\n"); file end) nodes; write "\tSuexecUserGroup "; write user; write " "; write group; write "\n\tDocumentRoot "; write docroot; write "\n\tServerAdmin "; write sadmin; write "\n" end, fn () => (write "\n"; app TextIO.closeOut (!vhostFiles))) fun checkRewrite () = if !rewriteEnabled then () else (write "\tRewriteEngine on\n"; rewriteEnabled := true) val () = Env.action_three "localProxyRewrite" ("from", Env.string, "to", Env.string, "port", Env.int) (fn (from, to, port) => (checkRewrite (); write "\tRewriteRule\t"; write from; write "\thttp://localhost:"; write (Int.toString port); write "/"; write to; write " [P]\n")) val () = Env.action_two "proxyPass" ("from", Env.string, "to", Env.string) (fn (from, to) => (write "\tProxyPass\t"; write from; write "\t"; write to; write "\n")) val () = Env.action_two "proxyPassReverse" ("from", Env.string, "to", Env.string) (fn (from, to) => (write "\tProxyPassReverse\t"; write from; write "\t"; write to; write "\n")) val () = Env.action_three "rewriteRule" ("from", Env.string, "to", Env.string, "flags", Env.list flag) (fn (from, to, flags) => (checkRewrite (); write "\tRewriteRule\t"; write from; write "\t"; write to; case flags of [] => () | flag::rest => (write " ["; write flag; app (fn flag => (write ","; write flag)) rest; write "]"); write "\n")) 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 from; write "\t"; write to; case flags of [] => () | flag::rest => (write " ["; write flag; app (fn flag => (write ","; write flag)) rest; write "]"); write "\n")) end