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