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