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 < 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
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) => ())
acts
end
-val _ = Env.container_one "domain"
- ("domain", Env.string)
- (fn dom =>
- let
- val path = getPath dom Config.tmpDir
- in
- current := dom;
- currentPath := path;
- !befores dom
- end,
- fn () =>
- let
- val dom = !current
- val () = !afters dom
-
- val diffs = findDiffs dom
-
- val diffs = map (fn Add' {src, dst} =>
- (Slave.shellF ([Config.cp, " ", src, " ", dst],
- fn cl => "Copy failed: " ^ cl);
- {action = Slave.Add,
- domain = dom,
- file = dst})
- | Delete' dst =>
- (OS.FileSys.remove dst
- handle OS.SysErr _ =>
- ErrorMsg.error NONE ("Delete failed for " ^ dst);
- {action = Slave.Delete,
- domain = dom,
- file = dst})
- | Modify' {src, dst} =>
- (Slave.shellF ([Config.cp, " ", src, " ", dst],
- fn cl => "Copy failed: " ^ cl);
- {action = Slave.Modify,
- domain = dom,
- 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)
+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
HCoop / hcoop / domtool2.git / blobdiff