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