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