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 val () = Slave.registerFileHandler (fn fs =>
 245                                        let
 246                                            val spl = OS.Path.splitDirFile (#file fs)
 247                                        in
 248                                            if String.isSuffix ".vhost" (#file spl)
 249                                               orelse String.isSuffix ".vhost_ssl" (#file spl) then let
 250                                                    val realVhostFile = OS.Path.joinDirFile
 251                                                                            {dir = Config.Apache.confDir,
 252                                                                             file = #file spl}
 253
 254                                                    val user = findVhostUser (#file fs)
 255                                                    val oldUser = findVhostUser realVhostFile
 256                                                in
 257                                                    if (oldUser = NONE andalso #action fs <> Slave.Add)
 258                                                       orelse (user = NONE andalso #action fs <> Slave.Delete) then
 259                                                        print ("Can't find user in " ^ #file fs ^ " or " ^ realVhostFile ^ "!  Taking no action.\n")
 260                                                    else
 261                                                        let
 262                                                            fun realLogDir user =
 263                                                                let
 264                                                                    val realLogDir = Domain.homedirOf (valOf user)
 265                                                                    val realLogDir = OS.Path.joinDirFile
 266                                                                                         {dir = realLogDir,
 267                                                                                          file = "apache"}
 268                                                                    val realLogDir = OS.Path.joinDirFile
 269                                                                                         {dir = realLogDir,
 270                                                                                          file = "log"}
 271                                                                    val realLogDir = OS.Path.joinDirFile
 272                                                                                         {dir = realLogDir,
 273                                                                                          file = Slave.hostname ()}
 274                                                                    val {base, ...} = OS.Path.splitBaseExt (#file spl)
 275
 276                                                                    val realLogDir = OS.Path.concat (realLogDir, base)
 277                                                                in
 278                                                                    if String.isSuffix ".vhost_ssl" (#file spl) then
 279                                                                        realLogDir ^ ".ssl"
 280                                                                    else
 281                                                                        realLogDir
 282                                                                end
 283                                                        in
 284                                                            vhostsChanged := true;
 285                                                            case #action fs of
 286                                                                Slave.Delete =>
 287                                                                (if !logDeleted then
 288                                                                     ()
 289                                                                 else
 290                                                                     (ignore (OS.Process.system (down ()));
 291                                                                      logDeleted := true);
 292                                                                 ignore (OS.Process.system (Config.rm
 293                                                                                            ^ " -rf "
 294                                                                                            ^ realVhostFile));
 295                                                                 ignore (OS.Process.system (Config.rm
 296                                                                                            ^ " -rf "
 297                                                                                            ^ realLogDir oldUser)))
 298                                                              | Slave.Add =>
 299                                                                let
 300                                                                    val rld = realLogDir user
 301                                                                in
 302                                                                    ignore (OS.Process.system (Config.cp
 303                                                                                               ^ " "
 304                                                                                               ^ #file fs
 305                                                                                               ^ " "
 306                                                                                               ^ realVhostFile));
 307                                                                    if Posix.FileSys.access (rld, []) then
 308                                                                        ()
 309                                                                    else
 310                                                                        OS.FileSys.mkDir rld
 311                                                                end
 312
 313                                                              | _ =>
 314                                                                (ignore (OS.Process.system (Config.cp
 315                                                                                            ^ " "
 316                                                                                            ^ #file fs
 317                                                                                            ^ " "
 318                                                                                            ^ realVhostFile));
 319                                                                 if user <> oldUser then
 320                                                                     let
 321                                                                         val old = realLogDir oldUser
 322                                                                         val rld = realLogDir user
 323                                                                     in
 324                                                                         if !logDeleted then
 325                                                                             ()
 326                                                                         else
 327                                                                             (ignore (OS.Process.system (down ()));
 328                                                                              logDeleted := true);
 329                                                                         ignore (OS.Process.system (Config.rm
 330                                                                                                    ^ " -rf "
 331                                                                                                    ^ realLogDir oldUser));
 332                                                                         if Posix.FileSys.access (rld, []) then
 333                                                                             ()
 334                                                                         else
 335                                                                             OS.FileSys.mkDir rld
 336                                                                     end
 337                                                                 else
 338                                                                     ())
 339                                                        end
 340                                                end
 341                                            else
 342                                                ()
 343                                        end)
 344
 345 val () = Slave.registerPostHandler
 346          (fn () =>
 347              (if !vhostsChanged then
 348                   Slave.shellF ([if !logDeleted then undown () else reload ()],
 349                                 fn cl => "Error reloading Apache with " ^ cl)
 350               else
 351                   ()))
 352
 353 val vhostFiles : (string * TextIO.outstream) list ref = ref []
 354 fun write' s = app (fn (node, file) => TextIO.output (file, s node)) (!vhostFiles)
 355 fun write s = app (fn (_, file) => TextIO.output (file, s)) (!vhostFiles)
 356
 357 val rewriteEnabled = ref false
 358 val localRewriteEnabled = ref false
 359 val currentVhost = ref ""
 360 val currentVhostId = ref ""
 361
 362 val pre = ref (fn _ : {user : string, nodes : string list, id : string, hostname : string} => ())
 363 fun registerPre f =
 364     let
 365         val old = !pre
 366     in
 367         pre := (fn x => (old x; f x))
 368     end
 369
 370 val post = ref (fn () => ())
 371 fun registerPost f =
 372     let
 373         val old = !post
 374     in
 375         post := (fn () => (old (); f ()))
 376     end
 377
 378 val aliaser = ref (fn _ : string => ())
 379 fun registerAliaser f =
 380     let
 381         val old = !aliaser
 382     in
 383         aliaser := (fn x => (old x; f x))
 384     end
 385
 386 val () = Env.containerV_one "vhost"
 387          ("host", Env.string)
 388          (fn (env, host) =>
 389              let
 390                  val nodes = Env.env (Env.list Env.string) (env, "WebNodes")
 391
 392                  val ssl = Env.env ssl (env, "SSL")
 393                  val user = Env.env Env.string (env, "User")
 394                  val group = Env.env Env.string (env, "Group")
 395                  val docroot = Env.env Env.string (env, "DocumentRoot")
 396                  val sadmin = Env.env Env.string (env, "ServerAdmin")
 397                  val suexec = Env.env Env.bool (env, "SuExec")
 398
 399                  val fullHost = host ^ "." ^ Domain.currentDomain ()
 400                  val vhostId = fullHost ^ (if Option.isSome ssl then ".ssl" else "")
 401                  val confFile = fullHost ^ (if Option.isSome ssl then ".vhost_ssl" else ".vhost")
 402              in
 403                  currentVhost := fullHost;
 404                  currentVhostId := vhostId;
 405
 406                  rewriteEnabled := false;
 407                  localRewriteEnabled := false;
 408                  vhostFiles := map (fn node =>
 409                                        let
 410                                            val file = Domain.domainFile {node = node,
 411                                                                          name = confFile}
 412                                        in
 413                                            TextIO.output (file, "# Owner: ");
 414                                            TextIO.output (file, user);
 415                                            TextIO.output (file, "\n<VirtualHost ");
 416                                            TextIO.output (file, Domain.nodeIp node);
 417                                            TextIO.output (file, ":");
 418                                            TextIO.output (file, case ssl of
 419                                                                     SOME _ => "443"
 420                                                                   | NONE => "80");
 421                                            TextIO.output (file, ">\n");
 422                                            TextIO.output (file, "\tErrorLog ");
 423                                            TextIO.output (file, Domain.homedirOf user);
 424                                            TextIO.output (file, "/apache/log/");
 425                                            TextIO.output (file, node);
 426                                            TextIO.output (file, "/");
 427                                            TextIO.output (file, vhostId);
 428                                            TextIO.output (file, "/error.log\n\tCustomLog ");
 429                                            TextIO.output (file, Domain.homedirOf user);
 430                                            TextIO.output (file, "/apache/log/");
 431                                            TextIO.output (file, node);
 432                                            TextIO.output (file, "/");
 433                                            TextIO.output (file, vhostId);
 434                                            TextIO.output (file, "/access.log combined\n");
 435                                            TextIO.output (file, "\tServerName ");
 436                                            TextIO.output (file, fullHost);
 437                                            if suexec then
 438                                                if isVersion1 node then
 439                                                    (TextIO.output (file, "\n\tUser ");
 440                                                     TextIO.output (file, user);
 441                                                     TextIO.output (file, "\n\tGroup ");
 442                                                     TextIO.output (file, group))
 443                                                else
 444                                                    (TextIO.output (file, "\n\tSuexecUserGroup ");
 445                                                     TextIO.output (file, user);
 446                                                     TextIO.output (file, " ");
 447                                                     TextIO.output (file, group))
 448                                            else
 449                                                ();
 450                                            if isWaklog node then
 451                                                (TextIO.output (file, "\n\tWaklogProtected on\n\tWaklogPrincipal ");
 452                                                 TextIO.output (file, user);
 453                                                 TextIO.output (file, "/cgi@HCOOP.NET /etc/keytabs/cgi/");
 454                                                 TextIO.output (file, user))
 455                                            else
 456                                                ();
 457                                            (Domain.homedirOf user ^ "/apache/log/"
 458                                             ^ node ^ "/" ^ vhostId, file)
 459                                        end)
 460                                    nodes;
 461                  write "\n\tDocumentRoot ";
 462                  write docroot;
 463                  write "\n\tServerAdmin ";
 464                  write sadmin;
 465                  case ssl of
 466                      SOME cert =>
 467                      (write "\n\tSSLEngine on\n\tSSLCertificateFile ";
 468                       write cert)
 469                    | NONE => ();
 470                  write "\n";
 471                  !pre {user = user, nodes = nodes, id = vhostId, hostname = fullHost}
 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 "rewriteLogLevel"
 579          ("level", Env.int)
 580          (fn level =>
 581              (checkRewrite ();
 582               write "\tRewriteLog ";
 583               write' (fn x => x);
 584               write "/rewrite.log\n\tRewriteLogLevel ";
 585               write (Int.toString level);
 586               write "\n"))
 587
 588 val () = Env.action_two "alias"
 589          ("from", Env.string, "to", Env.string)
 590          (fn (from, to) =>
 591              (write "\tAlias\t";
 592               write from;
 593               write " ";
 594               write to;
 595               write "\n"))
 596
 597 val () = Env.action_two "scriptAlias"
 598          ("from", Env.string, "to", Env.string)
 599          (fn (from, to) =>
 600              (write "\tScriptAlias\t";
 601               write from;
 602               write " ";
 603               write to;
 604               write "\n"))
 605
 606 val () = Env.action_two "errorDocument"
 607          ("code", Env.string, "handler", Env.string)
 608          (fn (code, handler) =>
 609              (write "\tErrorDocument\t";
 610               write code;
 611               write " ";
 612               write handler;
 613               write "\n"))
 614
 615 val () = Env.action_one "options"
 616          ("options", Env.list apache_option)
 617          (fn opts =>
 618              case opts of
 619                  [] => ()
 620                | _ => (write "\tOptions";
 621                        app (fn opt => (write " "; write opt)) opts;
 622                        write "\n"))
 623
 624 val () = Env.action_one "set_options"
 625          ("options", Env.list apache_option)
 626          (fn opts =>
 627              case opts of
 628                  [] => ()
 629                | _ => (write "\tOptions";
 630                        app (fn opt => (write " +"; write opt)) opts;
 631                        write "\n"))
 632
 633 val () = Env.action_one "unset_options"
 634          ("options", Env.list apache_option)
 635          (fn opts =>
 636              case opts of
 637                  [] => ()
 638                | _ => (write "\tOptions";
 639                        app (fn opt => (write " -"; write opt)) opts;
 640                        write "\n"))
 641
 642 val () = Env.action_one "directoryIndex"
 643          ("filenames", Env.list Env.string)
 644          (fn opts =>
 645              (write "\tDirectoryIndex";
 646               app (fn opt => (write " "; write opt)) opts;
 647               write "\n"))
 648
 649 val () = Env.action_one "serverAlias"
 650          ("host", Env.string)
 651          (fn host =>
 652              (write "\tServerAlias ";
 653               write host;
 654               write "\n";
 655               !aliaser host))
 656
 657 val authType = fn (EVar "basic", _) => SOME "basic"
 658                 | (EVar "digest", _) => SOME "digest"
 659                 | _ => NONE
 660
 661 val () = Env.action_one "authType"
 662          ("type", authType)
 663          (fn ty =>
 664              (write "\tAuthType ";
 665               write ty;
 666               write "\n"))
 667
 668 val () = Env.action_one "authName"
 669          ("name", Env.string)
 670          (fn name =>
 671              (write "\tAuthName \"";
 672               write name;
 673               write "\"\n"))
 674
 675 val () = Env.action_one "authUserFile"
 676          ("file", Env.string)
 677          (fn name =>
 678              (write "\tAuthUserFile ";
 679               write name;
 680               write "\n"))
 681
 682 val () = Env.action_none "requireValidUser"
 683          (fn () => write "\tRequire valid-user\n")
 684
 685 val () = Env.action_one "requireUser"
 686          ("users", Env.list Env.string)
 687          (fn names =>
 688              case names of
 689                  [] => ()
 690                | _ => (write "\tRequire user";
 691                        app (fn name => (write " "; write name)) names;
 692                        write "\n"))
 693
 694 val () = Env.action_one "requireGroup"
 695          ("groups", Env.list Env.string)
 696          (fn names =>
 697              case names of
 698                  [] => ()
 699                | _ => (write "\tRequire group";
 700                        app (fn name => (write " "; write name)) names;
 701                        write "\n"))
 702
 703 val () = Env.action_none "orderAllowDeny"
 704          (fn () => write "\tOrder allow,deny\n")
 705
 706 val () = Env.action_none "orderDenyAllow"
 707          (fn () => write "\tOrder deny,allow\n")
 708
 709 val () = Env.action_none "allowFromAll"
 710          (fn () => write "\tAllow from all\n")
 711
 712 val () = Env.action_one "allowFrom"
 713          ("entries", Env.list Env.string)
 714          (fn names =>
 715              case names of
 716                  [] => ()
 717                | _ => (write "\tAllow from";
 718                        app (fn name => (write " "; write name)) names;
 719                        write "\n"))
 720
 721 val () = Env.action_none "denyFromAll"
 722          (fn () => write "\tDeny from all\n")
 723
 724 val () = Env.action_one "denyFrom"
 725          ("entries", Env.list Env.string)
 726          (fn names =>
 727              case names of
 728                  [] => ()
 729                | _ => (write "\tDeny from";
 730                        app (fn name => (write " "; write name)) names;
 731                        write "\n"))
 732
 733 val () = Env.action_none "satisfyAll"
 734          (fn () => write "\tSatisfy all\n")
 735
 736 val () = Env.action_none "satisfyAny"
 737          (fn () => write "\tSatisfy any\n")
 738
 739 val () = Env.action_one "forceType"
 740          ("type", Env.string)
 741          (fn ty => (write "\tForceType ";
 742                     write ty;
 743                     write "\n"))
 744
 745 val () = Env.action_none "forceTypeOff"
 746          (fn () => write "\tForceType None\n")
 747
 748 val () = Env.action_two "action"
 749          ("what", Env.string, "how", Env.string)
 750          (fn (what, how) => (write "\tAction ";
 751                              write what;
 752                              write " ";
 753                              write how;
 754                              write "\n"))
 755
 756 val () = Env.action_one "addDefaultCharset"
 757          ("charset", Env.string)
 758          (fn ty => (write "\tAddDefaultCharset ";
 759                     write ty;
 760                     write "\n"))
 761
 762 (*val () = Env.action_one "davSvn"
 763          ("path", Env.string)
 764          (fn path => (write "\tDAV svn\n\tSVNPath ";
 765                       write path;
 766                       write "\n"))
 767
 768 val () = Env.action_one "authzSvnAccessFile"
 769          ("path", Env.string)
 770          (fn path => (write "\tAuthzSVNAccessFile ";
 771                       write path;
 772                       write "\n"))*)
 773
 774 val () = Env.action_two "addDescription"
 775          ("description", Env.string, "patterns", Env.list Env.string)
 776          (fn (desc, pats) =>
 777              case pats of
 778                  [] => ()
 779                | _ => (write "\tAddDescription \"";
 780                        write (String.toString desc);
 781                        write "\"";
 782                        app (fn pat => (write " "; write pat)) pats;
 783                        write "\n"))
 784
 785 val () = Env.action_one "indexOptions"
 786          ("options", Env.list autoindex_option)
 787          (fn opts =>
 788              case opts of
 789                  [] => ()
 790                | _ => (write "\tIndexOptions";
 791                        app (fn (opt, arg) =>
 792                                (write " ";
 793                                 write opt;
 794                                 Option.app (fn arg =>
 795                                                (write "="; write arg)) arg)) opts;
 796                        write "\n"))
 797
 798 val () = Env.action_one "set_indexOptions"
 799          ("options", Env.list autoindex_option)
 800          (fn opts =>
 801              case opts of
 802                  [] => ()
 803                | _ => (write "\tIndexOptions";
 804                        app (fn (opt, arg) =>
 805                                (write " +";
 806                                 write opt;
 807                                 Option.app (fn arg =>
 808                                                (write "="; write arg)) arg)) opts;
 809                        write "\n"))
 810
 811 val () = Env.action_one "unset_indexOptions"
 812          ("options", Env.list autoindex_option)
 813          (fn opts =>
 814              case opts of
 815                  [] => ()
 816                | _ => (write "\tIndexOptions";
 817                        app (fn (opt, _) =>
 818                                (write " -";
 819                                 write opt)) opts;
 820                        write "\n"))
 821
 822 val () = Env.action_one "headerName"
 823          ("name", Env.string)
 824          (fn name => (write "\tHeaderName ";
 825                       write name;
 826                       write "\n"))
 827
 828 val () = Env.action_one "readmeName"
 829          ("name", Env.string)
 830          (fn name => (write "\tReadmeName ";
 831                       write name;
 832                       write "\n"))
 833
 834 val () = Domain.registerResetLocal (fn () =>
 835                                        ignore (OS.Process.system (Config.rm ^ " -rf /var/domtool/vhosts/*")))
 836
 837 end