BIND
[hcoop/domtool2.git] / src / domain.sml
index 32b7ecf..6b645cb 100644 (file)
 
 structure Domain :> DOMAIN = struct
 
+fun validIp s =
+    case map Int.fromString (String.fields (fn ch => ch = #".") s) of
+       [SOME n1, SOME n2, SOME n3, SOME n4] =>
+       n1 >= 0 andalso n1 < 256 andalso n2 >= 0 andalso n2 < 256 andalso n3 >= 0 andalso n3 < 256 andalso n4 >= 0 andalso n4 < 256
+      | _ => false
+
+fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
+
+fun validHost s =
+    size s > 0 andalso size s < 20
+    andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s
+
+fun validDomain s =
+    size s > 0 andalso size s < 100
+    andalso List.all validHost (String.fields (fn ch => ch = #".") s)
+
+val _ = Env.type_one "ip"
+       Env.string
+       validIp
+
+val _ = Env.type_one "host"
+       Env.string
+       validHost
+
+val _ = Env.type_one "domain"
+       Env.string
+       validDomain
+
 open Ast
 
+val dl = ErrorMsg.dummyLoc
+
+val nsD = (EString Config.defaultNs, dl)
+val serialD = (EVar "serialAuto", dl)
+val refD = (EInt Config.defaultRefresh, dl)
+val retD = (EInt Config.defaultRetry, dl)
+val expD = (EInt Config.defaultExpiry, dl)
+val minD = (EInt Config.defaultMinimum, dl)
+
+val soaD = multiApp ((EVar "soa", dl),
+                    dl,
+                    [nsD, serialD, refD, retD, expD, minD])
+
+val _ = Main.registerDefault ("DNS",
+                             (TBase "dnsKind", dl),
+                             (EApp ((EVar "master", dl),
+                                    soaD), dl))
+
+val _ = Main.registerDefault ("TTL",
+                             (TBase "int", dl),
+                             (EInt Config.Bind.defaultTTL, dl))
+
+type soa = {ns : string,
+           serial : int option,
+           ref : int,
+           ret : int,
+           exp : int,
+           min : int}
+
+val serial = fn (EVar "serialAuto", _) => SOME NONE
+             | (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
+             | _ => NONE
+
+val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp 
+                                                    ((EVar "soa", _), ns), _),
+                                               sl), _),
+                                        rf), _),
+                                 ret), _),
+                          exp), _),
+                   min), _) =>
+            (case (Env.string ns, serial sl, Env.int rf,
+                   Env.int ret, Env.int exp, Env.int min) of
+                 (SOME ns, SOME sl, SOME rf,
+                  SOME ret, SOME exp, SOME min) =>
+                 SOME {ns = ns,
+                       serial = sl,
+                       ref = rf,
+                       ret = ret,
+                       exp = exp,
+                       min = min}
+               | _ => NONE)
+          | _ => NONE
+
+datatype dnsKind =
+        Master of soa
+       | Slave of soa
+       | NoDns
+
+val dnsKind = fn (EApp ((EVar "master", _), e), _) => Option.map Master (soa e)
+              | (EApp ((EVar "slave", _), e), _) => Option.map Slave (soa e)
+              | (EVar "noDns", _) => SOME NoDns
+              | _ => NONE
+
 val befores = ref (fn (_ : string) => ())
 val afters = ref (fn (_ : string) => ())
 
@@ -42,6 +133,8 @@ fun registerAfter f =
 val current = ref ""
 val currentPath = ref ""
 
+val scratch = ref ""
+
 fun currentDomain () = !current
 
 fun domainFile name = TextIO.openOut (!currentPath ^ name)
@@ -53,7 +146,8 @@ fun getPath domain =
        val elems = foldr (fn (piece, elems) =>
                              let
                                  val elems = piece :: elems
-                                 val path = String.concatWith "/" (Config.configRoot :: rev elems)
+                                 val path = String.concatWith "/" (Config.resultRoot :: rev elems)
+                                 val tmpPath = String.concatWith "/" (Config.tmpDir :: rev elems)
                              in
                                  (if Posix.FileSys.ST.isDir
                                          (Posix.FileSys.stat path) then
@@ -62,18 +156,188 @@ fun getPath domain =
                                       (OS.FileSys.remove path;
                                        OS.FileSys.mkDir path))
                                  handle OS.SysErr _ => OS.FileSys.mkDir path;
+
+                                 (if Posix.FileSys.ST.isDir
+                                         (Posix.FileSys.stat tmpPath) then
+                                      ()
+                                  else
+                                      (OS.FileSys.remove tmpPath;
+                                       OS.FileSys.mkDir tmpPath))
+                                 handle OS.SysErr _ => OS.FileSys.mkDir tmpPath;
+
                                  elems
                              end) [] toks
     in
-       String.concatWith "/" (Config.configRoot :: rev elems)
+       fn root => String.concatWith "/" (root :: rev ("" :: elems))
     end
 
-val _ = Env.registerContainer ("domain",
-                           fn (_, [(EString dom, _)]) => (current := dom;
-                                                          currentPath := getPath dom;
-                                                          !befores dom;
-                                                          StringMap.empty)
-                            | _ => Env.badArgs "domain",
-                           fn () => !afters (!current))
+datatype file_action' =
+        Add' of {src : string, dst : string}
+       | Delete' of string
+       | Modify' of {src : string, dst : string}
+
+fun findDiffs dom =
+    let
+       val realPath = getPath dom Config.resultRoot
+       val tmpPath = !currentPath
+
+       val dir = Posix.FileSys.opendir realPath
+
+       fun loopReal acts =
+           case Posix.FileSys.readdir dir of
+               NONE => (Posix.FileSys.closedir dir;
+                        acts)
+             | SOME fname =>
+               let
+                   val real = OS.Path.joinDirFile {dir = realPath,
+                                                   file = fname}
+                   val tmp = OS.Path.joinDirFile {dir = tmpPath,
+                                                  file = fname}
+               in
+                   if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
+                       loopReal acts
+                   else if Posix.FileSys.access (tmp, []) then
+                       if Slave.shell [Config.diff, " ", real, " ",  tmp] then
+                           loopReal acts
+                       else
+                           loopReal (Modify' {src = tmp, dst = real} :: acts)
+                   else
+                       loopReal (Delete' real :: acts)
+               end
+
+       val acts = loopReal []
+
+       val dir = Posix.FileSys.opendir tmpPath
+
+       fun loopTmp acts =
+           case Posix.FileSys.readdir dir of
+               NONE => (Posix.FileSys.closedir dir;
+                        acts)
+             | SOME fname =>
+               let
+                   val real = OS.Path.joinDirFile {dir = realPath,
+                                                   file = fname}
+                   val tmp = OS.Path.joinDirFile {dir = tmpPath,
+                                                  file = fname}
+               in
+                   if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
+                       loopTmp acts
+                   else if Posix.FileSys.access (real, []) then
+                       loopTmp acts
+                   else
+                       loopTmp (Add' {src = tmp, dst = real} :: acts)
+               end
+
+       val acts = loopTmp acts
+    in
+       acts
+    end
+
+val _ = Env.containerV_one "domain"
+                          ("domain", Env.string)
+                          (fn (evs, dom) =>
+                              let
+                                  val kind = Env.env dnsKind (evs, "DNS")
+                                  val ttl = Env.env Env.int (evs, "TTL")
+
+                                  val path = getPath dom Config.tmpDir
+
+                                  val () = (current := dom;
+                                            currentPath := path;
+                                            !befores dom)
+
+                                  fun saveSoa (kind, soa : soa) =
+                                      let
+                                          val outf = domainFile "soa"
+                                      in
+                                          TextIO.output (outf, kind);
+                                          TextIO.output (outf, "\n");
+                                          TextIO.output (outf, Int.toString ttl);
+                                          TextIO.output (outf, "\n");
+                                          TextIO.output (outf, #ns soa);
+                                          TextIO.output (outf, "\n");
+                                          case #serial soa of
+                                              NONE => ()
+                                            | SOME n => TextIO.output (outf, Int.toString n);
+                                          TextIO.output (outf, "\n");
+                                          TextIO.output (outf, Int.toString (#ref soa));
+                                          TextIO.output (outf, "\n");
+                                          TextIO.output (outf, Int.toString (#ret soa));
+                                          TextIO.output (outf, "\n");
+                                          TextIO.output (outf, Int.toString (#exp soa));
+                                          TextIO.output (outf, "\n");
+                                          TextIO.output (outf, Int.toString (#min soa));
+                                          TextIO.output (outf, "\n");
+                                          TextIO.closeOut outf
+                                      end
+
+                                  fun saveNamed (kind, soa : soa) =
+                                      let
+                                          val outf = domainFile "named.conf"
+                                      in
+                                          TextIO.output (outf, "\nzone \"");
+                                          TextIO.output (outf, dom);
+                                          TextIO.output (outf, "\" IN {\n\ttype ");
+                                          TextIO.output (outf, kind);
+                                          TextIO.output (outf, ";\n\tfile \"");
+                                          TextIO.output (outf, Config.Bind.zonePath);
+                                          TextIO.output (outf, "/");
+                                          TextIO.output (outf, dom);
+                                          TextIO.output (outf, ".zone\";\n");
+                                          case kind of
+                                              "master" => TextIO.output (outf, "\tallow-update { none; };\n")
+                                            | _ => TextIO.output (outf, "\tmasters { 1.2.3.4; };\n");
+                                          TextIO.output (outf, "}\n");
+                                          TextIO.closeOut outf
+                                      end
+
+                                  fun saveBoth ks = (saveSoa ks; saveNamed ks)
+                              in
+                                  case kind of
+                                      NoDns => ()
+                                    | Master soa => saveBoth ("master", soa)
+                                    | Slave soa => saveBoth ("slave", soa)
+                              end,
+                           fn () =>
+                              let
+                                  val dom = !current
+                                  val () = !afters dom
+
+                                  val diffs = findDiffs dom
+
+                                  val dir = getPath dom Config.resultRoot
+
+                                  val diffs = map (fn Add' {src, dst} =>
+                                                      (Slave.shellF ([Config.cp, " ", src, " ", dst],
+                                                                  fn cl => "Copy failed: " ^ cl);
+                                                       {action = Slave.Add,
+                                                        domain = dom,
+                                                        dir = dir,
+                                                        file = dst})
+                                                    | Delete' dst =>
+                                                      (OS.FileSys.remove dst
+                                                       handle OS.SysErr _ =>
+                                                              ErrorMsg.error NONE ("Delete failed for " ^ dst);
+                                                       {action = Slave.Delete,
+                                                        domain = dom,
+                                                        dir = dir,
+                                                        file = dst})
+                                                    | Modify' {src, dst} =>
+                                                      (Slave.shellF ([Config.cp, " ", src, " ", dst],
+                                                                  fn cl => "Copy failed: " ^ cl);
+                                                       {action = Slave.Modify,
+                                                        domain = dom,
+                                                        dir = dir,
+                                                        file = dst})) diffs
+                              in
+                                  if !ErrorMsg.anyErrors then
+                                      ()
+                                  else
+                                      Slave.handleChanges diffs;
+                                  ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, "/*"],
+                                                     fn cl => "Temp file cleanup failed: " ^ cl))
+                              end)
+
+
 
 end