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