From: Adam Chlipala <adamc@hcoop.net>
Date: Sun, 16 Dec 2007 14:55:02 +0000 (+0000)
Subject: Add IPv6 DNS mappings
X-Git-Tag: release_2010-11-19~81
X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/commitdiff_plain/090692f732336ea1d094032821fa121cb54078c4

Add IPv6 DNS mappings
---

diff --git a/lib/bind.dtl b/lib/bind.dtl
index 4f2c3c8..9cbc2fb 100644
--- a/lib/bind.dtl
+++ b/lib/bind.dtl
@@ -3,10 +3,12 @@
 extern type dnsRecord;
 
 extern val dnsA : host -> ip -> dnsRecord;
+extern val dnsAAAA : host -> ipv6 -> dnsRecord;
 extern val dnsCNAME : host -> domain -> dnsRecord;
 extern val dnsMX : int -> domain -> dnsRecord;
 extern val dnsNS : domain -> dnsRecord;
 
 extern val dnsDefaultA : ip -> dnsRecord;
+extern val dnsDefaultAAAA : ipv6 -> dnsRecord;
 
 extern val dns : dnsRecord -> [Domain] {TTL : int};
diff --git a/lib/domain.dtl b/lib/domain.dtl
index 3d9b088..8111c62 100644
--- a/lib/domain.dtl
+++ b/lib/domain.dtl
@@ -8,6 +8,8 @@ extern type no_newlines;
 
 extern type ip;
 {{An IP address}}
+extern type ipv6;
+{{An IPv6 address}}
 
 extern type your_ip;
 extern val your_ip_to_ip : your_ip -> ip;
diff --git a/lib/easy_domain.dtl b/lib/easy_domain.dtl
index 9934be4..8491af0 100644
--- a/lib/easy_domain.dtl
+++ b/lib/easy_domain.dtl
@@ -74,6 +74,8 @@ val dom =
 
 val nameserver = \host -> dns (dnsNS host);
 val dnsIP = \from -> \to -> dns (dnsA from to);
+val dnsIPv6 = \from -> \to -> dns (dnsAAAA from to);
 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);
diff --git a/src/domain.sml b/src/domain.sml
index 94eb077..8384f85 100644
--- a/src/domain.sml
+++ b/src/domain.sml
@@ -80,6 +80,36 @@ fun validIp s =
 	n1 >= 0 andalso n1 < 256 andalso n2 >= 0 andalso n2 < 256 andalso n3 >= 0 andalso n3 < 256 andalso n4 >= 0 andalso n4 < 256
       | _ => false
 
+fun isHexDigit ch = Char.isDigit ch orelse (ord ch >= ord #"a" andalso ord ch <= ord #"f")
+
+fun validIpv6 s =
+    let
+	val fields = String.fields (fn ch => ch = #":") s
+
+	val empties = foldl (fn ("", n) => n + 1
+			      | (_, n) => n) 0 fields
+
+	fun noIpv4 maxLen =
+	    length fields >= 2
+	    andalso length fields <= maxLen
+	    andalso empties <= 1
+	    andalso List.all (fn "" => true
+			       | s => size s <= 4
+				      andalso CharVector.all isHexDigit s) fields
+
+	fun hasIpv4 () =
+	    length fields > 0
+	    andalso
+	    let
+		val maybeIpv4 = List.last fields
+		val theRest = List.take (fields, length fields - 1)
+	    in
+		validIp maybeIpv4 andalso noIpv4 6
+	    end
+    in
+	noIpv4 8 orelse hasIpv4 ()
+    end
+
 fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
 
 fun validHost s =
@@ -143,6 +173,10 @@ val _ = Env.type_one "ip"
 	Env.string
 	validIp
 
+val _ = Env.type_one "ipv6"
+	Env.string
+	validIpv6
+
 val _ = Env.type_one "host"
 	Env.string
 	validHost
diff --git a/src/plugins/bind.sml b/src/plugins/bind.sml
index 20c3c10..89b3938 100644
--- a/src/plugins/bind.sml
+++ b/src/plugins/bind.sml
@@ -50,6 +50,8 @@ datatype dns_record =
        | MX of int * string
        | NS of string
        | DefaultA of string
+       | AAAA of string * string
+       | DefaultAAAA of string
 
 val record = fn (EApp ((EApp ((EVar "dnsA", _), e1), _), e2), _) =>
 		(case (Env.string e1, Domain.ip e2) of
@@ -66,7 +68,13 @@ val record = fn (EApp ((EApp ((EVar "dnsA", _), e1), _), e2), _) =>
 	      | (EApp ((EVar "dnsNS", _), e), _) =>
 		Option.map NS (Env.string e)
 	      | (EApp ((EVar "dnsDefaultA", _), e), _) =>
-		Option.map DefaultA (Env.string 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)
 	      | _ => NONE
 
 fun writeRecord (evs, r) =
@@ -116,6 +124,20 @@ fun writeRecord (evs, r) =
 			    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")
 	end
 
 val () = Env.actionV_one "dns"