X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/f2cf641d13e1588e316468dc7f679d65f4633f26..63ac3b82c1cd33605e62688cd97688a6dae3cb9c:/src/plugins/bind.sml

diff --git a/src/plugins/bind.sml b/src/plugins/bind.sml
index 53c1d04..768478f 100644
--- a/src/plugins/bind.sml
+++ b/src/plugins/bind.sml
@@ -44,22 +44,47 @@ val _ = Domain.registerAfter
 
 val dl = ErrorMsg.dummyLoc
 
+datatype host =
+	 Literal of string
+       | Wildcard
+       | Default
+
 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
-       | DefaultA of string
-       | AAAA of string * string
-       | DefaultAAAA of string
-       | TXT of string * string
+       | AAAA of host * string
+       | TXT of host * string
+       | AFSDB of string
+       | SRV of host * 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 srv_host = fn (EApp ((EVar "srv_literal", _), e), _) =>
+		  Option.map Literal (Env.string e)
+		| (EVar "srv_wildcard", _) =>
+		  SOME Wildcard
+		| (EVar "srv_default", _) =>
+		  SOME Default
+		| _ => NONE
 
 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), _) =>
-		(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), _) =>
@@ -68,18 +93,20 @@ val record = fn (EApp ((EApp ((EVar "dnsA", _), e1), _), e2), _) =>
 		   | _ => 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), _) =>
-		(case (Env.string e1, Env.string e2) of
+		(case (host e1, Env.string e2) of
 		     (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), _) =>
-		(case (Env.string e1, Env.string e2) of
+		(case (srv_host e1, Env.string e2) of
 		     (SOME v1, SOME v2) => SOME (TXT (v1, v2))
 		   | _ => NONE)
+	      | (EApp ((EVar "dnsAFSDB", _), e), _) =>
+		Option.map AFSDB (Env.string e)
+	      | (EApp ((EApp ((EApp ((EApp ((EApp ((EVar "dnsSRV", _), e1), _), e2), _), e3), _), e4), _), e5), _) =>
+		(case (srv_host e1, Env.int e2, Env.int e3, Env.int e4, Env.string e5) of
+		     (SOME v1, SOME v2, SOME v3, SOME v4, SOME v5) => SOME (SRV (v1, v2, v3, v4, v5))
+		   | _ => NONE)
 	      | _ => NONE
 
 fun writeRecord (evs, r) =
@@ -93,22 +120,14 @@ fun writeRecord (evs, r) =
 	    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")
-	      | 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);
@@ -129,28 +148,41 @@ fun writeRecord (evs, r) =
 			    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")
-	      | 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")
+	      | AFSDB host => (writeDom ();
+			       write ".\t";
+			       write (Int.toString ttl);
+			       write "\tIN\tAFSDB\t";
+			       write "1";
+			       write "\t";
+			       write host;
+			       write ".\n")
+	      | SRV (from, priority, weight, port, to) => (write (hostS from);
+							   writeDom ();
+							   write ".\t";
+							   write (Int.toString ttl);
+							   write "\tIN\tSRV\t";
+							   write (Int.toString priority);
+							   write "\t";
+							   write (Int.toString weight);
+							   write "\t";
+							   write (Int.toString port);
+							   write "\t";
+							   write to;
+							   write ".\n")
 	end
 
 val () = Env.actionV_one "dns"
@@ -326,4 +358,20 @@ val () = Domain.registerDescriber (Domain.considerAll
 						     heading = "DNS zonefile contents:",
 						     showEmpty = false}])
 
+fun validSrvHost s =
+    size s > 0 andalso size s < 20
+    andalso CharVector.all (fn ch => Domain.isIdent ch orelse ch = #"-" orelse ch = #"_") s
+
+fun validSrvDomain s =
+    size s > 0 andalso size s < 100
+    andalso List.all validSrvHost (String.fields (fn ch => ch = #".") s)
+
+val _ = Env.type_one "srv_host"
+	Env.string
+	validSrvHost
+
+val _ = Env.type_one "srv_domain"
+	Env.string
+	validSrvDomain
+
 end