src/domain.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 (* Domain-related primitive actions *)
  20
  21 structure Domain :> DOMAIN = struct
  22
  23 open MsgTypes
  24
  25 structure SM = DataStructures.StringMap
  26 structure SS = DataStructures.StringSet
  27
  28 val ssl_context = ref (NONE : OpenSSL.context option)
  29 fun set_context ctx = ssl_context := SOME ctx
  30 fun get_context () = valOf (!ssl_context)
  31
  32 val nodes = map #1 Config.nodeIps
  33 val nodeMap = foldl (fn ((node, ip), mp) => SM.insert (mp, node, ip))
  34                     SM.empty Config.nodeIps
  35 fun nodeIp node = valOf (SM.find (nodeMap, node))
  36
  37 val usr = ref ""
  38 fun getUser () = !usr
  39 val fakePrivs = ref false
  40 val isClient = ref false
  41
  42 val your_doms = ref SS.empty
  43 fun your_domains () = !your_doms
  44
  45 val your_usrs = ref SS.empty
  46 fun your_users () = !your_usrs
  47
  48 val your_grps = ref SS.empty
  49 fun your_groups () = !your_grps
  50
  51 val your_pths = ref SS.empty
  52 fun your_paths () = !your_pths
  53
  54 val your_ipss = ref SS.empty
  55 fun your_ips () = !your_ipss
  56
  57 val world_readable = SS.addList (SS.empty, Config.worldReadable)
  58 val readable_pths = ref world_readable
  59 fun readable_paths () = !readable_pths
  60
  61 fun setUser user =
  62     let
  63         val () = usr := user
  64
  65         val your_paths = Acl.class {user = getUser (),
  66                                     class = "path"}
  67     in
  68         fakePrivs := false;
  69         your_doms := Acl.class {user = getUser (),
  70                                 class = "domain"};
  71         your_usrs := Acl.class {user = getUser (),
  72                                 class = "user"};
  73         your_grps := SS.add (Acl.class {user = getUser (),
  74                                         class = "group"},
  75                              "nogroup");
  76         your_pths := your_paths;
  77         readable_pths := SS.union (your_paths, world_readable);
  78         your_ipss := Acl.class {user = getUser (),
  79                                 class = "ip"}
  80     end
  81
  82 fun declareClient () = isClient := true
  83 fun fakePrivileges () = if !isClient then
  84                             fakePrivs := true
  85                         else
  86                             raise Fail "Tried to fake privileges as non-client"
  87
  88 fun validIp s =
  89     case map Int.fromString (String.fields (fn ch => ch = #".") s) of
  90         [SOME n1, SOME n2, SOME n3, SOME n4] =>
  91         n1 >= 0 andalso n1 < 256 andalso n2 >= 0 andalso n2 < 256 andalso n3 >= 0 andalso n3 < 256 andalso n4 >= 0 andalso n4 < 256
  92       | _ => false
  93
  94 fun isHexDigit ch = Char.isDigit ch orelse (ord ch >= ord #"a" andalso ord ch <= ord #"f")
  95
  96 fun validIpv6 s =
  97     let
  98         val fields = String.fields (fn ch => ch = #":") s
  99
 100         val empties = foldl (fn ("", n) => n + 1
 101                               | (_, n) => n) 0 fields
 102
 103         fun noIpv4 maxLen =
 104             length fields >= 2
 105             andalso length fields <= maxLen
 106             andalso empties <= 1
 107             andalso List.all (fn "" => true
 108                                | s => size s <= 4
 109                                       andalso CharVector.all isHexDigit s) fields
 110
 111         fun hasIpv4 () =
 112             length fields > 0
 113             andalso
 114             let
 115                 val maybeIpv4 = List.last fields
 116                 val theRest = List.take (fields, length fields - 1)
 117             in
 118                 validIp maybeIpv4 andalso noIpv4 6
 119             end
 120     in
 121         noIpv4 8 orelse hasIpv4 ()
 122     end
 123
 124 fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
 125
 126 fun validHost s =
 127     size s > 0 andalso size s < 50
 128     andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s
 129
 130 fun validDomain s =
 131     size s > 0 andalso size s < 200
 132     andalso List.all validHost (String.fields (fn ch => ch = #".") s)
 133
 134 fun validNode s = List.exists (fn s' => s = s') nodes
 135
 136 fun yourDomain s = !fakePrivs orelse SS.member (your_domains (), s)
 137 fun yourUser s = !fakePrivs orelse SS.member (your_users (), s)
 138 fun yourGroup s = !fakePrivs orelse SS.member (your_groups (), s)
 139
 140 fun checkPath paths path =
 141     !fakePrivs orelse
 142     (List.all (fn s => s <> "..") (String.fields (fn ch => ch = #"/") path)
 143      andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"/"
 144                                       orelse ch = #"-" orelse ch = #"_") path
 145      andalso SS.exists (fn s' => path = s' orelse String.isPrefix (s' ^ "/") path) (paths ()))
 146 val yourPath = checkPath your_paths
 147 val readablePath = checkPath readable_paths
 148
 149 fun yourIp s = !fakePrivs orelse SS.member (your_ips (), s)
 150
 151 fun yourDomainHost s =
 152     !fakePrivs
 153     orelse yourDomain s
 154     orelse let
 155         val (pref, suf) = Substring.splitl (fn ch => ch <> #".") (Substring.full s)
 156     in
 157         Substring.size suf > 0
 158         andalso validHost (Substring.string pref)
 159         andalso yourDomain (Substring.string
 160                                 (Substring.slice (suf, 1, NONE)))
 161     end
 162
 163 val yourDomain = yourDomainHost
 164
 165 fun validUser s = size s > 0 andalso size s < 20
 166                   andalso CharVector.all Char.isAlphaNum s
 167
 168 fun validEmailUser s =
 169     size s > 0 andalso size s < 50
 170     andalso CharVector.all (fn ch => Char.isAlphaNum ch
 171                                      orelse ch = #"."
 172                                      orelse ch = #"_"
 173                                      orelse ch = #"-"
 174                                      orelse ch = #"+") s
 175
 176 val validGroup = validUser
 177
 178 val _ = Env.type_one "no_spaces"
 179                      Env.string
 180                      (CharVector.all (fn ch => Char.isPrint ch andalso not (Char.isSpace ch)
 181                                                andalso ch <> #"\"" andalso ch <> #"'"))
 182 val _ = Env.type_one "no_newlines"
 183                      Env.string
 184                      (CharVector.all (fn ch => Char.isPrint ch andalso ch <> #"\n" andalso ch <> #"\r"
 185                                                andalso ch <> #"\""))
 186
 187 val _ = Env.type_one "ip"
 188         Env.string
 189         validIp
 190
 191 val _ = Env.type_one "ipv6"
 192         Env.string
 193         validIpv6
 194
 195 val _ = Env.type_one "host"
 196         Env.string
 197         validHost
 198
 199 val _ = Env.type_one "domain"
 200         Env.string
 201         validDomain
 202
 203 val _ = Env.type_one "your_domain"
 204         Env.string
 205         yourDomain
 206
 207 val _ = Env.type_one "your_domain_host"
 208         Env.string
 209         yourDomainHost
 210
 211 val _ = Env.type_one "user"
 212         Env.string
 213         validUser
 214
 215 val _ = Env.type_one "group"
 216         Env.string
 217         validGroup
 218
 219 val _ = Env.type_one "your_user"
 220         Env.string
 221         yourUser
 222
 223 val _ = Env.type_one "your_group"
 224         Env.string
 225         yourGroup
 226
 227 val _ = Env.type_one "your_path"
 228         Env.string
 229         yourPath
 230
 231 val _ = Env.type_one "readable_path"
 232         Env.string
 233         readablePath
 234
 235 val _ = Env.type_one "your_ip"
 236         Env.string
 237         yourIp
 238
 239 val _ = Env.type_one "node"
 240         Env.string
 241         validNode
 242
 243 val _ = Env.type_one "mime_type"
 244         Env.string
 245         (CharVector.exists (fn ch => ch = #"/"))
 246
 247 val _ = Env.registerFunction ("your_ip_to_ip",
 248                               fn [e] => SOME e
 249                                | _ => NONE)
 250
 251 val _ = Env.registerFunction ("dns_node_to_node",
 252                               fn [e] => SOME e
 253                                | _ => NONE)
 254
 255 val _ = Env.registerFunction ("mail_node_to_node",
 256                               fn [e] => SOME e
 257                                | _ => NONE)
 258
 259
 260 open Ast
 261
 262 val dl = ErrorMsg.dummyLoc
 263
 264 val _ = Env.registerFunction ("end_in_slash",
 265                               fn [(EString "", _)] => SOME (EString "/", dl)
 266                                | [(EString s, _)] =>
 267                                  SOME (EString (if String.sub (s, size s - 1) = #"/" then
 268                                                     s
 269                                                 else
 270                                                     s ^ "/"), dl)
 271                                | _ => NONE)
 272
 273
 274 val _ = Env.registerFunction ("you",
 275                               fn [] => SOME (EString (getUser ()), dl)
 276                               | _ => NONE)
 277
 278 val _  = Env.registerFunction ("defaultMailbox",
 279                                fn [] => SOME (EString (getUser ()), dl)
 280                                | _ => NONE)
 281
 282 val _  = Env.registerFunction ("defaultMailUser",
 283                                fn [] => SOME (EString (getUser ()), dl)
 284                                | _ => NONE)
 285
 286
 287 type soa = {ns : string,
 288             serial : int option,
 289             ref : int,
 290             ret : int,
 291             exp : int,
 292             min : int}
 293
 294 val serial = fn (EVar "serialAuto", _) => SOME NONE
 295               | (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
 296               | _ => NONE
 297
 298 val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
 299                                                      ((EVar "soa", _), ns), _),
 300                                                 sl), _),
 301                                          rf), _),
 302                                   ret), _),
 303                            exp), _),
 304                     min), _) =>
 305              (case (Env.string ns, serial sl, Env.int rf,
 306                     Env.int ret, Env.int exp, Env.int min) of
 307                   (SOME ns, SOME sl, SOME rf,
 308                    SOME ret, SOME exp, SOME min) =>
 309                   SOME {ns = ns,
 310                         serial = sl,
 311                         ref = rf,
 312                         ret = ret,
 313                         exp = exp,
 314                         min = min}
 315                 | _ => NONE)
 316            | _ => NONE
 317
 318 datatype master =
 319          ExternalMaster of string
 320        | InternalMaster of string
 321
 322 val ip = Env.string
 323
 324 val _ = Env.registerFunction ("ip_of_node",
 325                               fn [(EString node, _)] => SOME (EString (nodeIp node), dl)
 326                                | _ => NONE)
 327
 328 val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (ip e)
 329               | (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (Env.string e)
 330               | _ => NONE
 331
 332 datatype dnsKind =
 333          UseDns of {soa : soa,
 334                     master : master,
 335                     slaves : string list}
 336        | NoDns
 337
 338 val dnsKind = fn (EApp ((EApp ((EApp
 339                                     ((EVar "useDns", _), sa), _),
 340                                mstr), _),
 341                         slaves), _) =>
 342                  (case (soa sa, master mstr, Env.list Env.string slaves) of
 343                       (SOME sa, SOME mstr, SOME slaves) =>
 344                       SOME (UseDns {soa = sa,
 345                                     master = mstr,
 346                                     slaves = slaves})
 347                     | _ => NONE)
 348                | (EVar "noDns", _) => SOME NoDns
 349                | _ => NONE
 350
 351 val befores = ref (fn (_ : string) => ())
 352 val afters = ref (fn (_ : string) => ())
 353
 354 fun registerBefore f =
 355     let
 356         val old = !befores
 357     in
 358         befores := (fn x => (old x; f x))
 359     end
 360
 361 fun registerAfter f =
 362     let
 363         val old = !afters
 364     in
 365         afters := (fn x => (old x; f x))
 366     end
 367
 368 val globals = ref (fn () => ())
 369 val locals = ref (fn () => ())
 370
 371 fun registerResetGlobal f =
 372     let
 373         val old = !globals
 374     in
 375         globals := (fn x => (old x; f x))
 376     end
 377
 378 fun registerResetLocal f =
 379     let
 380         val old = !locals
 381     in
 382         locals := (fn x => (old x; f x))
 383     end
 384
 385 fun resetGlobal () = (!globals ();
 386                       ignore (OS.Process.system (Config.rm ^ " -rf " ^ Config.resultRoot ^ "/*")))
 387 fun resetLocal () = !locals ()
 388
 389 val current = ref ""
 390 val currentPath = ref (fn (_ : string) => "")
 391 val currentPathAli = ref (fn (_ : string, _ : string) => "")
 392
 393 val scratch = ref ""
 394
 395 fun currentDomain () = !current
 396
 397 val currentsAli = ref ([] : string list)
 398
 399 fun currentAliasDomains () = !currentsAli
 400 fun currentDomains () = currentDomain () :: currentAliasDomains ()
 401
 402 fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*)
 403                                TextIO.openOut (!currentPath node ^ name))
 404
 405 type files = {write : string -> unit,
 406               writeDom : unit -> unit,
 407               close : unit -> unit}
 408
 409 fun domainsFile {node, name} =
 410     let
 411         val doms = currentDomains ()
 412         val files = map (fn dom => (dom, TextIO.openOut (!currentPathAli (dom, node) ^ name))) doms
 413     in
 414         {write = fn s => app (fn (_, outf) => TextIO.output (outf, s)) files,
 415          writeDom = fn () => app (fn (dom, outf) => TextIO.output (outf, dom)) files,
 416          close = fn () => app (fn (_, outf) => TextIO.closeOut outf) files}
 417     end
 418
 419 fun getPath domain =
 420     let
 421         val toks = String.fields (fn ch => ch = #".") domain
 422
 423         val elems = foldr (fn (piece, elems) =>
 424                               let
 425                                   val elems = piece :: elems
 426
 427                                   fun doNode node =
 428                                       let
 429                                           val path = String.concatWith "/"
 430                                                                        (Config.resultRoot :: node :: rev elems)
 431                                           val tmpPath = String.concatWith "/"
 432                                                                           (Config.tmpDir :: node :: rev elems)
 433                                       in
 434                                           (if Posix.FileSys.ST.isDir
 435                                                   (Posix.FileSys.stat path) then
 436                                                ()
 437                                            else
 438                                                (OS.FileSys.remove path;
 439                                                 OS.FileSys.mkDir path))
 440                                           handle OS.SysErr _ => OS.FileSys.mkDir path;
 441
 442                                           (if Posix.FileSys.ST.isDir
 443                                                   (Posix.FileSys.stat tmpPath) then
 444                                                ()
 445                                            else
 446                                                (OS.FileSys.remove tmpPath;
 447                                                 OS.FileSys.mkDir tmpPath))
 448                                           handle OS.SysErr _ => OS.FileSys.mkDir tmpPath
 449                                       end
 450                               in
 451                                   app doNode nodes;
 452                                   elems
 453                               end) [] toks
 454     in
 455         fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
 456     end
 457
 458 datatype file_action' =
 459          Add' of {src : string, dst : string}
 460        | Delete' of string
 461        | Modify' of {src : string, dst : string}
 462
 463 fun findDiffs (prefixes, site, dom, acts) =
 464     let
 465         val gp = getPath dom
 466         val realPath = gp (Config.resultRoot, site)
 467         val tmpPath = gp (Config.tmpDir, site)
 468
 469         (*val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n")*)
 470
 471         val dir = Posix.FileSys.opendir realPath
 472
 473         fun loopReal acts =
 474             case Posix.FileSys.readdir dir of
 475                 NONE => (Posix.FileSys.closedir dir;
 476                          acts)
 477               | SOME fname =>
 478                 let
 479                     val real = OS.Path.joinDirFile {dir = realPath,
 480                                                     file = fname}
 481                     val tmp = OS.Path.joinDirFile {dir = tmpPath,
 482                                                    file = fname}
 483                 in
 484                     if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
 485                         loopReal acts
 486                     else if Posix.FileSys.access (tmp, []) then
 487                         if Slave.shell [Config.diff, " ", real, " ",  tmp] then
 488                             loopReal acts
 489                         else
 490                             loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
 491                     else if List.exists (fn prefix => String.isPrefix prefix real) prefixes then
 492                         loopReal ((site, dom, realPath, Delete' real) :: acts)
 493                     else
 494                         loopReal acts
 495                 end
 496
 497         val acts = loopReal acts
 498
 499         val dir = Posix.FileSys.opendir tmpPath
 500
 501         fun loopTmp acts =
 502             case Posix.FileSys.readdir dir of
 503                 NONE => (Posix.FileSys.closedir dir;
 504                          acts)
 505               | SOME fname =>
 506                 let
 507                     val real = OS.Path.joinDirFile {dir = realPath,
 508                                                     file = fname}
 509                     val tmp = OS.Path.joinDirFile {dir = tmpPath,
 510                                                    file = fname}
 511                 in
 512                     if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
 513                         loopTmp acts
 514                     else if Posix.FileSys.access (real, []) then
 515                         loopTmp acts
 516                     else
 517                         loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
 518                 end
 519
 520         val acts = loopTmp acts
 521     in
 522         acts
 523     end
 524
 525 fun findAllDiffs prefixes =
 526     let
 527         val dir = Posix.FileSys.opendir Config.tmpDir
 528         val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1
 529
 530         fun exploreSites diffs =
 531             case Posix.FileSys.readdir dir of
 532                 NONE => diffs
 533               | SOME site =>
 534                 let
 535                     fun explore (dname, diffs) =
 536                         let
 537                             val dir = Posix.FileSys.opendir dname
 538
 539                             fun loop diffs =
 540                                 case Posix.FileSys.readdir dir of
 541                                     NONE => diffs
 542                                   | SOME name =>
 543                                     let
 544                                         val fname = OS.Path.joinDirFile {dir = dname,
 545                                                                          file = name}
 546                                     in
 547                                         loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then
 548                                                   let
 549                                                       val dom = String.fields (fn ch => ch = #"/") fname
 550                                                       val dom = List.drop (dom, len)
 551                                                       val dom = String.concatWith "." (rev dom)
 552
 553                                                       val dname' = OS.Path.joinDirFile {dir = dname,
 554                                                                                         file = name}
 555                                                   in
 556                                                       explore (dname',
 557                                                                findDiffs (prefixes, site, dom, diffs))
 558                                                   end
 559                                               else
 560                                                   diffs)
 561                                     end
 562                         in
 563                             loop diffs
 564                             before Posix.FileSys.closedir dir
 565                         end
 566                 in
 567                     exploreSites (explore (OS.Path.joinDirFile {dir = Config.tmpDir,
 568                                                                 file = site}, diffs))
 569                 end
 570     in
 571         exploreSites []
 572         before Posix.FileSys.closedir dir
 573     end
 574
 575 val masterNode : string option ref = ref NONE
 576 fun dnsMaster () = !masterNode
 577
 578 val seenDomains : string list ref = ref []
 579
 580 val _ = Env.containerV_one "domain"
 581                            ("domain", Env.string)
 582                            (fn (evs, dom) =>
 583                                let
 584                                    val () = seenDomains := dom :: !seenDomains
 585
 586                                    val kind = Env.env dnsKind (evs, "DNS")
 587                                    val ttl = Env.env Env.int (evs, "TTL")
 588                                    val aliases = Env.env (Env.list Env.string) (evs, "Aliases")
 589
 590                                    val path = getPath dom
 591
 592                                    val () = (current := dom;
 593                                              currentsAli := Slave.remove (Slave.removeDups aliases, dom);
 594                                              currentPath := (fn site => path (Config.tmpDir, site));
 595                                              currentPathAli := (fn (dom, site) => getPath dom (Config.tmpDir, site)))
 596
 597                                    fun saveSoa (kind, soa : soa) node =
 598                                        let
 599                                            val {write, writeDom, close} = domainsFile {node = node, name = "soa.conf"}
 600                                        in
 601                                            write kind;
 602                                            write "\n";
 603                                            write (Int.toString ttl);
 604                                            write "\n";
 605                                            write (#ns soa);
 606                                            write "\n";
 607                                            case #serial soa of
 608                                                NONE => ()
 609                                              | SOME n => write (Int.toString n);
 610                                            write "\n";
 611                                            write (Int.toString (#ref soa));
 612                                            write "\n";
 613                                            write (Int.toString (#ret soa));
 614                                            write "\n";
 615                                            write (Int.toString (#exp soa));
 616                                            write "\n";
 617                                            write (Int.toString (#min soa));
 618                                            write "\n";
 619                                            close ()
 620                                        end
 621
 622                                    fun saveNamed (kind, soa : soa, masterIp, slaveIps) node =
 623                                        if dom = "localhost" then
 624                                            ()
 625                                        else let
 626                                                val {write, writeDom, close} = domainsFile {node = node, name = "named.conf"}
 627                                            in
 628                                                write "\nzone \"";
 629                                                writeDom ();
 630                                                write "\" {\n\ttype ";
 631                                                write kind;
 632                                                write ";\n\tfile \"";
 633                                                write Config.Bind.zonePath_real;
 634                                                write "/";
 635                                                writeDom ();
 636                                                write ".zone\";\n";
 637                                                case kind of
 638                                                    "master" => (write "\tallow-transfer {\n";
 639                                                                 app (fn ip => (write "\t\t";
 640                                                                                write ip;
 641                                                                                write ";\n")) slaveIps;
 642                                                                 write "\t};\n")
 643                                                  | _ => (write "\tmasters { ";
 644                                                          write masterIp;
 645                                                          write "; };\n";
 646                                                          write "// Updated: ";
 647                                                          write (Time.toString (Time.now ()));
 648                                                          write "\n");
 649                                                write "};\n";
 650                                                close ()
 651                                            end
 652                                in
 653                                    case kind of
 654                                        NoDns => masterNode := NONE
 655                                      | UseDns dns =>
 656                                        let
 657                                            val masterIp =
 658                                                case #master dns of
 659                                                    InternalMaster node => nodeIp node
 660                                                  | ExternalMaster ip => ip
 661
 662                                            val slaveIps = map nodeIp (#slaves dns)
 663                                        in
 664                                            app (saveNamed ("slave", #soa dns, masterIp, slaveIps)) (#slaves dns);
 665                                            case #master dns of
 666                                                InternalMaster node =>
 667                                                (masterNode := SOME node;
 668                                                 saveSoa ("master", #soa dns) node;
 669                                                 saveNamed ("master", #soa dns, masterIp, slaveIps) node)
 670                                              | _ => masterNode := NONE
 671                                        end;
 672                                    !befores dom
 673                                end,
 674                             fn () => !afters (!current))
 675
 676 val () = Env.registerPre (fn () => (seenDomains := [];
 677                                     ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
 678                                                        fn cl => "Temp file cleanup failed: " ^ cl));
 679                                     OS.FileSys.mkDir Config.tmpDir;
 680                                     app (fn node => OS.FileSys.mkDir
 681                                                         (OS.Path.joinDirFile {dir = Config.tmpDir,
 682                                                                               file = node}))
 683                                         nodes;
 684                                     app (fn node => OS.FileSys.mkDir
 685                                                         (OS.Path.joinDirFile {dir = Config.resultRoot,
 686                                                                               file = node})
 687                                             handle OS.SysErr _ => ())
 688                                         nodes))
 689
 690 fun handleSite (site, files) =
 691     let
 692
 693     in
 694         print ("New configuration for node " ^ site ^ "\n");
 695         if site = Config.dispatcherName then
 696             Slave.handleChanges files
 697         else let
 698                 val bio = OpenSSL.connect true (valOf (!ssl_context),
 699                                                 nodeIp site
 700                                                 ^ ":"
 701                                                 ^ Int.toString Config.slavePort)
 702             in
 703                 app (fn file => Msg.send (bio, MsgFile file)) files;
 704                 Msg.send (bio, MsgDoFiles);
 705                 case Msg.recv bio of
 706                     NONE => print "Slave closed connection unexpectedly\n"
 707                   | SOME m =>
 708                     case m of
 709                         MsgOk => print ("Slave " ^ site ^ " finished\n")
 710                       | MsgError s => print ("Slave " ^ site
 711                                              ^ " returned error: " ^
 712                                              s ^ "\n")
 713                       | _ => print ("Slave " ^ site
 714                                     ^ " returned unexpected command\n");
 715                 OpenSSL.close bio
 716             end
 717     end
 718
 719 val () = Env.registerPost (fn () =>
 720                               let
 721                                   val prefixes = List.concat
 722                                                      (List.map (fn dom =>
 723                                                                    let
 724                                                                        val pieces = String.tokens (fn ch => ch = #".") dom
 725                                                                        val path = String.concatWith "/" (rev pieces)
 726                                                                    in
 727                                                                        List.map (fn node =>
 728                                                                                     Config.resultRoot ^ "/" ^ node ^ "/" ^ path ^ "/")
 729                                                                                 nodes
 730                                                                    end) (!seenDomains))
 731
 732                                   val diffs = findAllDiffs prefixes
 733
 734                                   val diffs = map (fn (site, dom, dir, Add' {src, dst}) =>
 735                                                       (Slave.shellF ([Config.cp, " ", src, " ", dst],
 736                                                                   fn cl => "Copy failed: " ^ cl);
 737                                                        (site,
 738                                                         {action = Slave.Add,
 739                                                          domain = dom,
 740                                                          dir = dir,
 741                                                          file = dst}))
 742                                                     | (site, dom, dir, Delete' dst) =>
 743                                                       (OS.FileSys.remove dst
 744                                                        handle OS.SysErr _ =>
 745                                                               ErrorMsg.error NONE ("Delete failed for " ^ dst);
 746                                                        (site,
 747                                                         {action = Slave.Delete true,
 748                                                          domain = dom,
 749                                                          dir = dir,
 750                                                          file = dst}))
 751                                                     | (site, dom, dir, Modify' {src, dst}) =>
 752                                                       (Slave.shellF ([Config.cp, " ", src, " ", dst],
 753                                                                   fn cl => "Copy failed: " ^ cl);
 754                                                        (site,
 755                                                         {action = Slave.Modify,
 756                                                          domain = dom,
 757                                                          dir = dir,
 758                                                          file = dst}))) diffs
 759                               in
 760                                   if !ErrorMsg.anyErrors then
 761                                       ()
 762                                   else let
 763                                           val changed = foldl (fn ((site, file), changed) =>
 764                                                                   let
 765                                                                       val ls = case SM.find (changed, site) of
 766                                                                                    NONE => []
 767                                                                                  | SOME ls => ls
 768                                                                   in
 769                                                                       SM.insert (changed, site, file :: ls)
 770                                                                   end) SM.empty diffs
 771                                       in
 772                                           SM.appi handleSite changed
 773                                       end;
 774                                   ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
 775                                                      fn cl => "Temp file cleanup failed: " ^ cl))
 776                               end)
 777
 778 fun hasPriv priv = Acl.query {user = getUser (), class = "priv", value = "all"}
 779                    orelse Acl.query {user = getUser (), class = "priv", value = priv}
 780
 781 val _ = Env.type_one "dns_node"
 782         Env.string
 783         (fn node =>
 784             List.exists (fn x => x = node) Config.dnsNodes_all
 785             orelse (hasPriv "dns"
 786                     andalso List.exists (fn x => x = node) Config.dnsNodes_admin))
 787
 788 val _ = Env.type_one "mail_node"
 789         Env.string
 790         (fn node =>
 791             List.exists (fn x => x = node) Config.mailNodes_all
 792             orelse (hasPriv "mail"
 793                     andalso List.exists (fn x => x = node) Config.mailNodes_admin))
 794
 795 fun rmdom' delete resultRoot doms =
 796     let
 797         fun doNode (node, _) =
 798             let
 799                 val dname = OS.Path.joinDirFile {dir = resultRoot,
 800                                                  file = node}
 801
 802                 fun doDom (dom, actions) =
 803                     let
 804                         val domPath = String.concatWith "/" (rev (String.fields (fn ch => ch = #".") dom))
 805                         val dname = OS.Path.concat (dname, domPath)
 806
 807                         fun visitDom (dom, dname, actions) =
 808                             let
 809                                 val dir = Posix.FileSys.opendir dname
 810
 811                                 fun loop actions =
 812                                     case Posix.FileSys.readdir dir of
 813                                         NONE => actions
 814                                       | SOME fname =>
 815                                         let
 816                                             val fnameFull = OS.Path.joinDirFile {dir = dname,
 817                                                                                  file = fname}
 818                                         in
 819                                             if Posix.FileSys.ST.isDir (Posix.FileSys.stat fnameFull) then
 820                                                 loop (visitDom (fname ^ "." ^ dom,
 821                                                                 fnameFull,
 822                                                                 actions))
 823                                             else
 824                                                  loop ({action = Slave.Delete delete,
 825                                                         domain = dom,
 826                                                         dir = dname,
 827                                                         file = fnameFull} :: actions)
 828                                         end
 829                             in
 830                                 loop actions
 831                                 before Posix.FileSys.closedir dir
 832                             end
 833                                 handle OS.SysErr (s, _) =>
 834                                        (print ("Warning: System error deleting domain " ^ dom ^ " on " ^ node ^ ": " ^ s ^ "\n");
 835                                         actions)
 836                     in
 837                         visitDom (dom, dname, actions)
 838                     end
 839
 840                 val actions = foldl doDom [] doms
 841             in
 842                 handleSite (node, actions)
 843             end
 844                 handle IO.Io _ => print ("Warning: IO error deleting domains on " ^ node ^ ".\n")
 845
 846         fun cleanupNode (node, _) =
 847             let
 848                 fun doDom dom =
 849                     let
 850                         val domPath = String.concatWith "/" (rev (String.fields (fn ch => ch = #".") dom))
 851                         val dname = OS.Path.joinDirFile {dir = resultRoot,
 852                                                          file = node}
 853                         val dname = OS.Path.concat (dname, domPath)
 854                     in
 855                         if delete then
 856                             ignore (OS.Process.system (Config.rm ^ " -rf " ^ dname))
 857                         else
 858                             ()
 859                     end
 860             in
 861                 app doDom doms
 862             end
 863     in
 864         app doNode Config.nodeIps;
 865         app cleanupNode Config.nodeIps
 866     end
 867
 868 val rmdom = rmdom' true Config.resultRoot
 869 val rmdom' = rmdom' false
 870
 871 fun homedirOf uname =
 872     Posix.SysDB.Passwd.home (Posix.SysDB.getpwnam uname)
 873
 874 fun homedir () = homedirOf (getUser ())
 875                  handle e => if !fakePrivs then "/tmp" else raise e
 876
 877 type subject = {node : string, domain : string}
 878
 879 val describers : (subject -> string) list ref = ref []
 880
 881 fun registerDescriber f = describers := f :: !describers
 882
 883 fun describeOne arg = String.concat (map (fn f => f arg) (rev (!describers)))
 884
 885 val line = "--------------------------------------------------------------\n"
 886 val dline = "==============================================================\n"
 887
 888 fun describe dom =
 889     String.concat (List.mapPartial
 890                        (fn node =>
 891                            case describeOne {node = node, domain = dom} of
 892                                "" => NONE
 893                              | s =>
 894                                SOME (String.concat [dline, "Node ", node, "\n", dline, "\n", s]))
 895                        nodes)
 896
 897 datatype description =
 898          Filename of { filename : string, heading : string, showEmpty : bool }
 899        | Extension of { extension : string, heading : string -> string }
 900
 901 fun considerAll ds {node, domain} =
 902     let
 903         val ds = map (fn d => (d, ref [])) ds
 904
 905         val path = Config.resultRoot
 906         val jdf = OS.Path.joinDirFile
 907         val path = jdf {dir = path, file = node}
 908         val path = foldr (fn (more, path) => jdf {dir = path, file = more})
 909                          path (String.tokens (fn ch => ch = #".") domain)
 910     in
 911         if Posix.FileSys.access (path, []) then
 912             let
 913                 val dir = Posix.FileSys.opendir path
 914
 915                 fun loop () =
 916                     case Posix.FileSys.readdir dir of
 917                         NONE => ()
 918                       | SOME fname =>
 919                         (app (fn (d, entries) =>
 920                                  let
 921                                      fun readFile showEmpty entries' =
 922                                          let
 923                                              val fname = OS.Path.joinDirFile {dir = path,
 924                                                                               file = fname}
 925
 926                                              val inf = TextIO.openIn fname
 927
 928                                              fun loop (seenOne, entries') =
 929                                                  case TextIO.inputLine inf of
 930                                                      NONE => if seenOne orelse showEmpty then
 931                                                                  "\n" :: entries'
 932                                                              else
 933                                                                  !entries
 934                                                    | SOME line => loop (true, line :: entries')
 935                                          in
 936                                              loop (false, entries')
 937                                              before TextIO.closeIn inf
 938                                          end
 939                                  in
 940                                      case d of
 941                                          Filename {filename, heading, showEmpty} =>
 942                                          if fname = filename then
 943                                              entries := readFile showEmpty ("\n" :: line :: "\n" :: heading :: line :: !entries)
 944                                          else
 945                                              ()
 946                                        | Extension {extension, heading} =>
 947                                          let
 948                                              val {base, ext} = OS.Path.splitBaseExt fname
 949                                          in
 950                                              case ext of
 951                                                  NONE => ()
 952                                                | SOME extension' =>
 953                                                  if extension' = extension then
 954                                                      entries := readFile true ("\n" :: line :: "\n" :: heading base :: line :: !entries)
 955                                                  else
 956                                                      ()
 957                                          end
 958                                  end) ds;
 959                          loop ())
 960             in
 961                 loop ();
 962                 Posix.FileSys.closedir dir;
 963                 String.concat (List.concat (map (fn (_, entries) => rev (!entries)) ds))
 964             end
 965         else
 966             ""
 967     end
 968
 969 val () = registerDescriber (considerAll [Filename {filename = "soa.conf",
 970                                                    heading = "DNS SOA:",
 971                                                    showEmpty = false}])
 972
 973 val () = Env.registerAction ("domainHost",
 974                              fn (env, [(EString host, _)]) =>
 975                                 SM.insert (env, "Hostname",
 976                                            (EString (host ^ "." ^ currentDomain ()), dl))
 977                               | (_, args) => Env.badArgs ("domainHost", args))
 978
 979 val ouc = ref (fn () => ())
 980
 981 fun registerOnUsersChange f =
 982     let
 983         val f' = !ouc
 984     in
 985         ouc := (fn () => (f' (); f ()))
 986     end
 987
 988 fun onUsersChange () = !ouc ()
 989
 990 end