src/domain.sml

   1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
   2  * Copyright (c) 2006, 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 fun setUser user =
  52     (usr := user;
  53      your_doms := Acl.class {user = getUser (),
  54                              class = "domain"};
  55      your_usrs := Acl.class {user = getUser (),
  56                              class = "user"};
  57      your_grps := Acl.class {user = getUser (),
  58                              class = "group"};
  59      your_pths := Acl.class {user = getUser (),
  60                              class = "path"})
  61
  62 fun validIp s =
  63     case map Int.fromString (String.fields (fn ch => ch = #".") s) of
  64         [SOME n1, SOME n2, SOME n3, SOME n4] =>
  65         n1 >= 0 andalso n1 < 256 andalso n2 >= 0 andalso n2 < 256 andalso n3 >= 0 andalso n3 < 256 andalso n4 >= 0 andalso n4 < 256
  66       | _ => false
  67
  68 fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
  69
  70 fun validHost s =
  71     size s > 0 andalso size s < 20
  72     andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s
  73
  74 fun validDomain s =
  75     size s > 0 andalso size s < 100
  76     andalso List.all validHost (String.fields (fn ch => ch = #".") s)
  77
  78 fun validNode s = List.exists (fn s' => s = s') nodes
  79
  80 fun yourDomain s = SS.member (your_domains (), s)
  81 fun yourUser s = SS.member (your_users (), s)
  82 fun yourGroup s = SS.member (your_groups (), s)
  83 fun yourPath path =
  84     List.all (fn s => s <> "..") (String.fields (fn ch => ch = #"/") path)
  85     andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"/"
  86                                      orelse ch = #"-" orelse ch = #"_") path
  87     andalso SS.exists (fn s' => path = s' orelse String.isPrefix (s' ^ "/") path) (your_paths ())
  88
  89 fun yourDomainHost s =
  90     yourDomain s
  91     orelse let
  92         val (pref, suf) = Substring.splitl (fn ch => ch <> #".") (Substring.full s)
  93     in
  94         Substring.size suf > 0
  95         andalso validHost (Substring.string pref)
  96         andalso yourDomain (Substring.string
  97                                 (Substring.slice (suf, 1, NONE)))
  98     end
  99
 100 fun validUser s = size s > 0 andalso size s < 20
 101                   andalso CharVector.all Char.isAlphaNum s
 102
 103 val validGroup = validUser
 104
 105 val _ = Env.type_one "no_spaces"
 106                      Env.string
 107                      (CharVector.all (fn ch => not (Char.isSpace ch)))
 108 val _ = Env.type_one "no_newlines"
 109                      Env.string
 110                      (CharVector.all (fn ch => ch <> #"\n" andalso ch <> #"\r"))
 111
 112 val _ = Env.type_one "ip"
 113         Env.string
 114         validIp
 115
 116 val _ = Env.type_one "host"
 117         Env.string
 118         validHost
 119
 120 val _ = Env.type_one "domain"
 121         Env.string
 122         validDomain
 123
 124 val _ = Env.type_one "your_domain"
 125         Env.string
 126         yourDomain
 127
 128 val _ = Env.type_one "your_domain_host"
 129         Env.string
 130         yourDomainHost
 131
 132 val _ = Env.type_one "user"
 133         Env.string
 134         validUser
 135
 136 val _ = Env.type_one "group"
 137         Env.string
 138         validGroup
 139
 140 val _ = Env.type_one "your_user"
 141         Env.string
 142         yourUser
 143
 144 val _ = Env.type_one "your_group"
 145         Env.string
 146         yourGroup
 147
 148 val _ = Env.type_one "your_path"
 149         Env.string
 150         yourPath
 151
 152 val _ = Env.type_one "node"
 153         Env.string
 154         validNode
 155
 156 open Ast
 157
 158 val dl = ErrorMsg.dummyLoc
 159
 160 val nsD = (EString Config.defaultNs, dl)
 161 val serialD = (EVar "serialAuto", dl)
 162 val refD = (EInt Config.defaultRefresh, dl)
 163 val retD = (EInt Config.defaultRetry, dl)
 164 val expD = (EInt Config.defaultExpiry, dl)
 165 val minD = (EInt Config.defaultMinimum, dl)
 166
 167 val soaD = multiApp ((EVar "soa", dl),
 168                      dl,
 169                      [nsD, serialD, refD, retD, expD, minD])
 170
 171 val masterD = (EApp ((EVar "internalMaster", dl),
 172                      (EString Config.masterNode, dl)),
 173                dl)
 174
 175 val slavesD = (EList (map (fn s => (EString s, dl)) Config.slaveNodes), dl)
 176
 177 val _ = Defaults.registerDefault ("Mailbox",
 178                                   (TBase "email", dl),
 179                                   (fn () => (EString (getUser ()), dl)))
 180
 181 val _ = Defaults.registerDefault ("DNS",
 182                                   (TBase "dnsKind", dl),
 183                                   (fn () => multiApp ((EVar "useDns", dl),
 184                                                       dl,
 185                                                       [soaD, masterD, slavesD])))
 186
 187 val _ = Defaults.registerDefault ("TTL",
 188                                   (TBase "int", dl),
 189                                   (fn () => (EInt Config.Bind.defaultTTL, dl)))
 190
 191 type soa = {ns : string,
 192             serial : int option,
 193             ref : int,
 194             ret : int,
 195             exp : int,
 196             min : int}
 197
 198 val serial = fn (EVar "serialAuto", _) => SOME NONE
 199               | (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
 200               | _ => NONE
 201
 202 val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
 203                                                      ((EVar "soa", _), ns), _),
 204                                                 sl), _),
 205                                          rf), _),
 206                                   ret), _),
 207                            exp), _),
 208                     min), _) =>
 209              (case (Env.string ns, serial sl, Env.int rf,
 210                     Env.int ret, Env.int exp, Env.int min) of
 211                   (SOME ns, SOME sl, SOME rf,
 212                    SOME ret, SOME exp, SOME min) =>
 213                   SOME {ns = ns,
 214                         serial = sl,
 215                         ref = rf,
 216                         ret = ret,
 217                         exp = exp,
 218                         min = min}
 219                 | _ => NONE)
 220            | _ => NONE
 221
 222 datatype master =
 223          ExternalMaster of string
 224        | InternalMaster of string
 225
 226 val ip = Env.string
 227
 228 val _ = Env.registerFunction ("ip_of_node",
 229                               fn [(EString node, _)] => SOME (EString (nodeIp node), dl)
 230                                | _ => NONE)
 231
 232 val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (ip e)
 233               | (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (Env.string e)
 234               | _ => NONE
 235
 236 datatype dnsKind =
 237          UseDns of {soa : soa,
 238                     master : master,
 239                     slaves : string list}
 240        | NoDns
 241
 242 val dnsKind = fn (EApp ((EApp ((EApp
 243                                     ((EVar "useDns", _), sa), _),
 244                                mstr), _),
 245                         slaves), _) =>
 246                  (case (soa sa, master mstr, Env.list Env.string slaves) of
 247                       (SOME sa, SOME mstr, SOME slaves) =>
 248                       SOME (UseDns {soa = sa,
 249                                     master = mstr,
 250                                     slaves = slaves})
 251                     | _ => NONE)
 252                | (EVar "noDns", _) => SOME NoDns
 253                | _ => NONE
 254
 255 val befores = ref (fn (_ : string) => ())
 256 val afters = ref (fn (_ : string) => ())
 257
 258 fun registerBefore f =
 259     let
 260         val old = !befores
 261     in
 262         befores := (fn x => (old x; f x))
 263     end
 264
 265 fun registerAfter f =
 266     let
 267         val old = !afters
 268     in
 269         afters := (fn x => (old x; f x))
 270     end
 271
 272 val current = ref ""
 273 val currentPath = ref (fn (_ : string) => "")
 274
 275 val scratch = ref ""
 276
 277 fun currentDomain () = !current
 278
 279 fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*)
 280                                TextIO.openOut (!currentPath node ^ name))
 281
 282 fun getPath domain =
 283     let
 284         val toks = String.fields (fn ch => ch = #".") domain
 285
 286         val elems = foldr (fn (piece, elems) =>
 287                               let
 288                                   val elems = piece :: elems
 289
 290                                   fun doNode node =
 291                                       let
 292                                           val path = String.concatWith "/"
 293                                                                        (Config.resultRoot :: node :: rev elems)
 294                                           val tmpPath = String.concatWith "/"
 295                                                                           (Config.tmpDir :: node :: rev elems)
 296                                       in
 297                                           (if Posix.FileSys.ST.isDir
 298                                                   (Posix.FileSys.stat path) then
 299                                                ()
 300                                            else
 301                                                (OS.FileSys.remove path;
 302                                                 OS.FileSys.mkDir path))
 303                                           handle OS.SysErr _ => OS.FileSys.mkDir path;
 304
 305                                           (if Posix.FileSys.ST.isDir
 306                                                   (Posix.FileSys.stat tmpPath) then
 307                                                ()
 308                                            else
 309                                                (OS.FileSys.remove tmpPath;
 310                                                 OS.FileSys.mkDir tmpPath))
 311                                           handle OS.SysErr _ => OS.FileSys.mkDir tmpPath
 312                                       end
 313                               in
 314                                   app doNode nodes;
 315                                   elems
 316                               end) [] toks
 317     in
 318         fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
 319     end
 320
 321 datatype file_action' =
 322          Add' of {src : string, dst : string}
 323        | Delete' of string
 324        | Modify' of {src : string, dst : string}
 325
 326 fun findDiffs (site, dom, acts) =
 327     let
 328         val gp = getPath dom
 329         val realPath = gp (Config.resultRoot, site)
 330         val tmpPath = gp (Config.tmpDir, site)
 331
 332         (*val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n")*)
 333
 334         val dir = Posix.FileSys.opendir realPath
 335
 336         fun loopReal acts =
 337             case Posix.FileSys.readdir dir of
 338                 NONE => (Posix.FileSys.closedir dir;
 339                          acts)
 340               | SOME fname =>
 341                 let
 342                     val real = OS.Path.joinDirFile {dir = realPath,
 343                                                     file = fname}
 344                     val tmp = OS.Path.joinDirFile {dir = tmpPath,
 345                                                    file = fname}
 346                 in
 347                     if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
 348                         loopReal acts
 349                     else if Posix.FileSys.access (tmp, []) then
 350                         if Slave.shell [Config.diff, " ", real, " ",  tmp] then
 351                             loopReal acts
 352                         else
 353                             loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
 354                     else
 355                         loopReal ((site, dom, realPath, Delete' real) :: acts)
 356                 end
 357
 358         val acts = loopReal acts
 359
 360         val dir = Posix.FileSys.opendir tmpPath
 361
 362         fun loopTmp acts =
 363             case Posix.FileSys.readdir dir of
 364                 NONE => (Posix.FileSys.closedir dir;
 365                          acts)
 366               | SOME fname =>
 367                 let
 368                     val real = OS.Path.joinDirFile {dir = realPath,
 369                                                     file = fname}
 370                     val tmp = OS.Path.joinDirFile {dir = tmpPath,
 371                                                    file = fname}
 372                 in
 373                     if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
 374                         loopTmp acts
 375                     else if Posix.FileSys.access (real, []) then
 376                         loopTmp acts
 377                     else
 378                         loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
 379                 end
 380
 381         val acts = loopTmp acts
 382     in
 383         acts
 384     end
 385
 386 fun findAllDiffs () =
 387     let
 388         val dir = Posix.FileSys.opendir Config.tmpDir
 389         val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1
 390
 391         fun exploreSites diffs =
 392             case Posix.FileSys.readdir dir of
 393                 NONE => diffs
 394               | SOME site =>
 395                 let
 396                     fun explore (dname, diffs) =
 397                         let
 398                             val dir = Posix.FileSys.opendir dname
 399
 400                             fun loop diffs =
 401                                 case Posix.FileSys.readdir dir of
 402                                     NONE => diffs
 403                                   | SOME name =>
 404                                     let
 405                                         val fname = OS.Path.joinDirFile {dir = dname,
 406                                                                          file = name}
 407                                     in
 408                                         loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then
 409                                                   let
 410                                                       val dom = String.fields (fn ch => ch = #"/") fname
 411                                                       val dom = List.drop (dom, len)
 412                                                       val dom = String.concatWith "." (rev dom)
 413
 414                                                       val dname' = OS.Path.joinDirFile {dir = dname,
 415                                                                                         file = name}
 416                                                   in
 417                                                       explore (dname',
 418                                                                findDiffs (site, dom, diffs))
 419                                                   end
 420                                               else
 421                                                   diffs)
 422                                     end
 423                         in
 424                             loop diffs
 425                             before Posix.FileSys.closedir dir
 426                         end
 427                 in
 428                     exploreSites (explore (OS.Path.joinDirFile {dir = Config.tmpDir,
 429                                                                 file = site}, diffs))
 430                 end
 431     in
 432         exploreSites []
 433         before Posix.FileSys.closedir dir
 434     end
 435
 436 val masterNode : string option ref = ref NONE
 437 fun dnsMaster () = !masterNode
 438
 439 val _ = Env.containerV_one "domain"
 440                            ("domain", Env.string)
 441                            (fn (evs, dom) =>
 442                                let
 443                                    val kind = Env.env dnsKind (evs, "DNS")
 444                                    val ttl = Env.env Env.int (evs, "TTL")
 445
 446                                    val path = getPath dom
 447
 448                                    val () = (current := dom;
 449                                              currentPath := (fn site => path (Config.tmpDir, site)))
 450
 451                                    fun saveSoa (kind, soa : soa) node =
 452                                        let
 453                                            val outf = domainFile {node = node, name = "soa"}
 454                                        in
 455                                            TextIO.output (outf, kind);
 456                                            TextIO.output (outf, "\n");
 457                                            TextIO.output (outf, Int.toString ttl);
 458                                            TextIO.output (outf, "\n");
 459                                            TextIO.output (outf, #ns soa);
 460                                            TextIO.output (outf, "\n");
 461                                            case #serial soa of
 462                                                NONE => ()
 463                                              | SOME n => TextIO.output (outf, Int.toString n);
 464                                            TextIO.output (outf, "\n");
 465                                            TextIO.output (outf, Int.toString (#ref soa));
 466                                            TextIO.output (outf, "\n");
 467                                            TextIO.output (outf, Int.toString (#ret soa));
 468                                            TextIO.output (outf, "\n");
 469                                            TextIO.output (outf, Int.toString (#exp soa));
 470                                            TextIO.output (outf, "\n");
 471                                            TextIO.output (outf, Int.toString (#min soa));
 472                                            TextIO.output (outf, "\n");
 473                                            TextIO.closeOut outf
 474                                        end
 475
 476                                    fun saveNamed (kind, soa : soa, masterIp) node =
 477                                        let
 478                                            val outf = domainFile {node = node, name = "named.conf"}
 479                                        in
 480                                            TextIO.output (outf, "\nzone \"");
 481                                            TextIO.output (outf, dom);
 482                                            TextIO.output (outf, "\" IN {\n\ttype ");
 483                                            TextIO.output (outf, kind);
 484                                            TextIO.output (outf, ";\n\tfile \"");
 485                                            TextIO.output (outf, Config.Bind.zonePath_real);
 486                                            TextIO.output (outf, "/");
 487                                            TextIO.output (outf, dom);
 488                                            TextIO.output (outf, ".zone\";\n");
 489                                            case kind of
 490                                                "master" => TextIO.output (outf, "\tallow-update { none; };\n")
 491                                              | _ => (TextIO.output (outf, "\tmasters { ");
 492                                                      TextIO.output (outf, masterIp);
 493                                                      TextIO.output (outf, "; };\n"));
 494                                            TextIO.output (outf, "};\n");
 495                                            TextIO.closeOut outf
 496                                        end
 497                                in
 498                                    case kind of
 499                                        NoDns => masterNode := NONE
 500                                      | UseDns dns =>
 501                                        let
 502                                            val masterIp =
 503                                                case #master dns of
 504                                                    InternalMaster node => valOf (SM.find (nodeMap, node))
 505                                                  | ExternalMaster ip => ip
 506                                        in
 507                                            app (saveSoa ("slave", #soa dns)) (#slaves dns);
 508                                            app (saveNamed ("slave", #soa dns, masterIp)) (#slaves dns);
 509                                            case #master dns of
 510                                                InternalMaster node =>
 511                                                (masterNode := SOME node;
 512                                                 saveSoa ("master", #soa dns) node;
 513                                                 saveNamed ("master", #soa dns, masterIp) node)
 514                                              | _ => masterNode := NONE;
 515                                            !befores dom
 516                                        end
 517                                end,
 518                             fn () => !afters (!current))
 519
 520 val () = Env.registerPre (fn () => (ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
 521                                                        fn cl => "Temp file cleanup failed: " ^ cl));
 522                                     OS.FileSys.mkDir Config.tmpDir;
 523                                     app (fn node => OS.FileSys.mkDir
 524                                                         (OS.Path.joinDirFile {dir = Config.tmpDir,
 525                                                                               file = node}))
 526                                         nodes;
 527                                     app (fn node => OS.FileSys.mkDir
 528                                                         (OS.Path.joinDirFile {dir = Config.resultRoot,
 529                                                                               file = node})
 530                                             handle OS.SysErr _ => ())
 531                                         nodes))
 532
 533 val () = Env.registerPost (fn () =>
 534                               let
 535                                   val diffs = findAllDiffs ()
 536
 537                                   val diffs = map (fn (site, dom, dir, Add' {src, dst}) =>
 538                                                       (Slave.shellF ([Config.cp, " ", src, " ", dst],
 539                                                                   fn cl => "Copy failed: " ^ cl);
 540                                                        (site,
 541                                                         {action = Slave.Add,
 542                                                          domain = dom,
 543                                                          dir = dir,
 544                                                          file = dst}))
 545                                                     | (site, dom, dir, Delete' dst) =>
 546                                                       (OS.FileSys.remove dst
 547                                                        handle OS.SysErr _ =>
 548                                                               ErrorMsg.error NONE ("Delete failed for " ^ dst);
 549                                                        (site,
 550                                                         {action = Slave.Delete,
 551                                                          domain = dom,
 552                                                          dir = dir,
 553                                                          file = dst}))
 554                                                     | (site, dom, dir, Modify' {src, dst}) =>
 555                                                       (Slave.shellF ([Config.cp, " ", src, " ", dst],
 556                                                                   fn cl => "Copy failed: " ^ cl);
 557                                                        (site,
 558                                                         {action = Slave.Modify,
 559                                                          domain = dom,
 560                                                          dir = dir,
 561                                                          file = dst}))) diffs
 562                               in
 563                                   if !ErrorMsg.anyErrors then
 564                                       ()
 565                                   else let
 566                                           val changed = foldl (fn ((site, file), changed) =>
 567                                                                   let
 568                                                                       val ls = case SM.find (changed, site) of
 569                                                                                    NONE => []
 570                                                                                  | SOME ls => ls
 571                                                                   in
 572                                                                       SM.insert (changed, site, file :: ls)
 573                                                                   end) SM.empty diffs
 574
 575                                           fun handleSite (site, files) =
 576                                               let
 577
 578                                               in
 579                                                   print ("New configuration for node " ^ site ^ "\n");
 580                                                   if site = Config.defaultNode then
 581                                                       Slave.handleChanges files
 582                                                   else let
 583                                                           val bio = OpenSSL.connect (valOf (!ssl_context),
 584                                                                                      nodeIp site
 585                                                                                      ^ ":"
 586                                                                                      ^ Int.toString Config.slavePort)
 587                                                       in
 588                                                           app (fn file => Msg.send (bio, MsgFile file)) files;
 589                                                           Msg.send (bio, MsgDoFiles);
 590                                                           case Msg.recv bio of
 591                                                               NONE => print "Slave closed connection unexpectedly\n"
 592                                                             | SOME m =>
 593                                                               case m of
 594                                                                   MsgOk => print ("Slave " ^ site ^ " finished\n")
 595                                                                 | MsgError s => print ("Slave " ^ site
 596                                                                                        ^ " returned error: " ^
 597                                                                                        s ^ "\n")
 598                                                                 | _ => print ("Slave " ^ site
 599                                                                               ^ " returned unexpected command\n");
 600                                                           OpenSSL.close bio
 601                                                       end
 602                                               end
 603                                       in
 604                                           SM.appi handleSite changed
 605                                       end;
 606                                   ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
 607                                                      fn cl => "Temp file cleanup failed: " ^ cl))
 608                               end)
 609
 610 end