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