From: Adam Chlipala Date: Sun, 29 Apr 2007 20:05:52 +0000 (+0000) Subject: Initial domain aliases support X-Git-Tag: release_2010-11-19~229 X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/commitdiff_plain/e0b80e65c8132f096ed5c92e42d4da7d33ff369b Initial domain aliases support --- diff --git a/Makefile b/Makefile index a509c0b..31f72ba 100644 --- a/Makefile +++ b/Makefile @@ -101,32 +101,38 @@ COMMON_MLTON_DEPS := openssl/mlton/FFI/libssl.h.mlb \ src/plugins/*.sig src/plugins/*.sml \ src/mail/*.sig src/mail/*.sml +MLTON := mlton -link-opt -ldl + +ifdef DEBUG + MLTON += -const 'Exn.keepHistory true' +endif + bin/domtool-server: $(COMMON_MLTON_DEPS) src/domtool-server.mlb - mlton -output bin/domtool-server -link-opt -ldl src/domtool-server.mlb + $(MLTON) -output bin/domtool-server src/domtool-server.mlb bin/domtool-client: $(COMMON_MLTON_DEPS) src/domtool-client.mlb - mlton -output bin/domtool-client -link-opt -ldl src/domtool-client.mlb + $(MLTON) -output bin/domtool-client src/domtool-client.mlb bin/domtool-slave: $(COMMON_MLTON_DEPS) src/domtool-slave.mlb - mlton -output bin/domtool-slave -link-opt -ldl src/domtool-slave.mlb + $(MLTON) -output bin/domtool-slave src/domtool-slave.mlb bin/domtool-admin: $(COMMON_MLTON_DEPS) src/domtool-admin.mlb - mlton -output bin/domtool-admin -link-opt -ldl src/domtool-admin.mlb + $(MLTON) -output bin/domtool-admin src/domtool-admin.mlb bin/domtool-doc: $(COMMON_MLTON_DEPS) src/domtool-doc.mlb - mlton -output bin/domtool-doc -link-opt -ldl src/domtool-doc.mlb + $(MLTON) -output bin/domtool-doc src/domtool-doc.mlb bin/dbtool: $(COMMON_MLTON_DEPS) src/dbtool.mlb - mlton -output bin/dbtool -link-opt -ldl src/dbtool.mlb + $(MLTON) -output bin/dbtool src/dbtool.mlb bin/vmail: $(COMMON_MLTON_DEPS) src/vmail.mlb - mlton -output bin/vmail -link-opt -ldl src/vmail.mlb + $(MLTON) -output bin/vmail src/vmail.mlb bin/setsa: $(COMMON_MLTON_DEPS) src/setsa.mlb - mlton -output bin/setsa -link-opt -ldl src/setsa.mlb + $(MLTON) -output bin/setsa -ldl src/setsa.mlb bin/smtplog: $(COMMON_MLTON_DEPS) src/smtplog.mlb - mlton -output bin/smtplog -link-opt -ldl src/smtplog.mlb + $(MLTON) -output bin/smtplog src/smtplog.mlb install: cp scripts/domtool-publish /usr/local/sbin/ diff --git a/lib/domain.dtl b/lib/domain.dtl index 73f03fc..e52b3eb 100644 --- a/lib/domain.dtl +++ b/lib/domain.dtl @@ -75,7 +75,7 @@ extern val useDns : soa -> master -> [dns_node] -> dnsKind; extern val noDns : dnsKind; {{No DNS services for this domain.}} -extern val domain : your_domain -> Domain => [Root] {DNS : dnsKind, TTL : int}; +extern val domain : your_domain -> Domain => [Root] {Aliases : [your_domain], DNS : dnsKind, TTL : int}; {{Configure a domain to which you have access rights.}} extern type mail_node; diff --git a/lib/exim.dtl b/lib/exim.dtl index 3e9e749..a1d5cc6 100644 --- a/lib/exim.dtl +++ b/lib/exim.dtl @@ -2,3 +2,7 @@ extern val handleMail : [Domain] {MailNodes: [mail_node]}; {{The specified nodes should handle mail for this domain.}} + +extern val relayMail : [Domain] {MailNodes: [mail_node]}; +{{The specified nodes should relay mail for this domain. +That is, they should forward it on to authoritative mail servers, not handle it locally.}} diff --git a/src/domain.sig b/src/domain.sig index 83ed63c..b3c06ce 100644 --- a/src/domain.sig +++ b/src/domain.sig @@ -50,6 +50,20 @@ signature DOMAIN = sig (* Open one of the current domain's configuration files for a particular * node. *) + val currentAliasDomains : unit -> string list + val currentDomains : unit -> string list + (* Return the auxiliary domains being configured (not including + * currentDomain) or the list of all domains being configured, + * respectively. *) + + (* The type of a set of files open for different domains. *) + type files = {write : string -> unit, (* Write a string to each. *) + writeDom : unit -> unit, (* Write each's domain name to it. *) + close : unit -> unit} (* Close all files. *) + + val domainsFile : {node : string, name : string} -> files + (* Open a configuration file for every domain being configured. *) + val dnsMaster : unit -> string option (* Name of the node that is the DNS master for the current domain, if there * is one *) diff --git a/src/domain.sml b/src/domain.sml index 7ee4690..ea3d70a 100644 --- a/src/domain.sml +++ b/src/domain.sml @@ -191,6 +191,10 @@ val masterD = (EApp ((EVar "internalMaster", dl), val slavesD = (EList (map (fn s => (EString s, dl)) Config.slaveNodes), dl) +val _ = Defaults.registerDefault ("Aliases", + (TList (TBase "your_domain", dl), dl), + (fn () => (EList [], dl))) + val _ = Defaults.registerDefault ("Mailbox", (TBase "email", dl), (fn () => (EString (getUser ()), dl))) @@ -309,14 +313,34 @@ fun resetLocal () = !locals () val current = ref "" val currentPath = ref (fn (_ : string) => "") +val currentPathAli = ref (fn (_ : string, _ : string) => "") val scratch = ref "" fun currentDomain () = !current +val currentsAli = ref ([] : string list) + +fun currentAliasDomains () = !currentsAli +fun currentDomains () = currentDomain () :: currentAliasDomains () + fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*) TextIO.openOut (!currentPath node ^ name)) +type files = {write : string -> unit, + writeDom : unit -> unit, + close : unit -> unit} + +fun domainsFile {node, name} = + let + val doms = currentDomains () + val files = map (fn dom => (dom, TextIO.openOut (!currentPathAli (dom, node) ^ name))) doms + in + {write = fn s => app (fn (_, outf) => TextIO.output (outf, s)) files, + writeDom = fn () => app (fn (dom, outf) => TextIO.output (outf, dom)) files, + close = fn () => app (fn (_, outf) => TextIO.closeOut outf) files} + end + fun getPath domain = let val toks = String.fields (fn ch => ch = #".") domain @@ -480,59 +504,62 @@ val _ = Env.containerV_one "domain" let val kind = Env.env dnsKind (evs, "DNS") val ttl = Env.env Env.int (evs, "TTL") + val aliases = Env.env (Env.list Env.string) (evs, "Aliases") val path = getPath dom val () = (current := dom; - currentPath := (fn site => path (Config.tmpDir, site))) + currentsAli := Slave.remove (Slave.removeDups aliases, dom); + currentPath := (fn site => path (Config.tmpDir, site)); + currentPathAli := (fn (dom, site) => getPath dom (Config.tmpDir, site))) fun saveSoa (kind, soa : soa) node = let - val outf = domainFile {node = node, name = "soa"} + val {write, writeDom, close} = domainsFile {node = node, name = "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"); + write kind; + write "\n"; + write (Int.toString ttl); + write "\n"; + write (#ns soa); + write "\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 + | SOME n => write (Int.toString n); + write "\n"; + write (Int.toString (#ref soa)); + write "\n"; + write (Int.toString (#ret soa)); + write "\n"; + write (Int.toString (#exp soa)); + write "\n"; + write (Int.toString (#min soa)); + write "\n"; + close () end fun saveNamed (kind, soa : soa, masterIp) node = if dom = "localhost" then () else let - val outf = domainFile {node = node, name = "named.conf"} + val {write, writeDom, close} = domainsFile {node = node, name = "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_real); - TextIO.output (outf, "/"); - TextIO.output (outf, dom); - TextIO.output (outf, ".zone\";\n"); + write "\nzone \""; + writeDom (); + write "\" IN {\n\ttype "; + write kind; + write ";\n\tfile \""; + write Config.Bind.zonePath_real; + write "/"; + writeDom (); + write ".zone\";\n"; case kind of - "master" => TextIO.output (outf, "\tallow-update { none; };\n") - | _ => (TextIO.output (outf, "\tmasters { "); - TextIO.output (outf, masterIp); - TextIO.output (outf, "; };\n")); - TextIO.output (outf, "};\n"); - TextIO.closeOut outf + "master" => write "\tallow-update { none; };\n" + | _ => (write "\tmasters { "; + write masterIp; + write "; };\n"); + write "};\n"; + close () end in case kind of diff --git a/src/main.sml b/src/main.sml index f7b8346..bea07af 100644 --- a/src/main.sml +++ b/src/main.sml @@ -1253,8 +1253,9 @@ fun service () = OpenSSL.close bio handle OpenSSL.OpenSSL _ => (); loop ()) - | _ => + | e => (print "Unknown exception in main loop!\n"; + app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e); OpenSSL.close bio handle OpenSSL.OpenSSL _ => (); loop ()) diff --git a/src/slave.sig b/src/slave.sig index c1706bf..1a11e51 100644 --- a/src/slave.sig +++ b/src/slave.sig @@ -70,4 +70,7 @@ signature SLAVE = sig val mkDirAll : string -> unit (* [mkDirAll p] creates directory "p", creating all parent directories, as * necessary. *) + + val remove : ''a list * ''a -> ''a list + val removeDups : ''a list -> ''a list end diff --git a/src/slave.sml b/src/slave.sml index 44af4b3..a20f6db 100644 --- a/src/slave.sml +++ b/src/slave.sml @@ -202,4 +202,11 @@ fun inGroup {user, group} = fun mkDirAll dir = ignore (OS.Process.system ("mkdir -p " ^ dir)) +fun remove (ls, x) = List.filter (fn y => y <> x) ls +fun removeDups ls = List.foldr (fn (x, ls) => + if List.exists (fn y => y = x) ls then + ls + else + x :: ls) [] ls + end