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