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