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