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