src/plugins/apache.sml

   1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
   2  * Copyright (c) 2006, Adam Chlipala
   3  *
   4  * This program is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU General Public License
   6  * as published by the Free Software Foundation; either version 2
   7  * of the License, or (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this program; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
  17  *)
  18
  19 (* Apache HTTPD handling *)
  20
  21 structure Apache :> APACHE = struct
  22
  23 open Ast
  24
  25 val _ = Env.type_one "proxy_port"
  26         Env.int
  27         (fn n => n > 1024)
  28
  29 val _ = Env.type_one "proxy_target"
  30         Env.string
  31         (fn s =>
  32             let
  33                 fun default () = List.exists (fn s' => s = s') Config.Apache.proxyTargets
  34             in
  35                 case String.fields (fn ch => ch = #":") s of
  36                     ["http", "//localhost", rest] =>
  37                     (case String.fields (fn ch => ch = #"/") rest of
  38                          port :: _ =>
  39                          (case Int.fromString port of
  40                               NONE => default ()
  41                             | SOME n => n > 1024 orelse default ())
  42                        | _ => default ())
  43                   | _ => default ()
  44             end)
  45
  46 val _ = Env.type_one "rewrite_arg"
  47         Env.string
  48         (CharVector.all Char.isAlphaNum)
  49
  50 fun validLocation s =
  51     size s > 0 andalso size s < 1000 andalso CharVector.all
  52                                                  (fn ch => Char.isAlphaNum ch
  53                                                            orelse ch = #"-"
  54                                                            orelse ch = #"_"
  55                                                            orelse ch = #"."
  56                                                            orelse ch = #"/") s
  57
  58 val _ = Env.type_one "location"
  59         Env.string
  60         validLocation
  61
  62 val dl = ErrorMsg.dummyLoc
  63
  64 val _ = Main.registerDefault ("WebNodes",
  65                               (TList (TBase "node", dl), dl),
  66                               (fn () => (EList (map (fn s => (EString s, dl)) Config.Apache.webNodes), dl)))
  67
  68 val _ = Main.registerDefault ("SSL",
  69                               (TBase "bool", dl),
  70                               (fn () => (EVar "false", dl)))
  71
  72 val _ = Main.registerDefault ("User",
  73                               (TBase "your_user", dl),
  74                               (fn () => (EString (Domain.getUser ()), dl)))
  75
  76 val _ = Main.registerDefault ("Group",
  77                               (TBase "your_group", dl),
  78                               (fn () => (EString (Domain.getUser ()), dl)))
  79
  80 val _ = Main.registerDefault ("DocumentRoot",
  81                               (TBase "your_path", dl),
  82                               (fn () => (EString ("/home/" ^ Domain.getUser () ^ "/public_html"), dl)))
  83
  84 val _ = Main.registerDefault ("ServerAdmin",
  85                               (TBase "email", dl),
  86                               (fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl)))
  87
  88
  89 val redirect_code = fn (EVar "temp", _) => SOME "temp"
  90                      | (EVar "permanent", _) => SOME "permanent"
  91                      | (EVar "seeother", _) => SOME "seeother"
  92                      | (EVar "redir300", _) => SOME "300"
  93                      | (EVar "redir301", _) => SOME "301"
  94                      | (EVar "redir302", _) => SOME "302"
  95                      | (EVar "redir303", _) => SOME "303"
  96                      | (EVar "redir304", _) => SOME "304"
  97                      | (EVar "redir305", _) => SOME "305"
  98                      | (EVar "redir307", _) => SOME "307"
  99                      | _ => NONE
 100
 101 val flag = fn (EVar "redirect", _) => SOME "R"
 102             | (EVar "forbidden", _) => SOME "F"
 103             | (EVar "gone", _) => SOME "G"
 104             | (EVar "last", _) => SOME "L"
 105             | (EVar "chain", _) => SOME "C"
 106             | (EVar "nosubreq", _) => SOME "NS"
 107             | (EVar "nocase", _) => SOME "NC"
 108             | (EVar "qsappend", _) => SOME "QSA"
 109             | (EVar "noescape", _) => SOME "NE"
 110             | (EVar "passthrough", _) => SOME "PT"
 111             | (EApp ((EVar "mimeType", _), e), _) =>
 112               Option.map (fn s => "T=" ^ s) (Env.string e)
 113             | (EApp ((EVar "redirectWith", _), e), _) =>
 114               Option.map (fn s => "R=" ^ s) (redirect_code e)
 115             | (EApp ((EVar "skip", _), e), _) =>
 116               Option.map (fn n => "S=" ^ Int.toString n) (Env.int e)
 117             | (EApp ((EApp ((EVar "env", _), e1), _), e2), _) =>
 118               (case Env.string e1 of
 119                    NONE => NONE
 120                  | SOME s1 => Option.map (fn s2 => "E=" ^ s1 ^ ":" ^ s2)
 121                                          (Env.string e2))
 122
 123             | _ => NONE
 124
 125 val cond_flag = fn (EVar "cond_nocase", _) => SOME "NC"
 126             | (EVar "ornext", _) => SOME "OR"
 127             | _ => NONE
 128
 129 val apache_option = fn (EVar "execCGI", _) => SOME "ExecCGI"
 130                      | (EVar "includesNOEXEC", _) => SOME "IncludesNOEXEC"
 131                      | (EVar "indexes", _) => SOME "Indexes"
 132                      | _ => NONE
 133
 134
 135 val vhostsChanged = ref false
 136
 137 val () = Slave.registerPreHandler
 138              (fn () => vhostsChanged := false)
 139
 140 val () = Slave.registerFileHandler (fn fs =>
 141                                        let
 142                                            val spl = OS.Path.splitDirFile (#file fs)
 143                                        in
 144                                            if String.isSuffix ".vhost" (#file spl)
 145                                               orelse String.isSuffix ".vhost_ssl" (#file spl) then
 146                                                (vhostsChanged := true;
 147                                                 case #action fs of
 148                                                     Slave.Delete =>
 149                                                     ignore (OS.Process.system (Config.rm
 150                                                                                ^ " -rf "
 151                                                                                ^ Config.Apache.confDir
 152                                                                                ^ "/"
 153                                                                                ^ #file spl))
 154                                                   | _ =>
 155                                                     ignore (OS.Process.system (Config.cp
 156                                                                                ^ " "
 157                                                                                ^ #file fs
 158                                                                                ^ " "
 159                                                                                ^ Config.Apache.confDir
 160                                                                                ^ "/"
 161                                                                                ^ #file spl)))
 162                                            else
 163                                                ()
 164                                        end)
 165
 166 val () = Slave.registerPostHandler
 167          (fn () =>
 168              (if !vhostsChanged then
 169                   Slave.shellF ([Config.Apache.reload],
 170                                 fn cl => "Error reloading Apache with " ^ cl)
 171               else
 172                   ()))
 173
 174 val vhostFiles : TextIO.outstream list ref = ref []
 175 fun write s = app (fn file => TextIO.output (file, s)) (!vhostFiles)
 176
 177 val rewriteEnabled = ref false
 178 val currentVhost = ref ""
 179 val currentVhostId = ref ""
 180
 181 val () = Env.containerV_one "vhost"
 182          ("host", Env.string)
 183          (fn (env, host) =>
 184              let
 185                  val nodes = Env.env (Env.list Env.string) (env, "WebNodes")
 186
 187                  val ssl = Env.env Env.bool (env, "SSL")
 188                  val user = Env.env Env.string (env, "User")
 189                  val group = Env.env Env.string (env, "Group")
 190                  val docroot = Env.env Env.string (env, "DocumentRoot")
 191                  val sadmin = Env.env Env.string (env, "ServerAdmin")
 192
 193                  val fullHost = host ^ "." ^ Domain.currentDomain ()
 194                  val vhostId = fullHost ^ (if ssl then ".ssl" else "")
 195                  val confFile = fullHost ^ (if ssl then ".vhost_ssl" else ".vhost")
 196              in
 197                  currentVhost := fullHost;
 198                  currentVhostId := vhostId;
 199
 200                  rewriteEnabled := false;
 201                  vhostFiles := map (fn node =>
 202                                        let
 203                                            val file = Domain.domainFile {node = node,
 204                                                                          name = confFile}
 205                                        in
 206                                            TextIO.output (file, "<VirtualHost ");
 207                                            TextIO.output (file, Domain.nodeIp node);
 208                                            TextIO.output (file, ":");
 209                                            TextIO.output (file, if ssl then
 210                                                                     "443"
 211                                                                 else
 212                                                                     "80");
 213                                            TextIO.output (file, ">\n");
 214                                            file
 215                                        end)
 216                                    nodes;
 217                  write "\tServerName ";
 218                  write fullHost;
 219                  write "\n\tSuexecUserGroup ";
 220                  write user;
 221                  write " ";
 222                  write group;
 223                  write "\n\tDocumentRoot ";
 224                  write docroot;
 225                  write "\n\tServerAdmin ";
 226                  write sadmin;
 227                  write "\n\tErrorLog ";
 228                  write Config.Apache.logDir;
 229                  write "/";
 230                  write vhostId;
 231                  write "/error.log\n\tCustomLog ";
 232                  write Config.Apache.logDir;
 233                  write "/";
 234                  write vhostId;
 235                  write "/access.log combined\n"
 236              end,
 237           fn () => (write "</VirtualHost>\n";
 238                     app TextIO.closeOut (!vhostFiles)))
 239
 240 val () = Env.container_one "location"
 241          ("prefix", Env.string)
 242          (fn prefix =>
 243              (write "\t<Location ";
 244               write prefix;
 245               write ">\n"),
 246           fn () => write "\t</Location>\n")
 247
 248 val () = Env.container_one "directory"
 249          ("directory", Env.string)
 250          (fn directory =>
 251              (write "\t<Directory ";
 252               write directory;
 253               write ">\n"),
 254           fn () => write "\t</Directory>\n")
 255
 256 fun checkRewrite () =
 257     if !rewriteEnabled then
 258         ()
 259     else
 260         (write "\tRewriteEngine on\n";
 261          rewriteEnabled := true)
 262
 263 val () = Env.action_three "localProxyRewrite"
 264          ("from", Env.string, "to", Env.string, "port", Env.int)
 265          (fn (from, to, port) =>
 266              (checkRewrite ();
 267               write "\tRewriteRule\t";
 268               write from;
 269               write "\thttp://localhost:";
 270               write (Int.toString port);
 271               write "/";
 272               write to;
 273               write " [P]\n"))
 274
 275 val () = Env.action_two "proxyPass"
 276          ("from", Env.string, "to", Env.string)
 277          (fn (from, to) =>
 278                  (write "\tProxyPass\t";
 279                   write from;
 280                   write "\t";
 281                   write to;
 282                   write "\n"))
 283
 284 val () = Env.action_two "proxyPassReverse"
 285          ("from", Env.string, "to", Env.string)
 286          (fn (from, to) =>
 287                  (write "\tProxyPassReverse\t";
 288                   write from;
 289                   write "\t";
 290                   write to;
 291                   write "\n"))
 292
 293 val () = Env.action_three "rewriteRule"
 294          ("from", Env.string, "to", Env.string, "flags", Env.list flag)
 295          (fn (from, to, flags) =>
 296              (checkRewrite ();
 297               write "\tRewriteRule\t";
 298               write from;
 299               write "\t";
 300               write to;
 301               case flags of
 302                   [] => ()
 303                 | flag::rest => (write " [";
 304                                  write flag;
 305                                  app (fn flag => (write ",";
 306                                                   write flag)) rest;
 307                                  write "]");
 308               write "\n"))
 309
 310 val () = Env.action_three "rewriteCond"
 311          ("test", Env.string, "pattern", Env.string, "flags", Env.list cond_flag)
 312          (fn (from, to, flags) =>
 313              (checkRewrite ();
 314               write "\tRewriteCond\t";
 315               write from;
 316               write "\t";
 317               write to;
 318               case flags of
 319                   [] => ()
 320                 | flag::rest => (write " [";
 321                                  write flag;
 322                                  app (fn flag => (write ",";
 323                                                   write flag)) rest;
 324                                  write "]");
 325               write "\n"))
 326
 327 val () = Env.action_one "rewriteLogLevel"
 328          ("level", Env.int)
 329          (fn level =>
 330              (checkRewrite ();
 331               write "\tRewriteLog ";
 332               write Config.Apache.logDir;
 333               write "/";
 334               write (!currentVhostId);
 335               write "/rewrite.log\n\tRewriteLogLevel ";
 336               write (Int.toString level);
 337               write "\n"))
 338
 339 val () = Env.action_two "alias"
 340          ("from", Env.string, "to", Env.string)
 341          (fn (from, to) =>
 342              (write "\tAlias\t";
 343               write from;
 344               write " ";
 345               write to;
 346               write "\n"))
 347
 348 val () = Env.action_two "scriptAlias"
 349          ("from", Env.string, "to", Env.string)
 350          (fn (from, to) =>
 351              (write "\tScriptAlias\t";
 352               write from;
 353               write " ";
 354               write to;
 355               write "\n"))
 356
 357 val () = Env.action_two "errorDocument"
 358          ("code", Env.string, "handler", Env.string)
 359          (fn (code, handler) =>
 360              (write "\tErrorDocument\t";
 361               write code;
 362               write " ";
 363               write handler;
 364               write "\n"))
 365
 366 val () = Env.action_one "options"
 367          ("options", Env.list apache_option)
 368          (fn opts =>
 369              case opts of
 370                  [] => ()
 371                | _ => (write "\tOptions";
 372                        app (fn opt => (write " "; write opt)) opts;
 373                        write "\n"))
 374
 375 val () = Env.action_one "set_options"
 376          ("options", Env.list apache_option)
 377          (fn opts =>
 378              case opts of
 379                  [] => ()
 380                | _ => (write "\tOptions";
 381                        app (fn opt => (write " +"; write opt)) opts;
 382                        write "\n"))
 383
 384 val () = Env.action_one "unset_options"
 385          ("options", Env.list apache_option)
 386          (fn opts =>
 387              case opts of
 388                  [] => ()
 389                | _ => (write "\tOptions";
 390                        app (fn opt => (write " -"; write opt)) opts;
 391                        write "\n"))
 392
 393 val () = Env.action_one "directoryIndex"
 394          ("filenames", Env.list Env.string)
 395          (fn opts =>
 396              (write "\tDirectoryIndex";
 397               app (fn opt => (write " "; write opt)) opts;
 398               write "\n"))
 399
 400 val () = Env.action_one "serverAlias"
 401          ("host", Env.string)
 402          (fn host =>
 403              (write "\tServerAlias ";
 404               write host;
 405               write "\n"))
 406
 407 val authType = fn (EVar "basic", _) => SOME "basic"
 408                 | (EVar "digest", _) => SOME "digest"
 409                 | _ => NONE
 410
 411 val () = Env.action_one "authType"
 412          ("type", authType)
 413          (fn ty =>
 414              (write "\tAuthType ";
 415               write ty;
 416               write "\n"))
 417
 418 val () = Env.action_one "authName"
 419          ("name", Env.string)
 420          (fn name =>
 421              (write "\tAuthName \"";
 422               write name;
 423               write "\"\n"))
 424
 425 val () = Env.action_one "authUserFile"
 426          ("file", Env.string)
 427          (fn name =>
 428              (write "\tAuthUserFile ";
 429               write name;
 430               write "\n"))
 431
 432 val () = Env.action_none "requireValidUser"
 433          (fn () => write "\tRequire valid-user\n")
 434
 435 val () = Env.action_one "requireUser"
 436          ("users", Env.list Env.string)
 437          (fn names =>
 438              case names of
 439                  [] => ()
 440                | _ => (write "\tRequire user";
 441                        app (fn name => (write " "; write name)) names;
 442                        write "\n"))
 443
 444 val () = Env.action_one "requireGroup"
 445          ("groups", Env.list Env.string)
 446          (fn names =>
 447              case names of
 448                  [] => ()
 449                | _ => (write "\tRequire group";
 450                        app (fn name => (write " "; write name)) names;
 451                        write "\n"))
 452
 453 val () = Env.action_none "orderAllowDeny"
 454          (fn () => write "\tOrder allow,deny\n")
 455
 456 val () = Env.action_none "orderDenyAllow"
 457          (fn () => write "\tOrder deny,allow\n")
 458
 459 val () = Env.action_none "allowFromAll"
 460          (fn () => write "\tAllow from all\n")
 461
 462 val () = Env.action_one "allowFrom"
 463          ("entries", Env.list Env.string)
 464          (fn names =>
 465              case names of
 466                  [] => ()
 467                | _ => (write "\tAllow from";
 468                        app (fn name => (write " "; write name)) names;
 469                        write "\n"))
 470
 471 val () = Env.action_none "denyFromAll"
 472          (fn () => write "\tDeny from all\n")
 473
 474 val () = Env.action_one "denyFrom"
 475          ("entries", Env.list Env.string)
 476          (fn names =>
 477              case names of
 478                  [] => ()
 479                | _ => (write "\tDeny from";
 480                        app (fn name => (write " "; write name)) names;
 481                        write "\n"))
 482
 483 val () = Env.action_none "satisfyAll"
 484          (fn () => write "\tSatisfy all\n")
 485
 486 val () = Env.action_none "satisfyAny"
 487          (fn () => write "\tSatisfy any\n")
 488
 489 val () = Env.action_one "forceType"
 490          ("type", Env.string)
 491          (fn ty => (write "\tForceType ";
 492                     write ty;
 493                     write "\n"))
 494
 495 val () = Env.action_none "forceTypeOff"
 496          (fn () => write "\tForceType None\n")
 497
 498 val () = Env.action_two "action"
 499          ("what", Env.string, "how", Env.string)
 500          (fn (what, how) => (write "\tAction ";
 501                              write what;
 502                              write " ";
 503                              write how;
 504                              write "\n"))
 505
 506 val () = Env.action_one "addDefaultCharset"
 507          ("charset", Env.string)
 508          (fn ty => (write "\tAddDefaultCharset ";
 509                     write ty;
 510                     write "\n"))
 511
 512 val () = Env.action_one "davSvn"
 513          ("path", Env.string)
 514          (fn path => (write "\tDAV svn\n\tSVNPath ";
 515                       write path;
 516                       write "\n"))
 517
 518 val () = Env.action_one "authzSvnAccessFile"
 519          ("path", Env.string)
 520          (fn path => (write "\tAuthzSVNAccessFile ";
 521                       write path;
 522                       write "\n"))
 523
 524 end