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