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