Patch title: Release 85 bulk changes
Abstract:
File: /pliant/protocol/dns/common.pli
Key:
    Removed line
    Added line
abstract
  [DNS protocol related data types, and caching mechanism.]


module "/pliant/language/unsafe.pli"
module "/pliant/language/stream/stream.pli"
module "/pliant/language/stream/udp.pli"
module "/pliant/fullpliant/this_computer.pli"
module "/pliant/protocol/dns/name.pli"

scope "/pliant/protocol/dns/"
public

constant minimum_timeout 120

doc
  [Data types.]

type DnsHeader
  packed
  field uInt16_hi id
  field uInt16_hi flags
  field uInt16_hi qdcount ancount nscount arcount

type DnsTail
  packed
  field uInt16_hi qtype qclass

type DnsAnswer
  packed
  field uInt32_hi ttl
  field uInt16_hi rdlength


doc
  [Compressed names encoding and decoding.]

function read_name buf offset limit -> name
  arg Address buf ; arg_rw Int offset ; arg Int limit ; arg Str name
  name := ""
  var Int start := offset
  while true
    if offset>=limit
      return ""
    var uInt8 len := (buf translate Byte offset) map uInt8 ; offset += 1
    if len=0
      if name:len>0
        name := name 0 name:len-1
      return
    eif len<64
      if offset+len>=limit
        return ""
      (var Str one) set (buf translate Byte offset) len false ; offset += len
      name += one+"."
    eif len<192
      return ""
    else
      if offset+1>=limit
        return ""
      var Int offset2 := ((buf translate Byte offset) map uInt8)+(len-192)*256 ; offset += 1
      var Str subname := read_name buf offset2 start
      if subname<>""
        return name+subname
      else
        return ""


function write_name buf offset limit name
  arg Address buf ; arg_rw Int offset ; arg Int limit ; arg Str name
  var Str all := name+"."
  while (all eparse any:(var Str first) "." any:(var Str remain))
    var uInt8 len := first len
    if offset+2+len>=limit
      return
    (buf translate Byte offset) map uInt8 := len ; offset += 1
    memory_copy first:characters (buf translate Byte offset) len ; offset += len
    all := remain
  (buf translate Byte offset) map uInt8 := 0 ; offset += 1


doc
  [Parsing an answer to find the shortest timeout.]

function answer_timeout answer -> timeout
  arg Str answer ; arg Int timeout
  var Address buf := answer characters ; var Int limit := answer len
  if DnsHeader:size>limit
    return undefined
  timeout := 30*86400
  var Pointer:DnsHeader h :> buf map DnsHeader ; var Int offset := DnsHeader size
  for (var Int i) 0 h:qdcount+h:ancount+h:nscount+h:arcount-1
    var Str id := read_name buf offset limit
    if offset+DnsTail:size>limit
      return
    var Pointer:DnsTail t :> (buf translate Byte offset) map DnsTail ; offset += DnsTail size
    if i>=h:qdcount
      if offset+DnsAnswer:size>limit
        return
      var Pointer:DnsAnswer a :> (buf translate Byte offset) map DnsAnswer ; offset += DnsAnswer size 
      if offset+a:rdlength>limit
        return undefined
      if a:ttl<30*86400
        timeout := min timeout a:ttl
      offset += a:rdlength
  if offset<>limit
    # console "wrong DNS answer size" eol
    return undefined
  timeout := max timeout minimum_timeout
  # console "DNS answer timeout is " timeout eol

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

doc
  [Caching.]

type CacheEntry
  field Str answer
  field Int hits
  field DateTime expires

gvar Sem sem
gvar Dictionary cache
gvar Int cache_size := 1024


function set_cache query answer
  arg Str query answer
  var DateTime now := datetime
  var Int timeout := answer_timeout answer
  var Link:CacheEntry e :> new CacheEntry
  e answer := answer 2 answer:len
  e hits := 0
  e expires := now ; e:expires seconds += timeout
  sem request
  if cache:count>=cache_size
    var Intn total := 0
    each ee cache type CacheEntry
      total += ee hits
    var Intn threshold := total\cache:count
    var List drop
    each ee cache type CacheEntry getkey k
      if ee:expires<=now or ee:hits<=threshold
        ee answer := k
        drop append addressof:ee
      else
        ee hits \= 2
    var Pointer:Arrow c :> drop first
    while c<>null
      cache remove (c map CacheEntry):answer c
      c :> drop next c
    this_computer:env:"pliant":"dns":"cache_size" parse cache_size
  cache insert (query 2 query:len) true addressof:e
  sem release


function query_cache query -> answer
  arg Str query answer
  var DateTime now := datetime
  sem rd_request
  var Pointer:Arrow c :> cache first (query 2 query:len)
  if c<>null
    var Link:CacheEntry e :> c map CacheEntry
    if e:expires>=now
      answer := (query 0 2)+e:answer
      e hits += 1
      sem rd_release
      return
  sem rd_release
  answer := ""


doc
  ['query_providers' will forward the request to external DNS servers, then record the answer in the cache.]

function query_provider query server timeout -> answer
  arg Str query server ; arg Float timeout ; arg Str answer
  (var Stream fwd) open "udp://"+server+"/client/53" in+out+safe
  fwd configure "priority high"
  fwd writechars query
  fwd configure "timeout "+string:timeout
  fwd read_available (var Address adr2) (var Int size2)
  if size2<>0
    answer set (memory_allocate size2 addressof:answer) size2 true
    memory_copy adr2 answer:characters size2
    set_cache query answer
  else 
    answer := ""

function query_providers query -> answer
  arg Str query answer
  for (var Int lap) 0 4
    each provider this_computer:env:"pliant":"dns"
      if (keyof:provider parse "provider" any) and provider<>""
        answer := query_provider query provider (min 2^lap 4)
        if answer:len<>0
          return
  answer := ""