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