src/domain.sml

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