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