Initial domain aliases support

diff --git a/Makefile b/Makefile
index a509c0b..31f72ba 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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