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                | _ => NONE
 226
 227 val befores = ref (fn (_ : string) => ())
 228 val afters = ref (fn (_ : string) => ())
 229
 230 fun registerBefore f =
 231     let
 232         val old = !befores
 233     in
 234         befores := (fn x => (old x; f x))
 235     end
 236
 237 fun registerAfter f =
 238     let
 239         val old = !afters
 240     in
 241         afters := (fn x => (old x; f x))
 242     end
 243
 244 val current = ref ""
 245 val currentPath = ref (fn (_ : string) => "")
 246
 247 val scratch = ref ""
 248
 249 fun currentDomain () = !current
 250
 251 fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*)
 252                                TextIO.openOut (!currentPath node ^ name))
 253
 254 fun getPath domain =
 255     let
 256         val toks = String.fields (fn ch => ch = #".") domain
 257
 258         val elems = foldr (fn (piece, elems) =>
 259                               let
 260                                   val elems = piece :: elems
 261
 262                                   fun doNode node =
 263                                       let
 264                                           val path = String.concatWith "/"
 265                                                                        (Config.resultRoot :: node :: rev elems)
 266                                           val tmpPath = String.concatWith "/"
 267                                                                           (Config.tmpDir :: node :: rev elems)
 268                                       in
 269                                           (if Posix.FileSys.ST.isDir
 270                                                   (Posix.FileSys.stat path) then
 271                                                ()
 272                                            else
 273                                                (OS.FileSys.remove path;
 274                                                 OS.FileSys.mkDir path))
 275                                           handle OS.SysErr _ => OS.FileSys.mkDir path;
 276
 277                                           (if Posix.FileSys.ST.isDir
 278                                                   (Posix.FileSys.stat tmpPath) then
 279                                                ()
 280                                            else
 281                                                (OS.FileSys.remove tmpPath;
 282                                                 OS.FileSys.mkDir tmpPath))
 283                                           handle OS.SysErr _ => OS.FileSys.mkDir tmpPath
 284                                       end
 285                               in
 286                                   app doNode nodes;
 287                                   elems
 288                               end) [] toks
 289     in
 290         fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
 291     end
 292
 293 datatype file_action' =
 294          Add' of {src : string, dst : string}
 295        | Delete' of string
 296        | Modify' of {src : string, dst : string}
 297
 298 fun findDiffs (site, dom, acts) =
 299     let
 300         val gp = getPath dom
 301         val realPath = gp (Config.resultRoot, site)
 302         val tmpPath = gp (Config.tmpDir, site)
 303
 304         (*val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n")*)
 305
 306         val dir = Posix.FileSys.opendir realPath
 307
 308         fun loopReal acts =
 309             case Posix.FileSys.readdir dir of
 310                 NONE => (Posix.FileSys.closedir dir;
 311                          acts)
 312               | SOME fname =>
 313                 let
 314                     val real = OS.Path.joinDirFile {dir = realPath,
 315                                                     file = fname}
 316                     val tmp = OS.Path.joinDirFile {dir = tmpPath,
 317                                                    file = fname}
 318                 in
 319                     if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
 320                         loopReal acts
 321                     else if Posix.FileSys.access (tmp, []) then
 322                         if Slave.shell [Config.diff, " ", real, " ",  tmp] then
 323                             loopReal acts
 324                         else
 325                             loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
 326                     else
 327                         loopReal ((site, dom, realPath, Delete' real) :: acts)
 328                 end
 329
 330         val acts = loopReal acts
 331
 332         val dir = Posix.FileSys.opendir tmpPath
 333
 334         fun loopTmp acts =
 335             case Posix.FileSys.readdir dir of
 336                 NONE => (Posix.FileSys.closedir dir;
 337                          acts)
 338               | SOME fname =>
 339                 let
 340                     val real = OS.Path.joinDirFile {dir = realPath,
 341                                                     file = fname}
 342                     val tmp = OS.Path.joinDirFile {dir = tmpPath,
 343                                                    file = fname}
 344                 in
 345                     if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
 346                         loopTmp acts
 347                     else if Posix.FileSys.access (real, []) then
 348                         loopTmp acts
 349                     else
 350                         loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
 351                 end
 352
 353         val acts = loopTmp acts
 354     in
 355         acts
 356     end
 357
 358 fun findAllDiffs () =
 359     let
 360         val dir = Posix.FileSys.opendir Config.tmpDir
 361         val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1
 362
 363         fun exploreSites diffs =
 364             case Posix.FileSys.readdir dir of
 365                 NONE => diffs
 366               | SOME site =>
 367                 let
 368                     fun explore (dname, diffs) =
 369                         let
 370                             val dir = Posix.FileSys.opendir dname
 371
 372                             fun loop diffs =
 373                                 case Posix.FileSys.readdir dir of
 374                                     NONE => diffs
 375                                   | SOME name =>
 376                                     let
 377                                         val fname = OS.Path.joinDirFile {dir = dname,
 378                                                                          file = name}
 379                                     in
 380                                         loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then
 381                                                   let
 382                                                       val dom = String.fields (fn ch => ch = #"/") fname
 383                                                       val dom = List.drop (dom, len)
 384                                                       val dom = String.concatWith "." (rev dom)
 385
 386                                                       val dname' = OS.Path.joinDirFile {dir = dname,
 387                                                                                         file = name}
 388                                                   in
 389                                                       explore (dname',
 390                                                                findDiffs (site, dom, diffs))
 391                                                   end
 392                                               else
 393                                                   diffs)
 394                                     end
 395                         in
 396                             loop diffs
 397                             before Posix.FileSys.closedir dir
 398                         end
 399                 in
 400                     explore (OS.Path.joinDirFile {dir = Config.tmpDir,
 401                                                   file = site}, diffs)
 402                 end
 403     in
 404         exploreSites []
 405         before Posix.FileSys.closedir dir
 406     end
 407
 408 val masterNode : string option ref = ref NONE
 409 fun dnsMaster () = !masterNode
 410
 411 val _ = Env.containerV_one "domain"
 412                            ("domain", Env.string)
 413                            (fn (evs, dom) =>
 414                                let
 415                                    val kind = Env.env dnsKind (evs, "DNS")
 416                                    val ttl = Env.env Env.int (evs, "TTL")
 417
 418                                    val path = getPath dom
 419
 420                                    val () = (current := dom;
 421                                              currentPath := (fn site => path (Config.tmpDir, site)))
 422
 423                                    fun saveSoa (kind, soa : soa) node =
 424                                        let
 425                                            val outf = domainFile {node = node, name = "soa"}
 426                                        in
 427                                            TextIO.output (outf, kind);
 428                                            TextIO.output (outf, "\n");
 429                                            TextIO.output (outf, Int.toString ttl);
 430                                            TextIO.output (outf, "\n");
 431                                            TextIO.output (outf, #ns soa);
 432                                            TextIO.output (outf, "\n");
 433                                            case #serial soa of
 434                                                NONE => ()
 435                                              | SOME n => TextIO.output (outf, Int.toString n);
 436                                            TextIO.output (outf, "\n");
 437                                            TextIO.output (outf, Int.toString (#ref soa));
 438                                            TextIO.output (outf, "\n");
 439                                            TextIO.output (outf, Int.toString (#ret soa));
 440                                            TextIO.output (outf, "\n");
 441                                            TextIO.output (outf, Int.toString (#exp soa));
 442                                            TextIO.output (outf, "\n");
 443                                            TextIO.output (outf, Int.toString (#min soa));
 444                                            TextIO.output (outf, "\n");
 445                                            TextIO.closeOut outf
 446                                        end
 447
 448                                    fun saveNamed (kind, soa : soa, masterIp) node =
 449                                        let
 450                                            val outf = domainFile {node = node, name = "named.conf"}
 451                                        in
 452                                            TextIO.output (outf, "\nzone \"");
 453                                            TextIO.output (outf, dom);
 454                                            TextIO.output (outf, "\" IN {\n\ttype ");
 455                                            TextIO.output (outf, kind);
 456                                            TextIO.output (outf, ";\n\tfile \"");
 457                                            TextIO.output (outf, Config.Bind.zonePath);
 458                                            TextIO.output (outf, "/");
 459                                            TextIO.output (outf, dom);
 460                                            TextIO.output (outf, ".zone\";\n");
 461                                            case kind of
 462                                                "master" => TextIO.output (outf, "\tallow-update { none; };\n")
 463                                              | _ => (TextIO.output (outf, "\tmasters { ");
 464                                                      TextIO.output (outf, masterIp);
 465                                                      TextIO.output (outf, " };\n"));
 466                                            TextIO.output (outf, "};\n");
 467                                            TextIO.closeOut outf
 468                                        end
 469                                in
 470                                    case kind of
 471                                        NoDns => masterNode := NONE
 472                                      | UseDns dns =>
 473                                        let
 474                                            val masterIp =
 475                                                case #master dns of
 476                                                    InternalMaster node => valOf (SM.find (nodeMap, node))
 477                                                  | ExternalMaster ip => ip
 478                                        in
 479                                            app (saveSoa ("slave", #soa dns)) (#slaves dns);
 480                                            app (saveNamed ("slave", #soa dns, masterIp)) (#slaves dns);
 481                                            case #master dns of
 482                                                InternalMaster node =>
 483                                                (masterNode := SOME node;
 484                                                 saveSoa ("master", #soa dns) node;
 485                                                 saveNamed ("master", #soa dns, masterIp) node)
 486                                              | _ => masterNode := NONE;
 487                                            !befores dom
 488                                        end
 489                                end,
 490                             fn () => !afters (!current))
 491
 492 val () = Env.registerPreTycheck (fn () => (setUser Config.testUser;
 493                                            Acl.read Config.aclFile;
 494                                            your_doms := Acl.class {user = getUser (),
 495                                                                    class = "domain"};
 496                                            your_usrs := Acl.class {user = getUser (),
 497                                                                    class = "user"};
 498                                            your_grps := Acl.class {user = getUser (),
 499                                                                    class = "group"};
 500                                            your_pths := Acl.class {user = getUser (),
 501                                                                    class = "path"}))
 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