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.defaultNode, dl)),
 173                dl)
 174
 175 val _ = Defaults.registerDefault ("Mailbox",
 176                                   (TBase "email", dl),
 177                                   (fn () => (EString (getUser ()), dl)))
 178
 179 val _ = Defaults.registerDefault ("DNS",
 180                                   (TBase "dnsKind", dl),
 181                                   (fn () => multiApp ((EVar "useDns", dl),
 182                                                       dl,
 183                                                       [soaD, masterD, (EList [], dl)])))
 184
 185 val _ = Defaults.registerDefault ("TTL",
 186                                   (TBase "int", dl),
 187                                   (fn () => (EInt Config.Bind.defaultTTL, dl)))
 188
 189 type soa = {ns : string,
 190             serial : int option,
 191             ref : int,
 192             ret : int,
 193             exp : int,
 194             min : int}
 195
 196 val serial = fn (EVar "serialAuto", _) => SOME NONE
 197               | (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
 198               | _ => NONE
 199
 200 val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
 201                                                      ((EVar "soa", _), ns), _),
 202                                                 sl), _),
 203                                          rf), _),
 204                                   ret), _),
 205                            exp), _),
 206                     min), _) =>
 207              (case (Env.string ns, serial sl, Env.int rf,
 208                     Env.int ret, Env.int exp, Env.int min) of
 209                   (SOME ns, SOME sl, SOME rf,
 210                    SOME ret, SOME exp, SOME min) =>
 211                   SOME {ns = ns,
 212                         serial = sl,
 213                         ref = rf,
 214                         ret = ret,
 215                         exp = exp,
 216                         min = min}
 217                 | _ => NONE)
 218            | _ => NONE
 219
 220 datatype master =
 221          ExternalMaster of string
 222        | InternalMaster of string
 223
 224 val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (Env.string e)
 225               | (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (Env.string e)
 226               | _ => NONE
 227
 228 datatype dnsKind =
 229          UseDns of {soa : soa,
 230                     master : master,
 231                     slaves : string list}
 232        | NoDns
 233
 234 val dnsKind = fn (EApp ((EApp ((EApp
 235                                     ((EVar "useDns", _), sa), _),
 236                                mstr), _),
 237                         slaves), _) =>
 238                  (case (soa sa, master mstr, Env.list Env.string slaves) of
 239                       (SOME sa, SOME mstr, SOME slaves) =>
 240                       SOME (UseDns {soa = sa,
 241                                     master = mstr,
 242                                     slaves = slaves})
 243                     | _ => NONE)
 244                | (EVar "noDns", _) => SOME NoDns
 245                | _ => NONE
 246
 247 val befores = ref (fn (_ : string) => ())
 248 val afters = ref (fn (_ : string) => ())
 249
 250 fun registerBefore f =
 251     let
 252         val old = !befores
 253     in
 254         befores := (fn x => (old x; f x))
 255     end
 256
 257 fun registerAfter f =
 258     let
 259         val old = !afters
 260     in
 261         afters := (fn x => (old x; f x))
 262     end
 263
 264 val current = ref ""
 265 val currentPath = ref (fn (_ : string) => "")
 266
 267 val scratch = ref ""
 268
 269 fun currentDomain () = !current
 270
 271 fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*)
 272                                TextIO.openOut (!currentPath node ^ name))
 273
 274 fun getPath domain =
 275     let
 276         val toks = String.fields (fn ch => ch = #".") domain
 277
 278         val elems = foldr (fn (piece, elems) =>
 279                               let
 280                                   val elems = piece :: elems
 281
 282                                   fun doNode node =
 283                                       let
 284                                           val path = String.concatWith "/"
 285                                                                        (Config.resultRoot :: node :: rev elems)
 286                                           val tmpPath = String.concatWith "/"
 287                                                                           (Config.tmpDir :: node :: rev elems)
 288                                       in
 289                                           (if Posix.FileSys.ST.isDir
 290                                                   (Posix.FileSys.stat path) then
 291                                                ()
 292                                            else
 293                                                (OS.FileSys.remove path;
 294                                                 OS.FileSys.mkDir path))
 295                                           handle OS.SysErr _ => OS.FileSys.mkDir path;
 296
 297                                           (if Posix.FileSys.ST.isDir
 298                                                   (Posix.FileSys.stat tmpPath) then
 299                                                ()
 300                                            else
 301                                                (OS.FileSys.remove tmpPath;
 302                                                 OS.FileSys.mkDir tmpPath))
 303                                           handle OS.SysErr _ => OS.FileSys.mkDir tmpPath
 304                                       end
 305                               in
 306                                   app doNode nodes;
 307                                   elems
 308                               end) [] toks
 309     in
 310         fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
 311     end
 312
 313 datatype file_action' =
 314          Add' of {src : string, dst : string}
 315        | Delete' of string
 316        | Modify' of {src : string, dst : string}
 317
 318 fun findDiffs (site, dom, acts) =
 319     let
 320         val gp = getPath dom
 321         val realPath = gp (Config.resultRoot, site)
 322         val tmpPath = gp (Config.tmpDir, site)
 323
 324         (*val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n")*)
 325
 326         val dir = Posix.FileSys.opendir realPath
 327
 328         fun loopReal acts =
 329             case Posix.FileSys.readdir dir of
 330                 NONE => (Posix.FileSys.closedir dir;
 331                          acts)
 332               | SOME fname =>
 333                 let
 334                     val real = OS.Path.joinDirFile {dir = realPath,
 335                                                     file = fname}
 336                     val tmp = OS.Path.joinDirFile {dir = tmpPath,
 337                                                    file = fname}
 338                 in
 339                     if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
 340                         loopReal acts
 341                     else if Posix.FileSys.access (tmp, []) then
 342                         if Slave.shell [Config.diff, " ", real, " ",  tmp] then
 343                             loopReal acts
 344                         else
 345                             loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
 346                     else
 347                         loopReal ((site, dom, realPath, Delete' real) :: acts)
 348                 end
 349
 350         val acts = loopReal acts
 351
 352         val dir = Posix.FileSys.opendir tmpPath
 353
 354         fun loopTmp acts =
 355             case Posix.FileSys.readdir dir of
 356                 NONE => (Posix.FileSys.closedir dir;
 357                          acts)
 358               | SOME fname =>
 359                 let
 360                     val real = OS.Path.joinDirFile {dir = realPath,
 361                                                     file = fname}
 362                     val tmp = OS.Path.joinDirFile {dir = tmpPath,
 363                                                    file = fname}
 364                 in
 365                     if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
 366                         loopTmp acts
 367                     else if Posix.FileSys.access (real, []) then
 368                         loopTmp acts
 369                     else
 370                         loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
 371                 end
 372
 373         val acts = loopTmp acts
 374     in
 375         acts
 376     end
 377
 378 fun findAllDiffs () =
 379     let
 380         val dir = Posix.FileSys.opendir Config.tmpDir
 381         val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1
 382
 383         fun exploreSites diffs =
 384             case Posix.FileSys.readdir dir of
 385                 NONE => diffs
 386               | SOME site =>
 387                 let
 388                     fun explore (dname, diffs) =
 389                         let
 390                             val dir = Posix.FileSys.opendir dname
 391
 392                             fun loop diffs =
 393                                 case Posix.FileSys.readdir dir of
 394                                     NONE => diffs
 395                                   | SOME name =>
 396                                     let
 397                                         val fname = OS.Path.joinDirFile {dir = dname,
 398                                                                          file = name}
 399                                     in
 400                                         loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then
 401                                                   let
 402                                                       val dom = String.fields (fn ch => ch = #"/") fname
 403                                                       val dom = List.drop (dom, len)
 404                                                       val dom = String.concatWith "." (rev dom)
 405
 406                                                       val dname' = OS.Path.joinDirFile {dir = dname,
 407                                                                                         file = name}
 408                                                   in
 409                                                       explore (dname',
 410                                                                findDiffs (site, dom, diffs))
 411                                                   end
 412                                               else
 413                                                   diffs)
 414                                     end
 415                         in
 416                             loop diffs
 417                             before Posix.FileSys.closedir dir
 418                         end
 419                 in
 420                     exploreSites (explore (OS.Path.joinDirFile {dir = Config.tmpDir,
 421                                                                 file = site}, diffs))
 422                 end
 423     in
 424         exploreSites []
 425         before Posix.FileSys.closedir dir
 426     end
 427
 428 val masterNode : string option ref = ref NONE
 429 fun dnsMaster () = !masterNode
 430
 431 val _ = Env.containerV_one "domain"
 432                            ("domain", Env.string)
 433                            (fn (evs, dom) =>
 434                                let
 435                                    val kind = Env.env dnsKind (evs, "DNS")
 436                                    val ttl = Env.env Env.int (evs, "TTL")
 437
 438                                    val path = getPath dom
 439
 440                                    val () = (current := dom;
 441                                              currentPath := (fn site => path (Config.tmpDir, site)))
 442
 443                                    fun saveSoa (kind, soa : soa) node =
 444                                        let
 445                                            val outf = domainFile {node = node, name = "soa"}
 446                                        in
 447                                            TextIO.output (outf, kind);
 448                                            TextIO.output (outf, "\n");
 449                                            TextIO.output (outf, Int.toString ttl);
 450                                            TextIO.output (outf, "\n");
 451                                            TextIO.output (outf, #ns soa);
 452                                            TextIO.output (outf, "\n");
 453                                            case #serial soa of
 454                                                NONE => ()
 455                                              | SOME n => TextIO.output (outf, Int.toString n);
 456                                            TextIO.output (outf, "\n");
 457                                            TextIO.output (outf, Int.toString (#ref soa));
 458                                            TextIO.output (outf, "\n");
 459                                            TextIO.output (outf, Int.toString (#ret soa));
 460                                            TextIO.output (outf, "\n");
 461                                            TextIO.output (outf, Int.toString (#exp soa));
 462                                            TextIO.output (outf, "\n");
 463                                            TextIO.output (outf, Int.toString (#min soa));
 464                                            TextIO.output (outf, "\n");
 465                                            TextIO.closeOut outf
 466                                        end
 467
 468                                    fun saveNamed (kind, soa : soa, masterIp) node =
 469                                        let
 470                                            val outf = domainFile {node = node, name = "named.conf"}
 471                                        in
 472                                            TextIO.output (outf, "\nzone \"");
 473                                            TextIO.output (outf, dom);
 474                                            TextIO.output (outf, "\" IN {\n\ttype ");
 475                                            TextIO.output (outf, kind);
 476                                            TextIO.output (outf, ";\n\tfile \"");
 477                                            TextIO.output (outf, Config.Bind.zonePath_real);
 478                                            TextIO.output (outf, "/");
 479                                            TextIO.output (outf, dom);
 480                                            TextIO.output (outf, ".zone\";\n");
 481                                            case kind of
 482                                                "master" => TextIO.output (outf, "\tallow-update { none; };\n")
 483                                              | _ => (TextIO.output (outf, "\tmasters { ");
 484                                                      TextIO.output (outf, masterIp);
 485                                                      TextIO.output (outf, " };\n"));
 486                                            TextIO.output (outf, "};\n");
 487                                            TextIO.closeOut outf
 488                                        end
 489                                in
 490                                    case kind of
 491                                        NoDns => masterNode := NONE
 492                                      | UseDns dns =>
 493                                        let
 494                                            val masterIp =
 495                                                case #master dns of
 496                                                    InternalMaster node => valOf (SM.find (nodeMap, node))
 497                                                  | ExternalMaster ip => ip
 498                                        in
 499                                            app (saveSoa ("slave", #soa dns)) (#slaves dns);
 500                                            app (saveNamed ("slave", #soa dns, masterIp)) (#slaves dns);
 501                                            case #master dns of
 502                                                InternalMaster node =>
 503                                                (masterNode := SOME node;
 504                                                 saveSoa ("master", #soa dns) node;
 505                                                 saveNamed ("master", #soa dns, masterIp) node)
 506                                              | _ => masterNode := NONE;
 507                                            !befores dom
 508                                        end
 509                                end,
 510                             fn () => !afters (!current))
 511
 512 val () = Env.registerPre (fn () => (ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
 513                                                        fn cl => "Temp file cleanup failed: " ^ cl));
 514                                     OS.FileSys.mkDir Config.tmpDir;
 515                                     app (fn node => OS.FileSys.mkDir
 516                                                         (OS.Path.joinDirFile {dir = Config.tmpDir,
 517                                                                               file = node}))
 518                                         nodes;
 519                                     app (fn node => OS.FileSys.mkDir
 520                                                         (OS.Path.joinDirFile {dir = Config.resultRoot,
 521                                                                               file = node})
 522                                             handle OS.SysErr _ => ())
 523                                         nodes))
 524
 525 val () = Env.registerPost (fn () =>
 526                               let
 527                                   val diffs = findAllDiffs ()
 528
 529                                   val diffs = map (fn (site, dom, dir, Add' {src, dst}) =>
 530                                                       (Slave.shellF ([Config.cp, " ", src, " ", dst],
 531                                                                   fn cl => "Copy failed: " ^ cl);
 532                                                        (site,
 533                                                         {action = Slave.Add,
 534                                                          domain = dom,
 535                                                          dir = dir,
 536                                                          file = dst}))
 537                                                     | (site, dom, dir, Delete' dst) =>
 538                                                       (OS.FileSys.remove dst
 539                                                        handle OS.SysErr _ =>
 540                                                               ErrorMsg.error NONE ("Delete failed for " ^ dst);
 541                                                        (site,
 542                                                         {action = Slave.Delete,
 543                                                          domain = dom,
 544                                                          dir = dir,
 545                                                          file = dst}))
 546                                                     | (site, dom, dir, Modify' {src, dst}) =>
 547                                                       (Slave.shellF ([Config.cp, " ", src, " ", dst],
 548                                                                   fn cl => "Copy failed: " ^ cl);
 549                                                        (site,
 550                                                         {action = Slave.Modify,
 551                                                          domain = dom,
 552                                                          dir = dir,
 553                                                          file = dst}))) diffs
 554                               in
 555                                   if !ErrorMsg.anyErrors then
 556                                       ()
 557                                   else let
 558                                           val changed = foldl (fn ((site, file), changed) =>
 559                                                                   let
 560                                                                       val ls = case SM.find (changed, site) of
 561                                                                                    NONE => []
 562                                                                                  | SOME ls => ls
 563                                                                   in
 564                                                                       SM.insert (changed, site, file :: ls)
 565                                                                   end) SM.empty diffs
 566
 567                                           fun handleSite (site, files) =
 568                                               let
 569
 570                                               in
 571                                                   print ("New configuration for node " ^ site ^ "\n");
 572                                                   if site = Config.defaultNode then
 573                                                       Slave.handleChanges files
 574                                                   else let
 575                                                           val bio = OpenSSL.connect (valOf (!ssl_context),
 576                                                                                      nodeIp site
 577                                                                                      ^ ":"
 578                                                                                      ^ Int.toString Config.slavePort)
 579                                                       in
 580                                                           app (fn file => Msg.send (bio, MsgFile file)) files;
 581                                                           Msg.send (bio, MsgDoFiles);
 582                                                           case Msg.recv bio of
 583                                                               NONE => print "Slave closed connection unexpectedly\n"
 584                                                             | SOME m =>
 585                                                               case m of
 586                                                                   MsgOk => print ("Slave " ^ site ^ " finished\n")
 587                                                                 | MsgError s => print ("Slave " ^ site
 588                                                                                        ^ " returned error: " ^
 589                                                                                        s ^ "\n")
 590                                                                 | _ => print ("Slave " ^ site
 591                                                                               ^ " returned unexpected command\n");
 592                                                           OpenSSL.close bio
 593                                                       end
 594                                               end
 595                                       in
 596                                           SM.appi handleSite changed
 597                                       end;
 598                                   ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
 599                                                      fn cl => "Temp file cleanup failed: " ^ cl))
 600                               end)
 601
 602 end