src/plugins/apache.sml

   1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
   2  * Copyright (c) 2006-2007, 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 "web_node"
  26         Env.string
  27         (fn node =>
  28             List.exists (fn (x, _) => x = node) Config.Apache.webNodes_all
  29             orelse (Domain.hasPriv "www"
  30                     andalso List.exists (fn (x, _) => x = node) Config.Apache.webNodes_admin))
  31
  32 val _ = Env.registerFunction ("web_node_to_node",
  33                               fn [e] => SOME e
  34                                | _ => NONE)
  35
  36 val _ = Env.type_one "proxy_port"
  37         Env.int
  38         (fn n => n > 1024)
  39
  40 val _ = Env.type_one "proxy_target"
  41         Env.string
  42         (fn s =>
  43             let
  44                 fun default () = List.exists (fn s' => s = s') Config.Apache.proxyTargets
  45             in
  46                 case String.fields (fn ch => ch = #":") s of
  47                     ["http", "//localhost", rest] =>
  48                     (case String.fields (fn ch => ch = #"/") rest of
  49                          port :: _ =>
  50                          (case Int.fromString port of
  51                               NONE => default ()
  52                             | SOME n => n > 1024 orelse default ())
  53                        | _ => default ())
  54                   | _ => default ()
  55             end)
  56
  57 val _ = Env.type_one "rewrite_arg"
  58         Env.string
  59         (CharVector.all Char.isAlphaNum)
  60
  61 val _ = Env.type_one "suexec_flag"
  62         Env.bool
  63         (fn b => b orelse Domain.hasPriv "www")
  64
  65 fun validLocation s =
  66     size s > 0 andalso size s < 1000 andalso CharVector.all
  67                                                  (fn ch => Char.isAlphaNum ch
  68                                                            orelse ch = #"-"
  69                                                            orelse ch = #"_"
  70                                                            orelse ch = #"."
  71                                                            orelse ch = #"/") s
  72
  73 val _ = Env.type_one "location"
  74         Env.string
  75         validLocation
  76
  77 fun validCert s = Acl.query {user = Domain.getUser (),
  78                              class = "cert",
  79                              value = s}
  80
  81 val _ = Env.type_one "ssl_cert_path"
  82         Env.string
  83         validCert
  84
  85 fun ssl e = case e of
  86                 (EVar "no_ssl", _) => SOME NONE
  87               | (EApp ((EVar "use_cert", _), s), _) => Option.map SOME (Env.string s)
  88               | _ => NONE
  89
  90 val dl = ErrorMsg.dummyLoc
  91
  92 val defaults = [("WebNodes",
  93                  (TList (TBase "web_node", dl), dl),
  94                  (fn () => (EList (map (fn s => (EString s, dl)) Config.Apache.webNodes_default), dl))),
  95                 ("SSL",
  96                  (TBase "ssl", dl),
  97                  (fn () => (EVar "no_ssl", dl))),
  98                 ("User",
  99                  (TBase "your_user", dl),
 100                  (fn () => (EString (Domain.getUser ()), dl))),
 101                 ("Group",
 102                  (TBase "your_group", dl),
 103                  (fn () => (EString "nogroup", dl))),
 104                 ("DocumentRoot",
 105                  (TBase "your_path", dl),
 106                  (fn () => (EString (Domain.homedir () ^ "/" ^ Config.Apache.public_html), dl))),
 107                 ("ServerAdmin",
 108                  (TBase "email", dl),
 109                  (fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl))),
 110                 ("SuExec",
 111                  (TBase "suexec_flag", dl),
 112                  (fn () => (EVar "true", dl)))]
 113
 114 val () = app Defaults.registerDefault defaults
 115
 116 val redirect_code = fn (EVar "temp", _) => SOME "temp"
 117                      | (EVar "permanent", _) => SOME "permanent"
 118                      | (EVar "seeother", _) => SOME "seeother"
 119                      | (EVar "redir300", _) => SOME "300"
 120                      | (EVar "redir301", _) => SOME "301"
 121                      | (EVar "redir302", _) => SOME "302"
 122                      | (EVar "redir303", _) => SOME "303"
 123                      | (EVar "redir304", _) => SOME "304"
 124                      | (EVar "redir305", _) => SOME "305"
 125                      | (EVar "redir307", _) => SOME "307"
 126                      | _ => NONE
 127
 128 val flag = fn (EVar "redirect", _) => SOME "R"
 129             | (EVar "forbidden", _) => SOME "F"
 130             | (EVar "gone", _) => SOME "G"
 131             | (EVar "last", _) => SOME "L"
 132             | (EVar "chain", _) => SOME "C"
 133             | (EVar "nosubreq", _) => SOME "NS"
 134             | (EVar "nocase", _) => SOME "NC"
 135             | (EVar "qsappend", _) => SOME "QSA"
 136             | (EVar "noescape", _) => SOME "NE"
 137             | (EVar "passthrough", _) => SOME "PT"
 138             | (EApp ((EVar "mimeType", _), e), _) =>
 139               Option.map (fn s => "T=" ^ s) (Env.string e)
 140             | (EApp ((EVar "redirectWith", _), e), _) =>
 141               Option.map (fn s => "R=" ^ s) (redirect_code e)
 142             | (EApp ((EVar "skip", _), e), _) =>
 143               Option.map (fn n => "S=" ^ Int.toString n) (Env.int e)
 144             | (EApp ((EApp ((EVar "env", _), e1), _), e2), _) =>
 145               (case Env.string e1 of
 146                    NONE => NONE
 147                  | SOME s1 => Option.map (fn s2 => "E=" ^ s1 ^ ":" ^ s2)
 148                                          (Env.string e2))
 149
 150             | _ => NONE
 151
 152 val cond_flag = fn (EVar "cond_nocase", _) => SOME "NC"
 153             | (EVar "ornext", _) => SOME "OR"
 154             | _ => NONE
 155
 156 val apache_option = fn (EVar "execCGI", _) => SOME "ExecCGI"
 157                      | (EVar "includesNOEXEC", _) => SOME "IncludesNOEXEC"
 158                      | (EVar "indexes", _) => SOME "Indexes"
 159                      | _ => NONE
 160
 161 val autoindex_width = fn (EVar "autofit", _) => SOME "*"
 162                        | (EApp ((EVar "characters", _), n), _) =>
 163                          Option.map Int.toString (Env.int n)
 164                        | _ => NONE
 165
 166 val autoindex_option = fn (EApp ((EVar "descriptionWidth", _), w), _) =>
 167                           Option.map (fn w => ("DescriptionWidth", SOME w))
 168                           (autoindex_width w)
 169                         | (EVar "fancyIndexing", _) => SOME ("FancyIndexing", NONE)
 170                         | (EVar "foldersFirst", _) => SOME ("FoldersFirst", NONE)
 171                         | (EVar "htmlTable", _) => SOME ("HTMLTable", NONE)
 172                         | (EVar "iconsAreLinks", _) => SOME ("IconsAreLinks", NONE)
 173                         | (EApp ((EVar "iconHeight", _), n), _) =>
 174                           Option.map (fn w => ("IconHeight", SOME (Int.toString w)))
 175                                      (Env.int n)
 176                         | (EApp ((EVar "iconWidth", _), n), _) =>
 177                           Option.map (fn w => ("IconWidth", SOME (Int.toString w)))
 178                                      (Env.int n)
 179                         | (EVar "ignoreCase", _) => SOME ("IgnoreCase", NONE)
 180                         | (EVar "ignoreClient", _) => SOME ("IgnoreClient", NONE)
 181                         | (EApp ((EVar "nameWidth", _), w), _) =>
 182                           Option.map (fn w => ("NameWidth", SOME w))
 183                                      (autoindex_width w)
 184                         | (EVar "scanHtmlTitles", _) => SOME ("ScanHTMLTitles", NONE)
 185                         | (EVar "suppressColumnSorting", _) => SOME ("SuppressColumnSorting", NONE)
 186                         | (EVar "suppressDescription", _) => SOME ("SuppressDescription", NONE)
 187                         | (EVar "suppressHtmlPreamble", _) => SOME ("SuppressHTMLPreamble", NONE)
 188                         | (EVar "suppressIcon", _) => SOME ("SuppressIcon", NONE)
 189                         | (EVar "suppressLastModified", _) => SOME ("SuppressLastModified", NONE)
 190                         | (EVar "suppressRules", _) => SOME ("SuppressRules", NONE)
 191                         | (EVar "suppressSize", _) => SOME ("SuppressSize", NONE)
 192                         | (EVar "trackModified", _) => SOME ("TrackModified", NONE)
 193                         | (EVar "versionSort", _) => SOME ("VersionSort", NONE)
 194                         | (EVar "xhtml", _) => SOME ("XHTML", NONE)
 195
 196                         | _ => NONE
 197
 198 val vhostsChanged = ref false
 199 val logDeleted = ref false
 200
 201 val () = Slave.registerPreHandler
 202              (fn () => (vhostsChanged := false;
 203                         logDeleted := false))
 204
 205 fun findVhostUser fname =
 206     let
 207         val inf = TextIO.openIn fname
 208
 209         fun loop () =
 210             case TextIO.inputLine inf of
 211                 NONE => NONE
 212               | SOME line =>
 213                 if String.isPrefix "# Owner: " line then
 214                     case String.tokens Char.isSpace line of
 215                         [_, _, user] => SOME user
 216                       | _ => NONE
 217                 else
 218                     loop ()
 219     in
 220         loop ()
 221         before TextIO.closeIn inf
 222     end handle _ => NONE
 223
 224 val webNodes_full = Config.Apache.webNodes_all @ Config.Apache.webNodes_admin
 225
 226 fun isVersion1 node =
 227     List.exists (fn (n, {version = ConfigTypes.APACHE_1_3, ...}) => n = node
 228                   | _ => false) webNodes_full
 229
 230 fun imVersion1 () = isVersion1 (Slave.hostname ())
 231
 232 fun isWaklog node =
 233     List.exists (fn (n, {auth = ConfigTypes.MOD_WAKLOG, ...}) => n = node
 234                   | _ => false) webNodes_full
 235
 236 fun down () = if imVersion1 () then Config.Apache.down1 else Config.Apache.down
 237 fun undown () = if imVersion1 () then Config.Apache.undown1 else Config.Apache.undown
 238 fun reload () = if imVersion1 () then Config.Apache.reload1 else Config.Apache.reload
 239
 240 fun logDir {user, node, vhostId} =
 241     String.concat [Config.Apache.logDirOf (isVersion1 node) user,
 242                    "/",
 243                    node,
 244                    "/",
 245                    vhostId]
 246
 247 val () = Slave.registerFileHandler (fn fs =>
 248                                        let
 249                                            val spl = OS.Path.splitDirFile (#file fs)
 250                                        in
 251                                            if String.isSuffix ".vhost" (#file spl)
 252                                               orelse String.isSuffix ".vhost_ssl" (#file spl) then let
 253                                                    val realVhostFile = OS.Path.joinDirFile
 254                                                                            {dir = Config.Apache.confDir,
 255                                                                             file = #file spl}
 256
 257                                                    val user = findVhostUser (#file fs)
 258                                                    val oldUser = findVhostUser realVhostFile
 259                                                in
 260                                                    if (oldUser = NONE andalso #action fs <> Slave.Add)
 261                                                       orelse (user = NONE andalso #action fs <> Slave.Delete) then
 262                                                        print ("Can't find user in " ^ #file fs ^ " or " ^ realVhostFile ^ "!  Taking no action.\n")
 263                                                    else
 264                                                        let
 265                                                            val vhostId = if OS.Path.ext (#file spl) = SOME "vhost_ssl" then
 266                                                                              OS.Path.base (#file spl) ^ ".ssl"
 267                                                                          else
 268                                                                              OS.Path.base (#file spl)
 269
 270                                                            fun realLogDir user =
 271                                                                logDir {user = valOf user,
 272                                                                        node = Slave.hostname (),
 273                                                                        vhostId = vhostId}
 274                                                        in
 275                                                            vhostsChanged := true;
 276                                                            case #action fs of
 277                                                                Slave.Delete =>
 278                                                                (if !logDeleted then
 279                                                                     ()
 280                                                                 else
 281                                                                     (ignore (OS.Process.system (down ()));
 282                                                                      logDeleted := true);
 283                                                                 ignore (OS.Process.system (Config.rm
 284                                                                                            ^ " -rf "
 285                                                                                            ^ realVhostFile));
 286                                                                 ignore (OS.Process.system (Config.rm
 287                                                                                            ^ " -rf "
 288                                                                                            ^ realLogDir oldUser)))
 289                                                              | Slave.Add =>
 290                                                                let
 291                                                                    val rld = realLogDir user
 292                                                                in
 293                                                                    ignore (OS.Process.system (Config.cp
 294                                                                                               ^ " "
 295                                                                                               ^ #file fs
 296                                                                                               ^ " "
 297                                                                                               ^ realVhostFile));
 298                                                                    if Posix.FileSys.access (rld, []) then
 299                                                                        ()
 300                                                                    else
 301                                                                        Slave.mkDirAll rld
 302                                                                end
 303
 304                                                              | _ =>
 305                                                                (ignore (OS.Process.system (Config.cp
 306                                                                                            ^ " "
 307                                                                                            ^ #file fs
 308                                                                                            ^ " "
 309                                                                                            ^ realVhostFile));
 310                                                                 if user <> oldUser then
 311                                                                     let
 312                                                                         val old = realLogDir oldUser
 313                                                                         val rld = realLogDir user
 314                                                                     in
 315                                                                         if !logDeleted then
 316                                                                             ()
 317                                                                         else
 318                                                                             (ignore (OS.Process.system (down ()));
 319                                                                              logDeleted := true);
 320                                                                         ignore (OS.Process.system (Config.rm
 321                                                                                                    ^ " -rf "
 322                                                                                                    ^ realLogDir oldUser));
 323                                                                         if Posix.FileSys.access (rld, []) then
 324                                                                             ()
 325                                                                         else
 326                                                                             Slave.mkDirAll rld
 327                                                                     end
 328                                                                 else
 329                                                                     ())
 330                                                        end
 331                                                end
 332                                            else
 333                                                ()
 334                                        end)
 335
 336 val () = Slave.registerPostHandler
 337          (fn () =>
 338              (if !vhostsChanged then
 339                   Slave.shellF ([if !logDeleted then undown () else reload ()],
 340                                 fn cl => "Error reloading Apache with " ^ cl)
 341               else
 342                   ()))
 343
 344 val vhostFiles : (string * TextIO.outstream) list ref = ref []
 345 fun write' s = app (fn (node, file) => TextIO.output (file, s node)) (!vhostFiles)
 346 fun write s = app (fn (_, file) => TextIO.output (file, s)) (!vhostFiles)
 347
 348 val rewriteEnabled = ref false
 349 val localRewriteEnabled = ref false
 350 val currentVhost = ref ""
 351 val currentVhostId = ref ""
 352 val sslEnabled = ref false
 353
 354 val pre = ref (fn _ : {user : string, nodes : string list, id : string, hostname : string} => ())
 355 fun registerPre f =
 356     let
 357         val old = !pre
 358     in
 359         pre := (fn x => (old x; f x))
 360     end
 361
 362 val post = ref (fn () => ())
 363 fun registerPost f =
 364     let
 365         val old = !post
 366     in
 367         post := (fn () => (old (); f ()))
 368     end
 369
 370 val aliaser = ref (fn _ : string => ())
 371 fun registerAliaser f =
 372     let
 373         val old = !aliaser
 374     in
 375         aliaser := (fn x => (old x; f x))
 376     end
 377
 378 val () = Env.containerV_one "vhost"
 379          ("host", Env.string)
 380          (fn (env, host) =>
 381              let
 382                  val nodes = Env.env (Env.list Env.string) (env, "WebNodes")
 383
 384                  val ssl = Env.env ssl (env, "SSL")
 385                  val user = Env.env Env.string (env, "User")
 386                  val group = Env.env Env.string (env, "Group")
 387                  val docroot = Env.env Env.string (env, "DocumentRoot")
 388                  val sadmin = Env.env Env.string (env, "ServerAdmin")
 389                  val suexec = Env.env Env.bool (env, "SuExec")
 390
 391                  val fullHost = host ^ "." ^ Domain.currentDomain ()
 392                  val vhostId = fullHost ^ (if Option.isSome ssl then ".ssl" else "")
 393                  val confFile = fullHost ^ (if Option.isSome ssl then ".vhost_ssl" else ".vhost")
 394              in
 395                  currentVhost := fullHost;
 396                  currentVhostId := vhostId;
 397                  sslEnabled := Option.isSome ssl;
 398
 399                  rewriteEnabled := false;
 400                  localRewriteEnabled := false;
 401                  vhostFiles := map (fn node =>
 402                                        let
 403                                            val file = Domain.domainFile {node = node,
 404                                                                          name = confFile}
 405
 406                                            val ld = logDir {user = user, node = node, vhostId = vhostId}
 407                                        in
 408                                            TextIO.output (file, "# Owner: ");
 409                                            TextIO.output (file, user);
 410                                            TextIO.output (file, "\n<VirtualHost ");
 411                                            TextIO.output (file, Domain.nodeIp node);
 412                                            TextIO.output (file, ":");
 413                                            TextIO.output (file, case ssl of
 414                                                                     SOME _ => "443"
 415                                                                   | NONE => "80");
 416                                            TextIO.output (file, ">\n");
 417                                            TextIO.output (file, "\tErrorLog ");
 418                                            TextIO.output (file, ld);
 419                                            TextIO.output (file, "/error.log\n\tCustomLog ");
 420                                            TextIO.output (file, ld);
 421                                            TextIO.output (file, "/access.log combined\n");
 422                                            TextIO.output (file, "\tServerName ");
 423                                            TextIO.output (file, fullHost);
 424                                            app
 425                                                (fn dom => (TextIO.output (file, "\n\tServerAlias ");
 426                                                            TextIO.output (file, host);
 427                                                            TextIO.output (file, ".");
 428                                                            TextIO.output (file, dom)))
 429                                                (Domain.currentAliasDomains ());
 430
 431                                            if suexec then
 432                                                if isVersion1 node then
 433                                                    (TextIO.output (file, "\n\tUser ");
 434                                                     TextIO.output (file, user);
 435                                                     TextIO.output (file, "\n\tGroup ");
 436                                                     TextIO.output (file, group))
 437                                                else
 438                                                    (TextIO.output (file, "\n\tSuexecUserGroup ");
 439                                                     TextIO.output (file, user);
 440                                                     TextIO.output (file, " ");
 441                                                     TextIO.output (file, group))
 442                                            else
 443                                                ();
 444
 445                                            if isWaklog node then
 446                                                (TextIO.output (file, "\n\tWaklogEnabled on\n\tWaklogLocationPrincipal ");
 447                                                 TextIO.output (file, user);
 448                                                 TextIO.output (file, "/daemon@HCOOP.NET /etc/keytabs/user.daemon/");
 449                                                 TextIO.output (file, user))
 450                                            else
 451                                                ();
 452
 453                                            TextIO.output (file, "\n\tDAVLockDB /var/lock/apache2/dav/");
 454                                            TextIO.output (file, user);
 455                                            TextIO.output (file, "/DAVLock");
 456
 457                                            (ld, file)
 458                                        end)
 459                                    nodes;
 460                  write "\n\tDocumentRoot ";
 461                  write docroot;
 462                  write "\n\tServerAdmin ";
 463                  write sadmin;
 464                  case ssl of
 465                      SOME cert =>
 466                      (write "\n\tSSLEngine on\n\tSSLCertificateFile ";
 467                       write cert)
 468                    | NONE => ();
 469                  write "\n";
 470                  !pre {user = user, nodes = nodes, id = vhostId, hostname = fullHost};
 471                  app (fn dom => !aliaser (host ^ "." ^ dom)) (Domain.currentAliasDomains ())
 472              end,
 473           fn () => (!post ();
 474                     write "</VirtualHost>\n";
 475                     app (TextIO.closeOut o #2) (!vhostFiles)))
 476
 477 val inLocal = ref false
 478
 479 val () = Env.container_one "location"
 480          ("prefix", Env.string)
 481          (fn prefix =>
 482              (write "\t<Location ";
 483               write prefix;
 484               write ">\n";
 485               inLocal := true),
 486           fn () => (write "\t</Location>\n";
 487                     inLocal := false;
 488                     localRewriteEnabled := false))
 489
 490 val () = Env.container_one "directory"
 491          ("directory", Env.string)
 492          (fn directory =>
 493              (write "\t<Directory ";
 494               write directory;
 495               write ">\n";
 496               inLocal := true),
 497           fn () => (write "\t</Directory>\n";
 498                     inLocal := false;
 499                     localRewriteEnabled := false))
 500
 501 fun checkRewrite () =
 502     if !inLocal then
 503         if !rewriteEnabled orelse !localRewriteEnabled then
 504             ()
 505         else
 506             (write "\tRewriteEngine on\n";
 507              localRewriteEnabled := true)
 508     else if !rewriteEnabled then
 509         ()
 510     else
 511         (write "\tRewriteEngine on\n";
 512          rewriteEnabled := true)
 513
 514 val () = Env.action_three "localProxyRewrite"
 515          ("from", Env.string, "to", Env.string, "port", Env.int)
 516          (fn (from, to, port) =>
 517              (checkRewrite ();
 518               write "\tRewriteRule\t";
 519               write from;
 520               write "\thttp://localhost:";
 521               write (Int.toString port);
 522               write "/";
 523               write to;
 524               write " [P]\n"))
 525
 526 val () = Env.action_two "proxyPass"
 527          ("from", Env.string, "to", Env.string)
 528          (fn (from, to) =>
 529                  (write "\tProxyPass\t";
 530                   write from;
 531                   write "\t";
 532                   write to;
 533                   write "\n"))
 534
 535 val () = Env.action_two "proxyPassReverse"
 536          ("from", Env.string, "to", Env.string)
 537          (fn (from, to) =>
 538                  (write "\tProxyPassReverse\t";
 539                   write from;
 540                   write "\t";
 541                   write to;
 542                   write "\n"))
 543
 544 val () = Env.action_three "rewriteRule"
 545          ("from", Env.string, "to", Env.string, "flags", Env.list flag)
 546          (fn (from, to, flags) =>
 547              (checkRewrite ();
 548               write "\tRewriteRule\t";
 549               write from;
 550               write "\t";
 551               write to;
 552               case flags of
 553                   [] => ()
 554                 | flag::rest => (write " [";
 555                                  write flag;
 556                                  app (fn flag => (write ",";
 557                                                   write flag)) rest;
 558                                  write "]");
 559               write "\n"))
 560
 561 val () = Env.action_three "rewriteCond"
 562          ("test", Env.string, "pattern", Env.string, "flags", Env.list cond_flag)
 563          (fn (from, to, flags) =>
 564              (checkRewrite ();
 565               write "\tRewriteCond\t";
 566               write from;
 567               write "\t";
 568               write to;
 569               case flags of
 570                   [] => ()
 571                 | flag::rest => (write " [";
 572                                  write flag;
 573                                  app (fn flag => (write ",";
 574                                                   write flag)) rest;
 575                                  write "]");
 576               write "\n"))
 577
 578 val () = Env.action_one "rewriteBase"
 579          ("prefix", Env.string)
 580          (fn prefix =>
 581              (checkRewrite ();
 582               write "\tRewriteBase\t";
 583               write prefix;
 584               write "\n"))
 585
 586 val () = Env.action_one "rewriteLogLevel"
 587          ("level", Env.int)
 588          (fn level =>
 589              (checkRewrite ();
 590               write "\tRewriteLog ";
 591               write' (fn x => x);
 592               write "/rewrite.log\n\tRewriteLogLevel ";
 593               write (Int.toString level);
 594               write "\n"))
 595
 596 val () = Env.action_two "alias"
 597          ("from", Env.string, "to", Env.string)
 598          (fn (from, to) =>
 599              (write "\tAlias\t";
 600               write from;
 601               write " ";
 602               write to;
 603               write "\n"))
 604
 605 val () = Env.action_two "scriptAlias"
 606          ("from", Env.string, "to", Env.string)
 607          (fn (from, to) =>
 608              (write "\tScriptAlias\t";
 609               write from;
 610               write " ";
 611               write to;
 612               write "\n"))
 613
 614 val () = Env.action_two "errorDocument"
 615          ("code", Env.string, "handler", Env.string)
 616          (fn (code, handler) =>
 617              (write "\tErrorDocument\t";
 618               write code;
 619               write " ";
 620               write handler;
 621               write "\n"))
 622
 623 val () = Env.action_one "options"
 624          ("options", Env.list apache_option)
 625          (fn opts =>
 626              case opts of
 627                  [] => ()
 628                | _ => (write "\tOptions";
 629                        app (fn opt => (write " "; write opt)) opts;
 630                        write "\n"))
 631
 632 val () = Env.action_one "set_options"
 633          ("options", Env.list apache_option)
 634          (fn opts =>
 635              case opts of
 636                  [] => ()
 637                | _ => (write "\tOptions";
 638                        app (fn opt => (write " +"; write opt)) opts;
 639                        write "\n"))
 640
 641 val () = Env.action_one "unset_options"
 642          ("options", Env.list apache_option)
 643          (fn opts =>
 644              case opts of
 645                  [] => ()
 646                | _ => (write "\tOptions";
 647                        app (fn opt => (write " -"; write opt)) opts;
 648                        write "\n"))
 649
 650 val () = Env.action_one "directoryIndex"
 651          ("filenames", Env.list Env.string)
 652          (fn opts =>
 653              (write "\tDirectoryIndex";
 654               app (fn opt => (write " "; write opt)) opts;
 655               write "\n"))
 656
 657 val () = Env.action_one "serverAliasHost"
 658          ("host", Env.string)
 659          (fn host =>
 660              (write "\tServerAlias ";
 661               write host;
 662               write "\n";
 663               !aliaser host))
 664
 665 val () = Env.action_one "serverAlias"
 666          ("host", Env.string)
 667          (fn host =>
 668              (app
 669                   (fn dom =>
 670                       let
 671                           val full = host ^ "." ^ dom
 672                       in
 673                           write "\tServerAlias ";
 674                           write full;
 675                           write "\n";
 676                           !aliaser full
 677                       end)
 678                   (Domain.currentDomains ())))
 679
 680 val () = Env.action_none "serverAliasDefault"
 681          (fn () =>
 682              (app
 683                   (fn dom =>
 684                           (write "\tServerAlias ";
 685                            write dom;
 686                            write "\n";
 687                            !aliaser dom))
 688                   (Domain.currentDomains ())))
 689
 690 val authType = fn (EVar "basic", _) => SOME "basic"
 691                 | (EVar "digest", _) => SOME "digest"
 692                 | (EVar "kerberos", _) => SOME "kerberos"
 693                 | _ => NONE
 694
 695 fun allowAuthType "kerberos" = !sslEnabled
 696   | allowAuthType _ = true
 697
 698 val () = Env.action_one "authType"
 699          ("type", authType)
 700          (fn ty =>
 701              if allowAuthType ty then
 702                  (write "\tAuthType ";
 703                   write ty;
 704                   write "\n";
 705                   case ty of
 706                       "kerberos" =>
 707                       write "\tKrbMethodNegotiate off\n\tKrbMethodK5Passwd on\n\tKrbVerifyKDC off\n\tKrbAuthRealms HCOOP.NET\n\tKrbSaveCredentials on\n"
 708                     | _ => ())
 709              else
 710                  print "WARNING: Skipped Kerberos authType because this isn't an SSL vhost.\n")
 711
 712 val () = Env.action_one "authName"
 713          ("name", Env.string)
 714          (fn name =>
 715              (write "\tAuthName \"";
 716               write name;
 717               write "\"\n"))
 718
 719 val () = Env.action_one "authUserFile"
 720          ("file", Env.string)
 721          (fn name =>
 722              (write "\tAuthUserFile ";
 723               write name;
 724               write "\n"))
 725
 726 val () = Env.action_none "requireValidUser"
 727          (fn () => write "\tRequire valid-user\n")
 728
 729 val () = Env.action_one "requireUser"
 730          ("users", Env.list Env.string)
 731          (fn names =>
 732              case names of
 733                  [] => ()
 734                | _ => (write "\tRequire user";
 735                        app (fn name => (write " "; write name)) names;
 736                        write "\n"))
 737
 738 val () = Env.action_one "requireGroup"
 739          ("groups", Env.list Env.string)
 740          (fn names =>
 741              case names of
 742                  [] => ()
 743                | _ => (write "\tRequire group";
 744                        app (fn name => (write " "; write name)) names;
 745                        write "\n"))
 746
 747 val () = Env.action_none "orderAllowDeny"
 748          (fn () => write "\tOrder allow,deny\n")
 749
 750 val () = Env.action_none "orderDenyAllow"
 751          (fn () => write "\tOrder deny,allow\n")
 752
 753 val () = Env.action_none "allowFromAll"
 754          (fn () => write "\tAllow from all\n")
 755
 756 val () = Env.action_one "allowFrom"
 757          ("entries", Env.list Env.string)
 758          (fn names =>
 759              case names of
 760                  [] => ()
 761                | _ => (write "\tAllow from";
 762                        app (fn name => (write " "; write name)) names;
 763                        write "\n"))
 764
 765 val () = Env.action_none "denyFromAll"
 766          (fn () => write "\tDeny from all\n")
 767
 768 val () = Env.action_one "denyFrom"
 769          ("entries", Env.list Env.string)
 770          (fn names =>
 771              case names of
 772                  [] => ()
 773                | _ => (write "\tDeny from";
 774                        app (fn name => (write " "; write name)) names;
 775                        write "\n"))
 776
 777 val () = Env.action_none "satisfyAll"
 778          (fn () => write "\tSatisfy all\n")
 779
 780 val () = Env.action_none "satisfyAny"
 781          (fn () => write "\tSatisfy any\n")
 782
 783 val () = Env.action_one "forceType"
 784          ("type", Env.string)
 785          (fn ty => (write "\tForceType ";
 786                     write ty;
 787                     write "\n"))
 788
 789 val () = Env.action_none "forceTypeOff"
 790          (fn () => write "\tForceType None\n")
 791
 792 val () = Env.action_two "action"
 793          ("what", Env.string, "how", Env.string)
 794          (fn (what, how) => (write "\tAction ";
 795                              write what;
 796                              write " ";
 797                              write how;
 798                              write "\n"))
 799
 800 val () = Env.action_one "addDefaultCharset"
 801          ("charset", Env.string)
 802          (fn ty => (write "\tAddDefaultCharset ";
 803                     write ty;
 804                     write "\n"))
 805
 806 (*val () = Env.action_one "davSvn"
 807          ("path", Env.string)
 808          (fn path => (write "\tDAV svn\n\tSVNPath ";
 809                       write path;
 810                       write "\n"))
 811
 812 val () = Env.action_one "authzSvnAccessFile"
 813          ("path", Env.string)
 814          (fn path => (write "\tAuthzSVNAccessFile ";
 815                       write path;
 816                       write "\n"))*)
 817
 818 val () = Env.action_none "davFilesystem"
 819          (fn path => write "\tDAV filesystem\n")
 820
 821 val () = Env.action_two "addDescription"
 822          ("description", Env.string, "patterns", Env.list Env.string)
 823          (fn (desc, pats) =>
 824              case pats of
 825                  [] => ()
 826                | _ => (write "\tAddDescription \"";
 827                        write (String.toString desc);
 828                        write "\"";
 829                        app (fn pat => (write " "; write pat)) pats;
 830                        write "\n"))
 831
 832 val () = Env.action_one "indexOptions"
 833          ("options", Env.list autoindex_option)
 834          (fn opts =>
 835              case opts of
 836                  [] => ()
 837                | _ => (write "\tIndexOptions";
 838                        app (fn (opt, arg) =>
 839                                (write " ";
 840                                 write opt;
 841                                 Option.app (fn arg =>
 842                                                (write "="; write arg)) arg)) opts;
 843                        write "\n"))
 844
 845 val () = Env.action_one "set_indexOptions"
 846          ("options", Env.list autoindex_option)
 847          (fn opts =>
 848              case opts of
 849                  [] => ()
 850                | _ => (write "\tIndexOptions";
 851                        app (fn (opt, arg) =>
 852                                (write " +";
 853                                 write opt;
 854                                 Option.app (fn arg =>
 855                                                (write "="; write arg)) arg)) opts;
 856                        write "\n"))
 857
 858 val () = Env.action_one "unset_indexOptions"
 859          ("options", Env.list autoindex_option)
 860          (fn opts =>
 861              case opts of
 862                  [] => ()
 863                | _ => (write "\tIndexOptions";
 864                        app (fn (opt, _) =>
 865                                (write " -";
 866                                 write opt)) opts;
 867                        write "\n"))
 868
 869 val () = Env.action_one "headerName"
 870          ("name", Env.string)
 871          (fn name => (write "\tHeaderName ";
 872                       write name;
 873                       write "\n"))
 874
 875 val () = Env.action_one "readmeName"
 876          ("name", Env.string)
 877          (fn name => (write "\tReadmeName ";
 878                       write name;
 879                       write "\n"))
 880
 881 val () = Env.action_two "setEnv"
 882          ("key", Env.string, "value", Env.string)
 883          (fn (key, value) => (write "\tSetEnv \"";
 884                               write key;
 885                               write "\" \"";
 886                               write (String.translate (fn #"\"" => "\\\""
 887                                                         | ch => str ch) value);
 888                               write "\"\n"))
 889
 890 val () = Domain.registerResetLocal (fn () =>
 891                                        ignore (OS.Process.system (Config.rm ^ " -rf /var/domtool/vhosts/*")))
 892
 893 val () = Domain.registerDescriber (Domain.considerAll
 894                                    [Domain.Extension {extension = "vhost",
 895                                                       heading = fn host => "Web vhost " ^ host},
 896                                     Domain.Extension {extension = "vhost_ssl",
 897                                                       heading = fn host => "SSL web vhost " ^ host}])
 898
 899 end