From cfedb9220fc5a849df6d5d85cc929d1f72ac0326 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Mon, 18 Feb 2008 16:38:00 +0000 Subject: [PATCH] bind_patterns --- lib/bind.dtl | 21 ++++++++----- lib/easy_domain.dtl | 20 ++++++------ src/plugins/bind.sml | 72 ++++++++++++++++++-------------------------- 3 files changed, 52 insertions(+), 61 deletions(-) diff --git a/lib/bind.dtl b/lib/bind.dtl index 151c410..8515154 100644 --- a/lib/bind.dtl +++ b/lib/bind.dtl @@ -5,17 +5,22 @@ extern type dnsRecord; extern type srv_domain; {{Like domain, 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 vhost 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 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 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}; diff --git a/lib/easy_domain.dtl b/lib/easy_domain.dtl index 6bc84eb..2f8c0ab 100644 --- a/lib/easy_domain.dtl +++ b/lib/easy_domain.dtl @@ -7,7 +7,7 @@ val webAt = \ 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] @@ -22,7 +22,7 @@ val webAtIp = \ 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] @@ -51,7 +51,7 @@ val dom = 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"); @@ -74,11 +74,11 @@ val dom = 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 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 --- a/src/plugins/bind.sml +++ b/src/plugins/bind.sml @@ -44,25 +44,39 @@ 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 - | DefaultTXT of string + | AAAA of host * string + | TXT of host * 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), _) => - (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), _) => @@ -71,20 +85,14 @@ 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 (host e1, Env.string e2) of (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), _) => @@ -104,22 +112,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); @@ -140,34 +140,20 @@ 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") - | 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); -- 2.20.1