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