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