(* HCoop Domtool (http://hcoop.sourceforge.net/) * Copyright (c) 2006, Adam Chlipala * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *) (* Domain-related primitive actions *) 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) => ()) fun registerBefore f = let val old = !befores in befores := (fn x => (old x; f x)) end fun registerAfter f = let val old = !afters in afters := (fn x => (old x; f x)) end val current = ref "" val currentPath = ref "" val scratch = ref "" fun currentDomain () = !current fun domainFile name = TextIO.openOut (!currentPath ^ name) fun getPath domain = let val toks = String.fields (fn ch => ch = #".") domain val elems = foldr (fn (piece, elems) => let val elems = piece :: 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 () else (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 fn root => String.concatWith "/" (root :: rev ("" :: elems)) end 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