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