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