bind_patterns

diff --git a/lib/bind.dtl b/lib/bind.dtl
index 151c410..8515154 100644 (file)
--- a/lib/bind.dtl
+++ b/lib/bind.dtl
@@ -5,17 +5,22 @@ extern type dnsRecord;
 extern type srv_domain;
 {{Like <tt>domain</tt>, but may contain underscores}}
 
 extern type srv_domain;
 {{Like <tt>domain</tt>, but may contain underscores}}
 

-extern val dnsA : host -> ip -> dnsRecord;
-extern val dnsAAAA : host -> ipv6 -> dnsRecord;
+extern type bind_pattern;
+{{Ways of describing in which cases a DNS mapping applies}}
+extern val literal : host -> bind_pattern;
+{{A rule applies only to this particular host.}}
+extern val default : bind_pattern;
+{{A rule applies directly to the domain for the current <tt>vhost</tt> block.}}
+extern val wildcard : bind_pattern;
+{{A rule applies to every host within the current domain.}}
+
+extern val dnsA : bind_pattern -> ip -> dnsRecord;
+extern val dnsAAAA : bind_pattern -> ipv6 -> dnsRecord;

 extern val dnsAFSDB : domain -> dnsRecord;
 extern val dnsAFSDB : domain -> dnsRecord;

-extern val dnsCNAME : host -> domain -> dnsRecord;
+extern val dnsCNAME : bind_pattern -> domain -> dnsRecord;

 extern val dnsMX : int -> domain -> dnsRecord;
 extern val dnsNS : domain -> dnsRecord;
 extern val dnsSRV : srv_domain -> int -> int -> int -> domain -> dnsRecord;
 extern val dnsMX : int -> domain -> dnsRecord;
 extern val dnsNS : domain -> dnsRecord;
 extern val dnsSRV : srv_domain -> int -> int -> int -> domain -> dnsRecord;

-extern val dnsTXT : host -> no_newlines -> dnsRecord;
-
-extern val dnsDefaultA : ip -> dnsRecord;
-extern val dnsDefaultAAAA : ipv6 -> dnsRecord;
-extern val dnsDefaultTXT : no_newlines -> dnsRecord;
+extern val dnsTXT : bind_pattern -> no_newlines -> dnsRecord;

 
 extern val dns : dnsRecord -> [Domain] {TTL : int};
 
 extern val dns : dnsRecord -> [Domain] {TTL : int};

diff --git a/lib/easy_domain.dtl b/lib/easy_domain.dtl
index 6bc84eb..2f8c0ab 100644 (file)
--- a/lib/easy_domain.dtl
+++ b/lib/easy_domain.dtl
@@ -7,7 +7,7 @@ val webAt =
   \ n : (web_node) ->
   \ host : (host) ->
   \\ config : Vhost -> begin
   \ n : (web_node) ->
   \ host : (host) ->
   \\ config : Vhost -> begin

-    dns (dnsA host (ip_of_node (web_node_to_node n)));
+    dns (dnsA (literal host) (ip_of_node (web_node_to_node n)));

 
     vhost host where
       WebPlaces = [web_place_default n]
 
     vhost host where
       WebPlaces = [web_place_default n]


@@ -22,7 +22,7 @@ val webAtIp =
   \ ip : (your_ip) ->
   \ host : (host) ->
   \\ config : Vhost -> begin
   \ ip : (your_ip) ->
   \ host : (host) ->
   \\ config : Vhost -> begin

-    dns (dnsA host (your_ip_to_ip ip));
+    dns (dnsA (literal host) (your_ip_to_ip ip));

 
     vhost host where
       WebPlaces = [web_place web_node ip]
 
     vhost host where
       WebPlaces = [web_place web_node ip]


@@ -51,7 +51,7 @@ val dom =
     dns (dnsNS "ns1.hcoop.net");
     dns (dnsNS "ns3.hcoop.net");
 
     dns (dnsNS "ns1.hcoop.net");
     dns (dnsNS "ns3.hcoop.net");
 

-    dns (dnsDefaultA (ip_of_node (web_node_to_node web_node)));
+    dns (dnsA default (ip_of_node (web_node_to_node web_node)));

 
     handleMail;
     dns (dnsMX 1 "deleuze.hcoop.net");
 
     handleMail;
     dns (dnsMX 1 "deleuze.hcoop.net");


@@ -74,11 +74,11 @@ val dom =
   end;
 
 val nameserver = \host -> dns (dnsNS host);
   end;
 
 val nameserver = \host -> dns (dnsNS host);

-val dnsIP = \from -> \to -> dns (dnsA from to);
-val dnsIPv6 = \from -> \to -> dns (dnsAAAA from to);
+val dnsIP = \from -> \to -> dns (dnsA (literal from) to);
+val dnsIPv6 = \from -> \to -> dns (dnsAAAA (literal from) to);

 val dnsMail = \num -> \host -> dns (dnsMX num host);
 val dnsMail = \num -> \host -> dns (dnsMX num host);

-val dnsAlias = \from -> \to -> dns (dnsCNAME from to);
-val dnsDefault = \to -> dns (dnsDefaultA to);
-val dnsDefaultv6 = \to -> dns (dnsDefaultAAAA to);
-val dnsText = \from -> \to -> dns (dnsTXT from to);
-val dnsDefaultText = \to -> dns (dnsDefaultTXT to);
+val dnsAlias = \from -> \to -> dns (dnsCNAME (literal from) to);
+val dnsDefault = \to -> dns (dnsA default to);
+val dnsDefaultv6 = \to -> dns (dnsAAAA default to);
+val dnsText = \from -> \to -> dns (dnsTXT (literal from) to);
+val dnsDefaultText = \to -> dns (dnsTXT default to);

diff --git a/src/plugins/bind.sml b/src/plugins/bind.sml
index 3d79cbf..46bd086 100644 (file)
--- a/src/plugins/bind.sml
+++ b/src/plugins/bind.sml
@@ -44,25 +44,39 @@ val _ = Domain.registerAfter
 
 val dl = ErrorMsg.dummyLoc
 
 
 val dl = ErrorMsg.dummyLoc
 

+datatype host =
+        Literal of string
+       | Wildcard
+       | Default
+

 datatype dns_record =
 datatype dns_record =

-        A of string * string
-       | CNAME of string * string
+        A of host * string
+       | CNAME of host * string

        | MX of int * string
        | NS of 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
+       | AAAA of host * string
+       | TXT of host * string

        | AFSDB of string
        | SRV of string * int * int * int * string
 
        | AFSDB of string
        | SRV of string * int * int * int * string
 

+fun hostS (Literal s) = s ^ "."
+  | hostS Wildcard = "*."
+  | hostS Default = ""
+
+val host = fn (EApp ((EVar "literal", _), e), _) =>
+             Option.map Literal (Env.string e)
+           | (EVar "wildcard", _) =>
+             SOME Wildcard
+           | (EVar "default", _) =>
+             SOME Default
+           | _ => NONE
+

 val record = fn (EApp ((EApp ((EVar "dnsA", _), e1), _), e2), _) =>
 val record = fn (EApp ((EApp ((EVar "dnsA", _), e1), _), e2), _) =>

-               (case (Env.string e1, Domain.ip e2) of
+               (case (host e1, Domain.ip e2) of

                     (SOME v1, SOME v2) => SOME (A (v1, v2))
                   | _ => NONE)
              | (EApp ((EApp ((EVar "dnsCNAME", _), e1), _), e2), _) =>
                     (SOME v1, SOME v2) => SOME (A (v1, v2))
                   | _ => NONE)
              | (EApp ((EApp ((EVar "dnsCNAME", _), e1), _), e2), _) =>

-               (case (Env.string e1, Env.string e2) of
+               (case (host e1, Env.string e2) of

                     (SOME v1, SOME v2) => SOME (CNAME (v1, v2))
                   | _ => NONE)
              | (EApp ((EApp ((EVar "dnsMX", _), e1), _), e2), _) =>
                     (SOME v1, SOME v2) => SOME (CNAME (v1, v2))
                   | _ => NONE)
              | (EApp ((EApp ((EVar "dnsMX", _), e1), _), e2), _) =>


@@ -71,20 +85,14 @@ val record = fn (EApp ((EApp ((EVar "dnsA", _), e1), _), e2), _) =>
                   | _ => NONE)
              | (EApp ((EVar "dnsNS", _), e), _) =>
                Option.map NS (Env.string e)
                   | _ => 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), _) =>
              | (EApp ((EApp ((EVar "dnsAAAA", _), e1), _), e2), _) =>

-               (case (Env.string e1, Env.string e2) of
+               (case (host e1, Env.string e2) of

                     (SOME v1, SOME v2) => SOME (AAAA (v1, v2))
                   | _ => NONE)
                     (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), _) =>
              | (EApp ((EApp ((EVar "dnsTXT", _), e1), _), e2), _) =>

-               (case (Env.string e1, Env.string e2) of
+               (case (host e1, Env.string e2) of

                     (SOME v1, SOME v2) => SOME (TXT (v1, v2))
                   | _ => NONE)
                     (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), _) =>
              | (EApp ((EVar "dnsAFSDB", _), e), _) =>
                Option.map AFSDB (Env.string e)
              | (EApp ((EApp ((EApp ((EApp ((EApp ((EVar "dnsSRV", _), e1), _), e2), _), e3), _), e4), _), e5), _) =>


@@ -104,22 +112,14 @@ fun writeRecord (evs, r) =
            val ttl = Env.env Env.int (evs, "TTL")
        in
            case r of
            val ttl = Env.env Env.int (evs, "TTL")
        in
            case r of

-               A (from, to) => (write from;
-                                write ".";
+               A (from, to) => (write (hostS from);

                                 writeDom ();
                                 write ".\t";
                                 write (Int.toString ttl);
                                 write "\tIN\tA\t";
                                 write to;
                                 write "\n")
                                 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 ".";
+             | CNAME (from, to) => (write (hostS from);

                                     writeDom ();
                                     write ".\t";
                                     write (Int.toString ttl);
                                     writeDom ();
                                     write ".\t";
                                     write (Int.toString ttl);


@@ -140,34 +140,20 @@ fun writeRecord (evs, r) =
                            write "\tIN\tNS\t";
                            write host;
                            write ".\n")
                            write "\tIN\tNS\t";
                            write host;
                            write ".\n")

-             | AAAA (from, to) => (write from;
-                                   write ".";
+             | AAAA (from, to) => (write (hostS from);

                                    writeDom ();
                                    write ".\t";
                                    write (Int.toString ttl);
                                    write "\tIN\tAAAA\t";
                                    write to;
                                    write "\n")
                                    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 ".";
+             | TXT (from, to) => (write (hostS from);

                                   writeDom ();
                                   write ".\t";
                                   write (Int.toString ttl);
                                   write "\tIN\tTXT\t\"";
                                   write (String.translate (fn #"\"" => "\\\"" | ch => str ch) to);
                                   write "\"\n")
                                   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);
              | AFSDB host => (writeDom ();
                               write ".\t";
                               write (Int.toString ttl);