From e0b0abd209a1ecbd9266cfcf8735af171f96869b Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 6 Aug 2006 02:28:41 +0000 Subject: [PATCH] Added concept of multiple nodes --- configDefault/domtool.cfg | 5 +- configDefault/domtool.cfs | 4 + configDefault/exim.cfg | 2 + configDefault/exim.csg | 3 + lib/alias.dtl | 5 +- lib/domain.dtl | 16 ++- lib/exim.dtl | 4 +- src/domain.sig | 8 +- src/domain.sml | 259 +++++++++++++++++++++++++++----------- src/env.sig | 9 ++ src/env.sml | 38 ++++++ src/eval.sml | 3 +- src/plugins/alias.sml | 104 +++++++++------ src/plugins/bind.sml | 69 +++++----- src/plugins/exim.sml | 19 ++- src/slave.sml | 2 +- tests/testAlias.dtl | 2 +- 17 files changed, 392 insertions(+), 160 deletions(-) diff --git a/configDefault/domtool.cfg b/configDefault/domtool.cfg index 4ea0478..20e133f 100644 --- a/configDefault/domtool.cfg +++ b/configDefault/domtool.cfg @@ -1,6 +1,6 @@ val libRoot = "/home/adamc/cvs/domtool2/lib" val resultRoot = "/home/adamc/domtool" -val tmpDir = "/tmp" +val tmpDir = "/tmp/domtool" val cat = "/bin/cat" val cp = "/bin/cp" @@ -13,3 +13,6 @@ val defaultRefresh = 172800 val defaultRetry = 900 val defaultExpiry = 1209600 val defaultMinimum = 3600 + +val nodes = ["this"] +val defaultNode = "this" diff --git a/configDefault/domtool.cfs b/configDefault/domtool.cfs index 87c679e..e7f04aa 100644 --- a/configDefault/domtool.cfs +++ b/configDefault/domtool.cfs @@ -20,3 +20,7 @@ val defaultRefresh : int val defaultRetry : int val defaultExpiry : int val defaultMinimum : int + +(* Names of machines who will receive configuration *) +val nodes : string list +val defaultNode : string diff --git a/configDefault/exim.cfg b/configDefault/exim.cfg index 2a537be..26939fd 100644 --- a/configDefault/exim.cfg +++ b/configDefault/exim.cfg @@ -8,4 +8,6 @@ val reload = "echo \"I would reload exim now.\"" val handleDomains = "/home/adamc/fake/mail" +val aliasTo = ["this"] + end diff --git a/configDefault/exim.csg b/configDefault/exim.csg index 20c0e44..e666016 100644 --- a/configDefault/exim.csg +++ b/configDefault/exim.csg @@ -11,4 +11,7 @@ val reload : string val handleDomains : string (* File to which to write a comma-separate list of domains to handle mail for *) +val aliasTo : string list +(* Default nodes to which alias directives are applied *) + end diff --git a/lib/alias.dtl b/lib/alias.dtl index c591aaf..b7ccae4 100644 --- a/lib/alias.dtl +++ b/lib/alias.dtl @@ -28,8 +28,9 @@ extern val addressesTarget : [email] -> aliasTarget; extern val dropTarget : aliasTarget; {{Silently delete all mail to the associated source.}} -extern val aliasPrim : aliasSource -> aliasTarget -> [Domain]; -{{Request redirection of all mail from the source to the target.}} +extern val aliasPrim : aliasSource -> aliasTarget -> [Domain] {MailNodes: [node]}; +{{Request redirection of all mail from the source to the target, specifying on + which nodes this redirection should be applied.}} val alias = \user -> \email -> aliasPrim (userSource user) (addressTarget email); {{Redirect mail for the user at the current domain to the e-mail address.}} diff --git a/lib/domain.dtl b/lib/domain.dtl index 8edfa72..0f2b1fa 100644 --- a/lib/domain.dtl +++ b/lib/domain.dtl @@ -9,6 +9,9 @@ extern type host; extern type domain; {{An Internet domain name}} +extern type node; +{{The name of a server controlled by domtool}} + context Domain; {{Configuration directives specific to an Internet domain}} @@ -23,11 +26,20 @@ extern type soa; {{DNS start-of-authority record}} extern val soa : domain -> serial -> int -> int -> int -> int -> soa; +extern type master; +{{Information on the master DNS server for a domain}} +extern val externalMaster : ip -> master; +{{A server not controlled by domtool will serve as master.}} +extern val internalMaster : node -> master; +{{A server controlled by domtool will serve as master.}} + extern type dnsKind; {{How should DNS for this domain be handled?}} -extern val master : soa -> dnsKind; -extern val slave : soa -> dnsKind; +extern val useDns : soa -> master -> [node] -> dnsKind; +{{We do want DNS services for this domain. Specify the SOA record, information + on the server in charge of zone data, and a list of slave servers.}} extern val noDns : dnsKind; +{{No DNS services for this domain.}} extern val domain : domain -> Domain => [Root] {DNS : dnsKind, TTL : int}; {{Configure a domain to which you have access rights.}} diff --git a/lib/exim.dtl b/lib/exim.dtl index 1152aef..feb320e 100644 --- a/lib/exim.dtl +++ b/lib/exim.dtl @@ -1,4 +1,4 @@ {{Exim MTA configuration}} -extern val handleMail : [Domain]; -{{The local server should handle mail for this domain.}} +extern val handleMail : [Domain] {MailNodes: [node]}; +{{The specified nodes should handle mail for this domain.}} diff --git a/src/domain.sig b/src/domain.sig index 8c79274..c2ebb95 100644 --- a/src/domain.sig +++ b/src/domain.sig @@ -31,7 +31,11 @@ signature DOMAIN = sig val currentDomain : unit -> string - val domainFile : string -> TextIO.outstream - (* Open one of the current domain's configuration files. *) + val domainFile : {node : string, name : string} -> TextIO.outstream + (* Open one of the current domain's configuration files for a particular + * node. *) + val dnsMaster : unit -> string option + (* Name of the node that is the DNS master for the current domain, if there + * is one *) end diff --git a/src/domain.sml b/src/domain.sml index 6b645cb..d2dfbde 100644 --- a/src/domain.sml +++ b/src/domain.sml @@ -36,6 +36,8 @@ fun validDomain s = size s > 0 andalso size s < 100 andalso List.all validHost (String.fields (fn ch => ch = #".") s) +fun validNode s = List.exists (fn s' => s = s') Config.nodes + val _ = Env.type_one "ip" Env.string validIp @@ -48,6 +50,10 @@ val _ = Env.type_one "domain" Env.string validDomain +val _ = Env.type_one "node" + Env.string + validNode + open Ast val dl = ErrorMsg.dummyLoc @@ -63,10 +69,15 @@ val soaD = multiApp ((EVar "soa", dl), dl, [nsD, serialD, refD, retD, expD, minD]) +val masterD = (EApp ((EVar "internalMaster", dl), + (EString Config.defaultNode, dl)), + dl) + val _ = Main.registerDefault ("DNS", (TBase "dnsKind", dl), - (EApp ((EVar "master", dl), - soaD), dl)) + (multiApp ((EVar "useDns", dl), + dl, + [soaD, masterD, (EList [], dl)]))) val _ = Main.registerDefault ("TTL", (TBase "int", dl), @@ -103,14 +114,30 @@ val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp | _ => NONE) | _ => NONE +datatype master = + ExternalMaster of string + | InternalMaster of string + +val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (Env.string e) + | (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (Env.string e) + | _ => NONE + datatype dnsKind = - Master of soa - | Slave of soa + UseDns of {soa : soa, + master : master, + slaves : string list} | 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 +val dnsKind = fn (EApp ((EApp ((EApp + ((EVar "useDns", _), sa), _), + mstr), _), + slaves), _) => + (case (soa sa, master mstr, Env.list Env.string slaves) of + (SOME sa, SOME mstr, SOME slaves) => + SOME (UseDns {soa = sa, + master = mstr, + slaves = slaves}) + | _ => NONE) | _ => NONE val befores = ref (fn (_ : string) => ()) @@ -131,13 +158,14 @@ fun registerAfter f = end val current = ref "" -val currentPath = ref "" +val currentPath = ref (fn (_ : string) => "") val scratch = ref "" fun currentDomain () = !current -fun domainFile name = TextIO.openOut (!currentPath ^ name) +fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*) + TextIO.openOut (!currentPath node ^ name)) fun getPath domain = let @@ -146,29 +174,36 @@ fun getPath 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; + fun doNode node = + let + val path = String.concatWith "/" + (Config.resultRoot :: node :: rev elems) + val tmpPath = String.concatWith "/" + (Config.tmpDir :: node :: 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 + end + in + app doNode Config.nodes; elems end) [] toks in - fn root => String.concatWith "/" (root :: rev ("" :: elems)) + fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems)) end datatype file_action' = @@ -176,10 +211,13 @@ datatype file_action' = | Delete' of string | Modify' of {src : string, dst : string} -fun findDiffs dom = +fun findDiffs (site, dom, acts) = let - val realPath = getPath dom Config.resultRoot - val tmpPath = !currentPath + val gp = getPath dom + val realPath = gp (Config.resultRoot, site) + val tmpPath = gp (Config.tmpDir, site) + + (*val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n")*) val dir = Posix.FileSys.opendir realPath @@ -200,12 +238,12 @@ fun findDiffs dom = if Slave.shell [Config.diff, " ", real, " ", tmp] then loopReal acts else - loopReal (Modify' {src = tmp, dst = real} :: acts) + loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts) else - loopReal (Delete' real :: acts) + loopReal ((site, dom, realPath, Delete' real) :: acts) end - val acts = loopReal [] + val acts = loopReal acts val dir = Posix.FileSys.opendir tmpPath @@ -225,7 +263,7 @@ fun findDiffs dom = else if Posix.FileSys.access (real, []) then loopTmp acts else - loopTmp (Add' {src = tmp, dst = real} :: acts) + loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts) end val acts = loopTmp acts @@ -233,6 +271,59 @@ fun findDiffs dom = acts end +fun findAllDiffs () = + let + val dir = Posix.FileSys.opendir Config.tmpDir + val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1 + + fun exploreSites diffs = + case Posix.FileSys.readdir dir of + NONE => diffs + | SOME site => + let + fun explore (dname, diffs) = + let + val dir = Posix.FileSys.opendir dname + + fun loop diffs = + case Posix.FileSys.readdir dir of + NONE => diffs + | SOME name => + let + val fname = OS.Path.joinDirFile {dir = dname, + file = name} + in + loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then + let + val dom = String.fields (fn ch => ch = #"/") fname + val dom = List.drop (dom, len) + val dom = String.concatWith "." (rev dom) + + val dname' = OS.Path.joinDirFile {dir = dname, + file = name} + in + explore (dname', + findDiffs (site, dom, diffs)) + end + else + diffs) + end + in + loop diffs + before Posix.FileSys.closedir dir + end + in + explore (OS.Path.joinDirFile {dir = Config.tmpDir, + file = site}, diffs) + end + in + exploreSites [] + before Posix.FileSys.closedir dir + end + +val masterNode : string option ref = ref NONE +fun dnsMaster () = !masterNode + val _ = Env.containerV_one "domain" ("domain", Env.string) (fn (evs, dom) => @@ -240,15 +331,14 @@ val _ = Env.containerV_one "domain" val kind = Env.env dnsKind (evs, "DNS") val ttl = Env.env Env.int (evs, "TTL") - val path = getPath dom Config.tmpDir + val path = getPath dom val () = (current := dom; - currentPath := path; - !befores dom) + currentPath := (fn site => path (Config.tmpDir, site))) - fun saveSoa (kind, soa : soa) = + fun saveSoa (kind, soa : soa) node = let - val outf = domainFile "soa" + val outf = domainFile {node = node, name = "soa"} in TextIO.output (outf, kind); TextIO.output (outf, "\n"); @@ -271,9 +361,9 @@ val _ = Env.containerV_one "domain" TextIO.closeOut outf end - fun saveNamed (kind, soa : soa) = + fun saveNamed (kind, soa : soa) node = let - val outf = domainFile "named.conf" + val outf = domainFile {node = node, name = "named.conf"} in TextIO.output (outf, "\nzone \""); TextIO.output (outf, dom); @@ -294,49 +384,70 @@ val _ = Env.containerV_one "domain" fun saveBoth ks = (saveSoa ks; saveNamed ks) in case kind of - NoDns => () - | Master soa => saveBoth ("master", soa) - | Slave soa => saveBoth ("slave", soa) + NoDns => masterNode := NONE + | UseDns dns => + (app (saveSoa ("slave", #soa dns)) (#slaves dns); + app (saveNamed ("slave", #soa dns)) (#slaves dns); + case #master dns of + InternalMaster node => + (masterNode := SOME node; + saveSoa ("master", #soa dns) node; + saveNamed ("master", #soa dns) node) + | _ => masterNode := NONE); + !befores dom end, - fn () => - let - val dom = !current - val () = !afters dom - - val diffs = findDiffs dom - - val dir = getPath dom Config.resultRoot + fn () => !afters (!current)) + +val () = Env.registerPre (fn () => (ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""], + fn cl => "Temp file cleanup failed: " ^ cl)); + OS.FileSys.mkDir Config.tmpDir; + app (fn node => OS.FileSys.mkDir + (OS.Path.joinDirFile {dir = Config.tmpDir, + file = node})) + Config.nodes; + app (fn node => OS.FileSys.mkDir + (OS.Path.joinDirFile {dir = Config.resultRoot, + file = node}) + handle OS.SysErr _ => ()) + Config.nodes)) + +val () = Env.registerPost (fn () => + let + val diffs = findAllDiffs () - val diffs = map (fn Add' {src, dst} => - (Slave.shellF ([Config.cp, " ", src, " ", dst], - fn cl => "Copy failed: " ^ cl); + val diffs = map (fn (site, dom, dir, Add' {src, dst}) => + (Slave.shellF ([Config.cp, " ", src, " ", dst], + fn cl => "Copy failed: " ^ cl); + (site, {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); + file = dst})) + | (site, dom, dir, Delete' dst) => + (OS.FileSys.remove dst + handle OS.SysErr _ => + ErrorMsg.error NONE ("Delete failed for " ^ dst); + (site, {action = Slave.Delete, domain = dom, dir = dir, - file = dst}) - | Modify' {src, dst} => - (Slave.shellF ([Config.cp, " ", src, " ", dst], - fn cl => "Copy failed: " ^ cl); + file = dst})) + | (site, dom, dir, Modify' {src, dst}) => + (Slave.shellF ([Config.cp, " ", src, " ", dst], + fn cl => "Copy failed: " ^ cl); + (site, {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) + file = dst}))) diffs + in + if !ErrorMsg.anyErrors then + () + else + Slave.handleChanges (map #2 diffs); + ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""], + fn cl => "Temp file cleanup failed: " ^ cl)) + end) diff --git a/src/env.sig b/src/env.sig index c196158..477af94 100644 --- a/src/env.sig +++ b/src/env.sig @@ -32,6 +32,12 @@ signature ENV = sig val registerContainer : string * action * (unit -> unit) -> unit val container : string -> (action * (unit -> unit)) option + (* Actions to take before and after evaluating a file *) + val registerPre : (unit -> unit) -> unit + val pre : unit -> unit + val registerPost : (unit -> unit) -> unit + val post : unit -> unit + val badArgs : string * Ast.exp list -> 'a val badArg : string * string * Ast.exp -> 'a @@ -46,6 +52,7 @@ signature ENV = sig val two : string -> string * 'a arg * string * 'b arg -> ('a * 'b -> unit) -> action val oneV : string -> string * 'a arg -> (env_vars * 'a -> unit) -> action + val twoV : string -> string * 'a arg * string * 'b arg -> (env_vars * 'a * 'b -> unit) -> action val env : 'a arg -> env_vars * string -> 'a @@ -55,7 +62,9 @@ signature ENV = sig val action_one : string -> string * 'a arg -> ('a -> unit) -> unit val action_two : string -> string * 'a arg * string * 'b arg -> ('a * 'b -> unit) -> unit + val actionV_none : string -> (env_vars -> unit) -> unit val actionV_one : string -> string * 'a arg -> (env_vars * 'a -> unit) -> unit + val actionV_two : string -> string * 'a arg * string * 'b arg -> (env_vars * 'a * 'b -> unit) -> unit val container_none : string -> (unit -> unit) * (unit -> unit) -> unit val container_one : string -> string * 'a arg -> ('a -> unit) * (unit -> unit) -> unit diff --git a/src/env.sml b/src/env.sml index 91fb69d..167adce 100644 --- a/src/env.sml +++ b/src/env.sml @@ -41,6 +41,34 @@ fun registerContainer (name, befor, after) = containers := SM.insert (!containers, name, (befor, after)) fun container name = SM.find (!containers, name) +local + val pr = ref (fn () => ()) +in + +fun registerPre f = + let + val old = !pr + in + pr := (fn () => (old (); f ())) + end +fun pre () = !pr () + +end + +local + val pst = ref (fn () => ()) +in + +fun registerPost f = + let + val old = !pst + in + pst := (fn () => (old (); f ())) + end +fun post () = !pst () + +end + fun badArgs (name, args) = (print ("Invalid arguments to " ^ name ^ "\n"); app (fn arg => Print.preface ("Argument: ", Print.p_exp arg)) args; @@ -97,6 +125,14 @@ fun oneV func (name, arg) f (evs, [e]) = SM.empty)) | oneV func _ _ (_, es) = badArgs (func, es) +fun twoV func (name1, arg1, name2, arg2) f (evs, [e1, e2]) = + (case (arg1 e1, arg2 e2) of + (NONE, _) => badArg (func, name1, e1) + | (_, NONE) => badArg (func, name2, e2) + | (SOME v1, SOME v2) => (f (evs, v1, v2); + SM.empty)) + | twoV func _ _ (_, es) = badArgs (func, es) + fun env arg (evs, name) = case SM.find (evs, name) of @@ -116,7 +152,9 @@ fun action_none name f = registerAction (name, none name f) fun action_one name args f = registerAction (name, one name args f) fun action_two name args f = registerAction (name, two name args f) +fun actionV_none name f = registerAction (name, fn (env, _) => (f env; env)) fun actionV_one name args f = registerAction (name, oneV name args f) +fun actionV_two name args f = registerAction (name, twoV name args f) fun container_none name (f, g) = registerContainer (name, none name f, g) fun container_one name args (f, g) = registerContainer (name, one name args f, g) diff --git a/src/eval.sml b/src/eval.sml index 37a5d63..232a8aa 100644 --- a/src/eval.sml +++ b/src/eval.sml @@ -103,9 +103,10 @@ fun exec evs e = | SOME action => action (evs, args) end + val _ = Env.pre () val evs' = exec' evs e in - () + Env.post () end end diff --git a/src/plugins/alias.sml b/src/plugins/alias.sml index 9449f2b..6d6ab43 100644 --- a/src/plugins/alias.sml +++ b/src/plugins/alias.sml @@ -22,22 +22,41 @@ structure Alias :> ALIAS = struct open Ast -val aliases : TextIO.outstream option ref = ref NONE -fun aliasesF () = valOf (!aliases) +structure SM = DataStructures.StringMap -val aliasesD : TextIO.outstream option ref = ref NONE -fun aliasesDF () = valOf (!aliasesD) +val aliases : TextIO.outstream SM.map ref = ref SM.empty +fun aliasesF node = valOf (SM.find (!aliases, node)) -fun write s = TextIO.output (aliasesF (), s) -fun writeD s = TextIO.output (aliasesDF (), s) +val aliasesD : TextIO.outstream SM.map ref = ref SM.empty +fun aliasesDF node = valOf (SM.find (!aliasesD, node)) + +fun write nodes = + let + val files = map (fn node => aliasesF node) nodes + in + fn s => app (fn file => TextIO.output (file, s)) files + end + +fun writeD nodes = + let + val files = map (fn node => aliasesDF node) nodes + in + fn s => app (fn file => TextIO.output (file, s)) files + end + +fun openInAll base = foldl (fn (node, r) => + SM.insert (r, + node, + Domain.domainFile {node = node, name = base})) + SM.empty Config.nodes val _ = Domain.registerBefore - (fn _ => (aliases := SOME (Domain.domainFile "aliases"); - aliasesD := SOME (Domain.domainFile "aliases.default"))) + (fn _ => (aliases := openInAll "aliases"; + aliasesD := openInAll "aliases.default")) val _ = Domain.registerAfter - (fn _ => (TextIO.closeOut (aliasesF ()); - TextIO.closeOut (aliasesDF ()))) + (fn _ => (SM.app TextIO.closeOut (!aliases); + SM.app TextIO.closeOut (!aliasesD))) fun validEmailUser s = size s > 0 andalso size s < 50 @@ -94,34 +113,41 @@ fun localhostify s = s end -fun writeTarget (outf, t) = - case t of - Address s => TextIO.output (outf, localhostify s) - | Addresses [] => TextIO.output (outf, "!") - | Addresses ss => TextIO.output (outf, String.concatWith "," (map localhostify ss)) - | Drop => TextIO.output (outf, "!") - -fun writeSource (s, t) = - case s of - User s => (write s; - write "@"; - write (Domain.currentDomain ()); - write ": "; - writeTarget (aliasesF (), t); - write "\n") - | Default => (write "*@"; - write (Domain.currentDomain ()); - write ": "; - writeTarget (aliasesF (), t); - write "\n") - | CatchAll => (writeD "*@"; - writeD (Domain.currentDomain ()); - writeD ": "; - writeTarget (aliasesDF (), t); - writeD "\n") - -val _ = Env.action_two "aliasPrim" - ("from", source, "to", target) - writeSource +fun writeSource (env, s, t) = + let + val nodes = Env.env (Env.list Env.string) (env, "MailNodes") + + val write = write nodes + val writeD = writeD nodes + + fun writeTarget (writer, t) = + case t of + Address s => writer (localhostify s) + | Addresses [] => writer "!" + | Addresses ss => writer (String.concatWith "," (map localhostify ss)) + | Drop => writer "!" + in + case s of + User s => (write s; + write "@"; + write (Domain.currentDomain ()); + write ": "; + writeTarget (write, t); + write "\n") + | Default => (write "*@"; + write (Domain.currentDomain ()); + write ": "; + writeTarget (write, t); + write "\n") + | CatchAll => (writeD "*@"; + writeD (Domain.currentDomain ()); + writeD ": "; + writeTarget (writeD, t); + writeD "\n") + end + +val _ = Env.actionV_two "aliasPrim" + ("from", source, "to", target) + writeSource end diff --git a/src/plugins/bind.sml b/src/plugins/bind.sml index d358078..4b09b45 100644 --- a/src/plugins/bind.sml +++ b/src/plugins/bind.sml @@ -32,15 +32,14 @@ val () = Slave.registerPreHandler (fn () => (namedChanged := false; didDomain := "")) val dns : TextIO.outstream option ref = ref NONE -fun dnsF () = valOf (!dns) - -fun write s = TextIO.output (dnsF (), s) val _ = Domain.registerBefore - (fn _ => dns := SOME (Domain.domainFile "dns")) + (fn _ => dns := Option.map (fn node => Domain.domainFile {node = node, + name = "dns"}) + (Domain.dnsMaster ())) val _ = Domain.registerAfter - (fn _ => TextIO.closeOut (dnsF ())) + (fn _ => Option.app TextIO.closeOut (!dns)) val dl = ErrorMsg.dummyLoc @@ -67,39 +66,43 @@ val record = fn (EApp ((EApp ((EVar "dnsA", _), e1), _), e2), _) => | _ => NONE fun writeRecord (evs, r) = - let - val ttl = Env.env Env.int (evs, "TTL") - in - case r of - A (from, to) => (write from; - write "."; - write (Domain.currentDomain ()); - write ".\t"; - write (Int.toString ttl); - write "\tIN\tA\t"; - write to; - write "\n") - | CNAME (from, to) => (write from; + case !dns of + NONE => print "Warning: DNS directive ignored because no master DNS server is configured for this domain\n" + | SOME file => + let + fun write s = TextIO.output (file, s) + val ttl = Env.env Env.int (evs, "TTL") + in + case r of + A (from, to) => (write from; write "."; write (Domain.currentDomain ()); write ".\t"; write (Int.toString ttl); - write "\tIN\tCNAME\t"; + write "\tIN\tA\t"; write to; - write ".\n") - | MX (num, host) => (write "\t"; - write (Int.toString ttl); - write "\tIN\tMX\t"; - write (Int.toString num); - write "\t"; - write host; - write ".\n") - | NS host => (write "\t"; - write (Int.toString ttl); - write "\tIN\tNS\t"; - write host; - write ".\n") - end + write "\n") + | CNAME (from, to) => (write from; + write "."; + write (Domain.currentDomain ()); + write ".\t"; + write (Int.toString ttl); + write "\tIN\tCNAME\t"; + write to; + write ".\n") + | MX (num, host) => (write "\t"; + write (Int.toString ttl); + write "\tIN\tMX\t"; + write (Int.toString num); + write "\t"; + write host; + write ".\n") + | NS host => (write "\t"; + write (Int.toString ttl); + write "\tIN\tNS\t"; + write host; + write ".\n") + end val () = Env.actionV_one "dns" ("record", record) diff --git a/src/plugins/exim.sml b/src/plugins/exim.sml index ee4cf80..a93b732 100644 --- a/src/plugins/exim.sml +++ b/src/plugins/exim.sml @@ -20,6 +20,14 @@ structure Exim :> EXIM = struct +open Ast + +val dl = ErrorMsg.dummyLoc + +val _ = Main.registerDefault ("MailNodes", + (TList (TBase "node", dl), dl), + (EList (map (fn s => (EString s, dl)) Config.Exim.aliasTo), dl)) + val aliasesChanged = ref false val aliasesDefaultChanged = ref false val hostsChanged = ref false @@ -65,7 +73,14 @@ val () = Slave.registerPostHandler ())) -val () = Env.action_none "handleMail" - (fn () => TextIO.closeOut (Domain.domainFile "mail")) +val () = Env.actionV_none "handleMail" + (fn env => + let + val nodes = Env.env (Env.list Env.string) (env, "MailNodes") + in + app (fn node => TextIO.closeOut + (Domain.domainFile {node = node, + name = "mail"})) nodes + end) end diff --git a/src/slave.sml b/src/slave.sml index 144a167..4e44a8b 100644 --- a/src/slave.sml +++ b/src/slave.sml @@ -106,7 +106,7 @@ fun enumerateTo p sep fname = val outf = TextIO.openOut fname val first = ref true - val baseLen = length (String.fields (fn ch => ch = #"/") Config.resultRoot) + val baseLen = length (String.fields (fn ch => ch = #"/") Config.resultRoot) + 1 fun visitDir dname = let diff --git a/tests/testAlias.dtl b/tests/testAlias.dtl index 75ffec8..1f7230c 100644 --- a/tests/testAlias.dtl +++ b/tests/testAlias.dtl @@ -4,5 +4,5 @@ domain "hcoop.net" with aliasDrop "yippo"; defaultAlias "billy"; - catchAllAlias "bonkers" + catchAllAlias "bonkerso" end -- 2.20.1