Patch title: Release 94 bulk changes
Abstract:
File: /pliant/protocol/dns/server.pli
Key:
    Removed line
    Added line
abstract
  [This is a partial DNS server implementation, according to RFC 1035.]


module "/pliant/install/minimal.pli"
module "/pliant/language/compiler.pli"
submodule "/pliant/protocol/common/tcp_server.pli"
module "/pliant/protocol/common/misc.pli"
module "/pliant/language/stream.pli"
module "/pliant/fullpliant/this_computer.pli"
module "common.pli"
module "name.pli"
module "/pliant/protocol/http/proxy.pli"
module "/pliant/protocol/http/site.pli"

module "/pliant/language/context.pli"
module "/pliant/language/schedule/resourcesem.pli"

(gvar TraceSlot dns_trace) configure "DNS server"


type DnsServer
  tcp_server_fields "DNS" 53
  field CBool please_stop_udp
  field ResourceSem resource
  public
    field Str cache
    field Str default
    field Int parallel <- (constant (max (min (cast memory_assigned\2^20 Int) 1024) 64))
TcpServer maybe DnsServer


gvar Int dns_refresh := 24*3600 # in seconds
gvar Int dns_hits := 0


#-------------------------------------------------------------------

doc
  [A few utility functions.]

method s write_header adr size flags
  arg_rw Stream s ; arg Address adr ; arg Int size ; arg Int flags
  var Pointer:DnsHeader h :> adr map DnsHeader
  h flags := flags
  h qdcount := 1
  h ancount := 0
  h nscount := 0
  h arcount := 0
  s raw_write adr size

method s write_name name
  arg_rw Stream s ; arg Str name
  var Int offset := (cast s:stream_write_cur Int) .-. (cast s:stream_write_buf Int)
  var Int limit := (cast s:stream_write_stop Int) .-. (cast s:stream_write_buf Int)
  write_name s:stream_write_buf offset limit name
  s:stream_write_cur := s:stream_write_buf translate Byte offset

method s write_cached_name offset
  arg_rw Stream s ; arg Int offset
  var uInt16_hi tag := offset + 0C000h
  s raw_write addressof:tag uInt16_hi:size

method s write_answer qtype length flags
  arg_rw Stream s ; arg Int qtype ; arg Int length ; arg Int flags
  var DnsTail t
  t qclass := 1
  t qtype := qtype
  s raw_write addressof:t DnsTail:size
  var DnsAnswer a
  a ttl := shunt (flags .and. 1)<>0 120 dns_refresh
  a rdlength := length
  s raw_write addressof:a DnsAnswer:size

method s write_ip_answer ip1 ip2 ip3 ip4 flags
  arg_rw Stream s ; arg uInt ip1 ip2 ip3 ip4 ; arg Int flags
  s write_answer 1 uInt32_hi:size flags
  var uInt32_hi ip := ip1*2^24+ip2*2^16+ip3*2^8+ip4 ; s raw_write addressof:ip uInt32_hi:size

method s write_ipv6_answer ip1 ip2 ip3 ip4 ip5 ip6 ip7 ip8 flags
  arg_rw Stream s ; arg uInt ip1 ip2 ip3 ip4 ip5 ip6 ip7 ip8 ; arg Int flags
  s write_answer 28 16 flags
  var uInt16_hi u := ip1 ; s raw_write addressof:u uInt16_hi:size
  var uInt16_hi u := ip2 ; s raw_write addressof:u uInt16_hi:size
  var uInt16_hi u := ip3 ; s raw_write addressof:u uInt16_hi:size
  var uInt16_hi u := ip4 ; s raw_write addressof:u uInt16_hi:size
  var uInt16_hi u := ip5 ; s raw_write addressof:u uInt16_hi:size
  var uInt16_hi u := ip6 ; s raw_write addressof:u uInt16_hi:size
  var uInt16_hi u := ip7 ; s raw_write addressof:u uInt16_hi:size
  var uInt16_hi u := ip8 ; s raw_write addressof:u uInt16_hi:size

method s no_answer
  arg_rw Stream s
  s stream_write_cur := s stream_write_buf


function is_ipv6 s ip1 ip2 ip3 ip4 ip5 ip6 ip7 ip8 -> answer
  arg Str s ; arg_w uInt ip1 ip2 ip3 ip4 ip5 ip6 ip7 ip8 ; arg CBool answer
  var (Array uInt 7) ips
  var Int index := 0 ; var Int start := 0 ; var uInt value := 0
  for (var Int i) 0 s:len-1
    var Int c := s:i:number
    if c=":":number 
      if i=start or index>=7
        return false
      ips index := value ; index += 1
      start := i+1 ; value := 0
    eif i-start>=4
      return false
    eif (c>="0":number and c<="9":number)
      value := value*16+c-"0":number
    eif (c>="A":number and c<="F":number)
      value := value*16+c-"A":number+10
    eif (c>="a":number and c<="f":number)
      value := value*16+c-"a":number+10
    else
      return false
  if i=start or index<>7
    return false
  ip1 := ips 0
  ip2 := ips 1
  ip3 := ips 2
  ip4 := ips 3
  ip5 := ips 4
  ip6 := ips 5
  ip7 := ips 6
  ip8 := value
  answer := true


type DnsExtra
  field Int offset
  field Str ip

method d record name s start
  arg_rw Dictionary d ; arg Str name ; arg Stream s ; arg Address start
  var Pointer:DnsExtra e :> d kmap name DnsExtra
  e offset := (cast s:stream_write_cur Int) .-. (cast start Int)
  e ip := name_ip name


doc
  ['build_answer' will build the answer packet to a request about a domain that is defined in the database, as opposed to other requests that will be forwarded (then cached) to external providers.]

function build_soa_field d s
  arg Data:NameDomain d ; arg_rw Stream s
  var Str master := computer_fullname
  part get_master_dns
    each ns d:dns
      master := ns
      leave get_master_dns
  var Str mailbox := d mailbox
  if mailbox=""
    mailbox := "postmaster@"+keyof:d
  datetime:date split (var Int year) (var Int month) (var Int day)
  var uInt32_hi serial := (cast year uInt)*100^3+(cast month uInt)*100^2+(cast day uInt)*100
  var uInt32_hi refresh := dns_refresh
  var uInt32_hi retry := 3600
  var uInt32_hi expire := 7*86400
  var uInt32_hi minimum := dns_refresh
  s write_cached_name DnsHeader:size
  s write_answer 6 master:len+2+mailbox:len+2+5*uInt32_hi:size 0
  s write_name master
  s write_name (replace mailbox "@" ".")
  s raw_write addressof:serial uInt32_hi:size
  s raw_write addressof:refresh uInt32_hi:size
  s raw_write addressof:retry uInt32_hi:size
  s raw_write addressof:expire uInt32_hi:size
  s raw_write addressof:minimum uInt32_hi:size

function build_answer d d2 field flags adr size s
  arg Data:NameDomain d d2 ; arg Int field flags ; arg Address adr ; arg Int size ; arg_rw Stream s
  var Address start := s stream_write_cur
  s write_header adr size flags
  var Int count1 := 0
  var Int count2 := 0
  var Int count3 := 0
  var Dictionary extra
  if field=6 or field=255 # query SOA field
    if exists:d and d:authoritative
      build_soa_field d s
      count1 += 1
  if field=2 or field=255 # query NS field
    each ns d:dns
      s write_cached_name DnsHeader:size
      s write_answer 2 ns:len+2 0
      extra record ns s start
      s write_name ns
      count1 += 1
  if field=15 or field=255 # query MX field
    var uInt16_hi priority := 1
    each m d:mail
      s write_cached_name DnsHeader:size
      s write_answer 15 uInt16_hi:size+m:len+2 0
      s raw_write addressof:priority uInt16_hi:size ; priority += 1
      extra record m s start
      s write_name m
      count1 += 1
  if field=1 or field=255 # query A field
    var Str answer := name_ip keyof:d
    if http_proxy_user:len>0 and (s query "remote_ip_address")="127.0.0.1"
      var Data:NameHost host :> name_database:data:host keyof:d
      if exists:host and host:public_key:len>0
        answer := "127.0.0.1"
      var Data:Site site :> site_database:data:site keyof:d
      if exists:site and site:public_key:len>0
        answer := "127.0.0.1"
    if (answer parse (var uInt ip1) "." (var uInt ip2) "." (var uInt ip3) "." (var uInt ip4))
      s write_cached_name DnsHeader:size
      s write_ip_answer ip1 ip2 ip3 ip4 0
      count1 += 1
  if field=28 or field=255 # query AAAA field
    var Str answer := name_ip keyof:d
    if (is_ipv6 answer (var uInt ip1) (var uInt ip2) (var uInt ip3) (var uInt ip4) (var uInt ip5) (var uInt ip6) (var uInt ip7) (var uInt ip8))
      s write_cached_name DnsHeader:size
      s write_ipv6_answer ip1 ip2 ip3 ip4 ip5 ip6 ip7 ip8 0
      count1 += 1
  if field=12 or field=255 # query PTR field
    var Data:NameReverse r :> name_database:data:reverse keyof:d
    each ptr r:ptr
      s write_cached_name DnsHeader:size
      s write_answer 12 ptr:len+2 0
      s write_name ptr
      count1 += 1
  if count1=0 and exists:d2 and d2:authoritative # autority SOA field
    build_soa_field d2 s
    count2 += 1
  eif field<>2 and (field<>255 or not exists:d) # autority NS fields
    each ns d2:dns
      if count2=0
        var Int offset2 := (cast s:stream_write_cur Int) .-. (cast start Int)
        s write_name keyof:d2
      else
        s write_cached_name offset2
      s write_answer 2 ns:len+2 0
      extra record ns s start
      s write_name ns
      count2 += 1
  each e extra type DnsExtra getkey n
    if (e:ip parse (var uInt ip1) "." (var uInt ip2) "." (var uInt ip3) "." (var uInt ip4))
      s write_cached_name e:offset
      s write_ip_answer ip1 ip2 ip3 ip4 0
      count3 += 1
    eif (is_ipv6 e:ip (var uInt ip1) (var uInt ip2) (var uInt ip3) (var uInt ip4) (var uInt ip5) (var uInt ip6) (var uInt ip7) (var uInt ip8))
      s write_cached_name e:offset
      s write_ipv6_answer ip1 ip2 ip3 ip4 ip5 ip6 ip7 ip8 0
      count3 += 1
  (start translate uInt16_hi 3) map uInt16_hi := count1
  (start translate uInt16_hi 4) map uInt16_hi := count2
  (start translate uInt16_hi 5) map uInt16_hi := count3
  var Pointer:DnsHeader h :> start map DnsHeader
  if count1=0 and (h:flags .and. 15)=0
    if field<>1 and field<>2 and field<>6 and field<>12 and field<>15 and field<>28 and field<>255
    if field<>1 and field<>2 and field<>5 and field<>6 and field<>12 and field<>15 and field<>28 and field<>255
      h flags += 4 # not implemented
    eif not exists:d and (name_ip keyof:d)="" and not exists:(name_database:data:reverse keyof:d) and (flags .and. 400h)<>0
      h flags += 3 # name does not exist (NXDOMAIN)
    

#-------------------------------------------------------------------

doc
  [Parses then answer a client request.]


method server answer adr size s udp
  arg_rw DnsServer server ; arg Address adr ; arg Int size ; arg_rw Stream s ; arg CBool udp
  if size<DnsHeader:size
    dns_trace trace "Received too short query from " (s query "remote_ip_address") ": no answer"
    s no_answer ; return
  var Pointer:DnsHeader h :> adr map DnsHeader
  if (h:flags .and. 8000h)<>0
    dns_trace trace "Received answer from " (s query "remote_ip_address") ": no answer"
    s no_answer ; return
  if (h:flags .and. 07840h)<>0 or h:qdcount<>1 # was 07870h to reject any request with Z<>0, now just ignores AD et CD bits
    dns_trace trace "Received invalid query from " (s query "remote_ip_address") " (flags=" (string (cast h:flags Int) "radix 16") " dqcount=" (cast h:qdcount Int) "): not implemented"
    h flags := 8000h+(h:flags .and. 7970h)+4 # not implemented
    s raw_write adr size
    return
  var CBool local_query := server:cache:len<>0 and ((s query "remote_ip_address") is_inside_ip_domain server:cache)
  var Int offset := DnsHeader:size
  var Str name := lower (read_name adr offset size)
  if local_query and server:default:len<>0 and (name search "." -1)=(-1) and (name_ip name+"."+server:default)<>""
    name += "."+server:default
  if size<offset+DnsTail:size
    dns_trace trace "Received too short query from " (s query "remote_ip_address") ": no answer"
    s no_answer ; return
  var Pointer:DnsTail t :> (adr translate Byte offset) map DnsTail
  offset += DnsTail size
  if offset>512 # try to avoid a few potencial buffer overflows
    dns_trace trace "Received too long query from " (s query "remote_ip_address") ": no answer"
    s no_answer ; return
  part answer_query "answer DNS query "+name+" (qclass="+string:(cast t:qclass Int)+" qtype="+string:(cast t:qtype Int)+")"
    var Int flags := 8000h+(h:flags .and. 100h)
    var Data:NameDomain d :> name_database:data:domain name
    var Data:NameDomain d2 :> d ; var Int pt := -1
    while not exists:d2 and { var Int pt2 := (name pt+1 name:len) search "." -1 ; pt2<>(-1) }
      pt := pt+1+pt2
      d2 :> name_database:data:domain (name pt+1 name:len)
    var CBool authoritative := exists:d2 and d2:authoritative
    if authoritative
      flags += 400h # set aa flag
    if local_query
      flags += 80h # set ra flag
    if authoritative 
      # a query about a local domain: build the answer localy
      dns_trace trace "Query " name " (qclass=" (cast t:qclass Int) " qtype=" (cast t:qtype Int) ") from " (s query "remote_ip_address") ": authoritative answer"
      build_answer d d2 (shunt t:qclass=1 t:qtype -1) flags adr offset s
    eif t:qclass=1 and (t:qtype=1 or t:qtype=28) and name_ip:name<>""
      dns_trace trace "Query IP address of " name " from " (s query "remote_ip_address") ": answer is " name_ip:name
      # we know the name -> IP assignment, so answer whatever the domain is
      build_answer d d2 t:qtype flags adr offset s
    eif local_query
      # a internal request about an external domain: query (then cache) the external DNS servers
      (var Str query) set adr size false
      var Str answer := query_cache query
      if answer=""
        if udp
          if (server:resource nowait_request 1)
            safe
              var Str ip := s query "remote_ip_address"
              var Str port := s query "remote_ip_port"
              thread
                share server
                part query_external "Query external DNS ("+name+")"
                  var Str answer2 := query_providers query
                  if answer2<>""
                    dns_trace trace "Local query " name " (qclass=" (cast t:qclass Int) " qtype=" (cast t:qtype Int) ") from " ip ": forwarding answer"
                    (var Stream back) open "udp://"+ip+"/client/"+port "local_ip_port 53" in+out+safe
                    back configure "priority high"
                    back writechars answer2
                    back close
                  else
                    dns_trace trace "Local query " name " (qclass=" (cast t:qclass Int) " qtype=" (cast t:qtype Int) ") from " ip ": failed to get answer from external DNS"
                  server:resource release 1
            failure
              dns_trace trace "Local query " name " (qclass=" (cast t:qclass Int) " qtype=" (cast t:qtype Int) ") from " (s query "remote_ip_address") ": no more thread"
              server:resource release 1
          else
            dns_trace trace "Local query " name " (qclass=" (cast t:qclass Int) " qtype=" (cast t:qtype Int) ") from " (s query "remote_ip_address") ": too many pending queries"
          s no_answer
        else
          answer := query_providers query
          dns_trace trace "Local TCP query " name " (qclass=" (cast t:qclass Int) " qtype=" (cast t:qtype Int) ") from " (s query "remote_ip_address") ": " (shunt answer<>"" "forwarding answer" "failed to get answer from external DNS")
      else
        dns_trace trace "Local query " name " (qclass=" (cast t:qclass Int) " qtype=" (cast t:qtype Int) ") from " (s query "remote_ip_address") ": was in cache"
      if answer<>""
        s writechars answer
      else
        s no_answer
    eif exists:d2 and not local_query
      # a query about a sub domain: build the answer localy
      dns_trace trace "Query about subdomain " name " (qclass=" (cast t:qclass Int) " qtype=" (cast t:qtype Int) ") from " (s query "remote_ip_address") ": non authoritative answer"
      build_answer d d2 (shunt t:qclass=1 t:qtype -1) flags adr offset s
    else
      s write_header adr offset flags+5 # refused


doc
  [General loop handling requests received on TCP port 53.]

method server service s
  arg_rw DnsServer server ; arg_rw Stream s
  while not s:atend
    s raw_read addressof:(var uInt16_hi length) uInt16_hi:size
    var Int size := length
    var Address adr := memory_allocate size null
    s raw_read adr size
    if s=failure
      memory_free adr
      return
    length := 0 ; s raw_write addressof:length uInt16_hi:size
    server answer adr size s false
    memory_free adr
    if s:stream_write_cur=s:stream_write_buf
      return
    s:stream_write_buf map uInt16_hi := (cast s:stream_write_cur Int) .-. (cast s:stream_write_buf Int) .-. uInt16_hi:size
    s flush anytime


doc
  [When the DNS TCP service starts, we start another thread handling UDP requests, and we stop this thread when the DNS TCP service stops.]

method server start_checkup -> status
  arg_rw DnsServer server ; arg Status status
  server:resource configure server:parallel
  (var Stream test) open "udp:/server/53" in+out+safe
  if test=failure
    return failure
  test close
  dns_hits := 0
  server please_stop_udp := false
  thread
    share server
    part udp_server "UDP DNS server"
      (var Stream s) open "udp:/server/53" in+out+safe
      s configure "priority high"
      while not server:please_stop_udp
        part wait_for_request "wait for UDP request"
          s read_available (var Address adr) (var Int size)
        dns_hits += 1
        part answer_request "answer UDP request"
          server answer adr size s true
        part reset_stream "reset UDP stream"
          s configure "reset"
        if s:is_crashed
          console "DNS UDP stream crashed !  Restarting it." eol
          s open "udp:/server/53" in+out+safe
          s configure "priority high"
      server please_stop_udp := false
  status := success

method server stop_checkup
  arg_rw DnsServer server
  server please_stop_udp := true
  while server:please_stop_udp
    (var Stream s) open "udp://127.0.0.1/client/53" in+out+safe
    s raw_write "[0]":characters 1
    s close
    sleep 0.1
   

define_tcp_server DnsServer dns_server
export dns_server dns_refresh dns_hits