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