X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/976657583f419a6a204400ea90f9758d15243acb..c219fe5500b4294ba8dc0bce57b5c7d60b39065e:/src/plugins/bind.sml diff --git a/src/plugins/bind.sml b/src/plugins/bind.sml index 8dc1a72..3d79cbf 100644 --- a/src/plugins/bind.sml +++ b/src/plugins/bind.sml @@ -31,15 +31,15 @@ val () = Slave.registerPreHandler (fn () => (namedChanged := false; zoneChanged := false; didDomain := "")) -val dns : TextIO.outstream option ref = ref NONE +val dns : Domain.files option ref = ref NONE val _ = Domain.registerBefore - (fn _ => dns := Option.map (fn node => Domain.domainFile {node = node, - name = "dns"}) + (fn _ => dns := Option.map (fn node => Domain.domainsFile {node = node, + name = "dns"}) (Domain.dnsMaster ())) val _ = Domain.registerAfter - (fn _ => (Option.app TextIO.closeOut (!dns); + (fn _ => (Option.app (fn files => #close files ()) (!dns); dns := NONE)) val dl = ErrorMsg.dummyLoc @@ -49,6 +49,13 @@ datatype dns_record = | CNAME of string * string | MX of int * string | NS of string + | DefaultA of string + | AAAA of string * string + | DefaultAAAA of string + | TXT of string * string + | DefaultTXT of string + | AFSDB of string + | SRV of string * int * int * int * string val record = fn (EApp ((EApp ((EVar "dnsA", _), e1), _), e2), _) => (case (Env.string e1, Domain.ip e2) of @@ -64,45 +71,125 @@ val record = fn (EApp ((EApp ((EVar "dnsA", _), e1), _), e2), _) => | _ => NONE) | (EApp ((EVar "dnsNS", _), e), _) => Option.map NS (Env.string e) + | (EApp ((EVar "dnsDefaultA", _), e), _) => + Option.map DefaultA (Domain.ip e) + | (EApp ((EApp ((EVar "dnsAAAA", _), e1), _), e2), _) => + (case (Env.string e1, Env.string e2) of + (SOME v1, SOME v2) => SOME (AAAA (v1, v2)) + | _ => NONE) + | (EApp ((EVar "dnsDefaultAAAA", _), e), _) => + Option.map DefaultAAAA (Env.string e) + | (EApp ((EApp ((EVar "dnsTXT", _), e1), _), e2), _) => + (case (Env.string e1, Env.string e2) of + (SOME v1, SOME v2) => SOME (TXT (v1, v2)) + | _ => NONE) + | (EApp ((EVar "dnsDefaultTXT", _), e), _) => + Option.map DefaultTXT (Env.string e) + | (EApp ((EVar "dnsAFSDB", _), e), _) => + Option.map AFSDB (Env.string e) + | (EApp ((EApp ((EApp ((EApp ((EApp ((EVar "dnsSRV", _), e1), _), e2), _), e3), _), e4), _), e5), _) => + (case (Env.string e1, Env.int e2, Env.int e3, Env.int e4, Env.string e5) of + (SOME v1, SOME v2, SOME v3, SOME v4, SOME v5) => SOME (SRV (v1, v2, v3, v4, v5)) + | _ => NONE) | _ => NONE fun writeRecord (evs, r) = case !dns of - NONE => print "Warning: DNS directive ignored because no master DNS server is configured for this domain\n" - | SOME file => + NONE => print ("Warning: DNS directive for " ^ Domain.currentDomain () + ^ " ignored because no master DNS server is configured for this domain\n") + | SOME files => let - fun write s = TextIO.output (file, s) + fun write s = #write files s + fun writeDom () = #writeDom files () val ttl = Env.env Env.int (evs, "TTL") in case r of A (from, to) => (write from; write "."; - write (Domain.currentDomain ()); + writeDom (); write ".\t"; write (Int.toString ttl); write "\tIN\tA\t"; write to; write "\n") + | DefaultA to => (writeDom (); + write ".\t"; + write (Int.toString ttl); + write "\tIN\tA\t"; + write to; + write "\n") | CNAME (from, to) => (write from; write "."; - write (Domain.currentDomain ()); + writeDom (); write ".\t"; write (Int.toString ttl); write "\tIN\tCNAME\t"; write to; write ".\n") - | MX (num, host) => (write "\t"; + | MX (num, host) => (writeDom (); + write ".\t"; write (Int.toString ttl); write "\tIN\tMX\t"; write (Int.toString num); write "\t"; write host; write ".\n") - | NS host => (write "\t"; + | NS host => (writeDom (); + write ".\t"; write (Int.toString ttl); write "\tIN\tNS\t"; write host; write ".\n") + | AAAA (from, to) => (write from; + write "."; + writeDom (); + write ".\t"; + write (Int.toString ttl); + write "\tIN\tAAAA\t"; + write to; + write "\n") + | DefaultAAAA to => (writeDom (); + write ".\t"; + write (Int.toString ttl); + write "\tIN\tAAAA\t"; + write to; + write "\n") + | TXT (from, to) => (write from; + write "."; + writeDom (); + write ".\t"; + write (Int.toString ttl); + write "\tIN\tTXT\t\""; + write (String.translate (fn #"\"" => "\\\"" | ch => str ch) to); + write "\"\n") + | DefaultTXT to => (writeDom (); + write ".\t"; + write (Int.toString ttl); + write "\tIN\tTXT\t\""; + write (String.translate (fn #"\"" => "\\\"" | ch => str ch) to); + write "\"\n") + | AFSDB host => (writeDom (); + write ".\t"; + write (Int.toString ttl); + write "\tIN\tAFSDB\t"; + write "1"; + write "\t"; + write host; + write ".\n") + | SRV (from, priority, weight, port, to) => (write from; + write "."; + writeDom (); + write ".\t"; + write (Int.toString ttl); + write "\tIN\tSRV\t"; + write (Int.toString priority); + write "\t"; + write (Int.toString weight); + write "\t"; + write (Int.toString port); + write "\t"; + write to; + write ".\n") end val () = Env.actionV_one "dns" @@ -116,6 +203,34 @@ fun readLine inf = fun readILine inf = valOf (Int.fromString (readLine inf)) +val monthToInt = fn Date.Jan => 1 + | Date.Feb => 2 + | Date.Mar => 3 + | Date.Apr => 4 + | Date.May => 5 + | Date.Jun => 6 + | Date.Jul => 7 + | Date.Aug => 8 + | Date.Sep => 9 + | Date.Oct => 10 + | Date.Nov => 11 + | Date.Dec => 12 + +fun padBy ch amt s = + if size s < amt then + CharVector.tabulate (amt - size s, fn _ => ch) ^ s + else + s + +fun dateString () = + let + val date = Date.fromTimeUniv (Time.now ()) + in + padBy #"0" 4 (Int.toString (Date.year date)) + ^ padBy #"0" 2 (Int.toString (monthToInt (Date.month date))) + ^ padBy #"0" 2 (Int.toString (Date.day date)) + end + val () = Slave.registerFileHandler (fn fs => let val {dir, file} = OS.Path.splitDirFile (#file fs) @@ -123,7 +238,7 @@ val () = Slave.registerFileHandler (fn fs => fun dnsChanged () = if #domain fs = !didDomain then () - else if #action fs = Slave.Delete then + else if Slave.isDelete (#action fs) then let val fname = OS.Path.joinBaseExt {base = #domain fs, ext = SOME "zone"} @@ -149,6 +264,40 @@ val () = Slave.registerFileHandler (fn fs => val min = readILine inf val () = TextIO.closeIn inf + val serialPath = OS.Path.joinDirFile {dir = Config.serialDir, + file = #domain fs} + + val oldSerial = let + val inf = TextIO.openIn serialPath + in + SOME (readLine inf) + before TextIO.closeIn inf + end handle IO.Io {name, ...} => NONE + + val newSerial = + case serial of + SOME n => Int.toString n + | NONE => + let + val prefix = dateString () + in + prefix + ^ (case oldSerial of + NONE => "00" + | SOME old => + if size old >= 8 andalso + String.substring (old, 0, 8) = prefix then + case Int.fromString (String.extract (old, 8, NONE)) of + NONE => "00" + | SOME old => padBy #"0" 2 (Int.toString (old+1)) + else + "00") + end + + val outf = TextIO.openOut serialPath + val _ = TextIO.output (outf, newSerial) + val _ = TextIO.closeOut outf + val dns = OS.Path.joinDirFile {dir = #dir fs, file = "dns"} @@ -166,8 +315,8 @@ val () = Slave.registerFileHandler (fn fs => TextIO.output (outf, ns); TextIO.output (outf, ".\thostmaster."); TextIO.output (outf, #domain fs); - TextIO.output (outf, ".\n( "); - TextIO.output (outf, Int.toString 123456789); + TextIO.output (outf, ". ( "); + TextIO.output (outf, newSerial); TextIO.output (outf, " "); TextIO.output (outf, Int.toString rf); TextIO.output (outf, " "); @@ -204,4 +353,28 @@ val () = Slave.registerPostHandler fn cl => "Error reloading bind with " ^ cl) else ())) + +val () = Domain.registerResetLocal (fn () => + ignore (OS.Process.system (Config.rm ^ " -rf /var/domtool/zones/*"))) + +val () = Domain.registerDescriber (Domain.considerAll + [Domain.Filename {filename = "named.conf", + heading = "named.conf addition:", + showEmpty = false}, + Domain.Filename {filename = "dns", + heading = "DNS zonefile contents:", + showEmpty = false}]) + +fun validHost_ s = + size s > 0 andalso size s < 20 + andalso CharVector.all (fn ch => Domain.isIdent ch orelse ch = #"-" orelse ch = #"_") s + +fun validSRVDomain s = + size s > 0 andalso size s < 100 + andalso List.all validHost_ (String.fields (fn ch => ch = #".") s) + +val _ = Env.type_one "srv_domain" + Env.string + validSRVDomain + end