/pliant/protocol/dns/common.pli
 
 1  abstract 
 2    [DNS protocol related data types, and caching mechanism.] 
 3   
 4   
 5  module "/pliant/language/unsafe.pli" 
 6  module "/pliant/language/stream/stream.pli" 
 7  module "/pliant/language/stream/udp.pli" 
 8  module "/pliant/fullpliant/this_computer.pli" 
 9  module "/pliant/protocol/dns/name.pli" 
 10   
 11  scope "/pliant/protocol/dns/" 
 12  public 
 13   
 14  constant minimum_timeout 120 
 15   
 16  doc 
 17    [Data types.] 
 18   
 19  type DnsHeader 
 20    packed 
 21    field uInt16_hi id 
 22    field uInt16_hi flags 
 23    field uInt16_hi qdcount ancount nscount arcount 
 24   
 25  type DnsTail 
 26    packed 
 27    field uInt16_hi qtype qclass 
 28   
 29  type DnsAnswer 
 30    packed 
 31    field uInt32_hi ttl 
 32    field uInt16_hi rdlength 
 33   
 34   
 35  doc 
 36    [Compressed names encoding and decoding.] 
 37   
 38  function read_name buf offset limit -> name 
 39    arg Address buf ; arg_rw Int offset ; arg Int limit ; arg Str name 
 40    name := "" 
 41    var Int start := offset 
 42    while true 
 43      if offset>=limit 
 44        return "" 
 45      var uInt8 len := (buf translate Byte offset) map uInt8 ; offset += 1 
 46      if len=0 
 47        if name:len>0 
 48          name := name name:len-1 
 49        return 
 50      eif len<64 
 51        if offset+len>=limit 
 52          return "" 
 53        (var Str one) set (buf translate Byte offset) len false ; offset += len 
 54        name += one+"." 
 55      eif len<192 
 56        return "" 
 57      else 
 58        if offset+1>=limit 
 59          return "" 
 60        var Int offset2 := ((buf translate Byte offset) map uInt8)+(len-192)*256 ; offset += 1 
 61        var Str subname := read_name buf offset2 start 
 62        if subname<>"" 
 63          return name+subname 
 64        else 
 65          return "" 
 66   
 67   
 68  function write_name buf offset limit name 
 69    arg Address buf ; arg_rw Int offset ; arg Int limit ; arg Str name 
 70    var Str all := name+"." 
 71    while (all eparse any:(var Str first) "." any:(var Str remain)) 
 72      var uInt8 len := first len 
 73      if offset+2+len>=limit 
 74        return 
 75      (buf translate Byte offset) map uInt8 := len ; offset += 1 
 76      memory_copy first:characters (buf translate Byte offset) len ; offset += len 
 77      all := remain 
 78    (buf translate Byte offset) map uInt8 := 0 ; offset += 1 
 79   
 80   
 81  doc 
 82    [Parsing an answer to find the shortest timeout.] 
 83   
 84  function answer_timeout answer -> timeout 
 85    arg Str answer ; arg Int timeout 
 86    var Address buf := answer characters ; var Int limit := answer len 
 87    if DnsHeader:size>limit 
 88      return undefined 
 89    timeout := 30*86400 
 90    var Pointer:DnsHeader :> buf map DnsHeader ; var Int offset := DnsHeader size 
 91    for (var Int i) h:qdcount+h:ancount+h:nscount+h:arcount-1 
 92      var Str id := read_name buf offset limit 
 93      if offset+DnsTail:size>limit 
 94        return 
 95      var Pointer:DnsTail :> (buf translate Byte offset) map DnsTail ; offset += DnsTail size 
 96      if i>=h:qdcount 
 97        if offset+DnsAnswer:size>limit 
 98          return 
 99        var Pointer:DnsAnswer :> (buf translate Byte offset) map DnsAnswer ; offset += DnsAnswer size  
 100        if offset+a:rdlength>limit 
 101          return undefined 
 102        if a:ttl<30*86400 
 103          timeout := min timeout a:ttl 
 104        offset += a:rdlength 
 105    if offset<>limit 
 106      # console "wrong DNS answer size" eol 
 107      return undefined 
 108    timeout := max timeout minimum_timeout 
 109    # console "DNS answer timeout is " timeout eol 
 110   
 111    
 112 
 
 113   
 114  doc 
 115    [Caching.] 
 116   
 117  type CacheEntry 
 118    field Str answer 
 119    field Int hits 
 120    field DateTime expires 
 121   
 122  gvar Sem sem 
 123  gvar Dictionary cache 
 124  gvar Int cache_size := 1024 
 125   
 126   
 127  function set_cache query answer 
 128    arg Str query answer 
 129    var DateTime now := datetime 
 130    var Int timeout := answer_timeout answer 
 131    var Link:CacheEntry :> new CacheEntry 
 132    answer := answer answer:len 
 133    hits := 0 
 134    expires := now ; e:expires seconds += timeout 
 135    sem request 
 136    if cache:count>=cache_size 
 137      var Intn total := 0 
 138      each ee cache type CacheEntry 
 139        total += ee hits 
 140      var Intn threshold := total\cache:count 
 141      var List drop 
 142      each ee cache type CacheEntry getkey k 
 143        if ee:expires<=now or ee:hits<=threshold 
 144          ee answer := k 
 145          drop append addressof:ee 
 146        else 
 147          ee hits \= 2 
 148      var Pointer:Arrow :> drop first 
 149      while c<>null 
 150        cache remove (map CacheEntry):answer c 
 151        :> drop next c 
 152      this_computer:env:"pliant":"dns":"cache_size" parse cache_size 
 153    cache insert (query query:len) true addressof:e 
 154    sem release 
 155   
 156   
 157  function query_cache query -> answer 
 158    arg Str query answer 
 159    var DateTime now := datetime 
 160    sem rd_request 
 161    var Pointer:Arrow :> cache first (query query:len) 
 162    if c<>null 
 163      var Link:CacheEntry :> map CacheEntry 
 164      if e:expires>=now 
 165        answer := (query 0 2)+e:answer 
 166        hits += 1 
 167        sem rd_release 
 168        return 
 169    sem rd_release 
 170    answer := "" 
 171   
 172   
 173  doc 
 174    ['query_providers' will forward the request to external DNS servers, then record the answer in the cache.] 
 175   
 176  function query_provider query server timeout -> answer 
 177    arg Str query server ; arg Float timeout ; arg Str answer 
 178    (var Stream fwd) open "udp://"+server+"/client/53" in+out+safe 
 179    fwd configure "priority high" 
 180    fwd writechars query 
 181    fwd configure "timeout "+string:timeout 
 182    fwd read_available (var Address adr2) (var Int size2) 
 183    if size2<>0 
 184      answer set (memory_allocate size2 addressof:answer) size2 true 
 185      memory_copy adr2 answer:characters size2 
 186      set_cache query answer 
 187    else  
 188      answer := "" 
 189   
 190  function query_providers query -> answer 
 191    arg Str query answer 
 192    for (var Int lap) 0 4 
 193      each provider this_computer:env:"pliant":"dns" 
 194        if (keyof:provider parse "provider" any) and provider<>"" 
 195          answer := query_provider query provider (min 2^lap 4) 
 196          if answer:len<>0 
 197            return 
 198    answer := ""