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