/pliant/protocol/dns/server.pli
 
 1  abstract 
 2    [This is a partial DNS server implementation, according to RFC 1035.] 
 3   
 4   
 5  module "/pliant/install/minimal.pli" 
 6  module "/pliant/language/compiler.pli" 
 7  submodule "/pliant/protocol/common/tcp_server.pli" 
 8  module "/pliant/protocol/common/misc.pli" 
 9  module "/pliant/language/stream.pli" 
 10  module "/pliant/fullpliant/this_computer.pli" 
 11  module "common.pli" 
 12  module "name.pli" 
 13  module "/pliant/protocol/http/proxy.pli" 
 14  module "/pliant/protocol/http/site.pli" 
 15   
 16  module "/pliant/language/context.pli" 
 17  module "/pliant/language/schedule/resourcesem.pli" 
 18   
 19  (gvar TraceSlot dns_trace) configure "DNS server" 
 20   
 21   
 22  type DnsServer 
 23    tcp_server_fields "DNS" 53 
 24    field CBool please_stop_udp 
 25    field ResourceSem resource 
 26    public 
 27      field Str cache 
 28      field Str default 
 29      field Int parallel <- (constant (max (min (cast memory_assigned\2^20 Int) 1024) 64)) 
 30  TcpServer maybe DnsServer 
 31   
 32   
 33  gvar Int dns_refresh := 24*3600 # in seconds 
 34  gvar Int dns_hits := 0 
 35   
 36   
 37 
 
 38   
 39  doc 
 40    [A few utility functions.] 
 41   
 42  method s write_header adr size flags 
 43    arg_rw Stream s ; arg Address adr ; arg Int size ; arg Int flags 
 44    var Pointer:DnsHeader h :> adr map DnsHeader 
 45    h flags := flags 
 46    h qdcount := 1 
 47    h ancount := 0 
 48    h nscount := 0 
 49    h arcount := 0 
 50    s raw_write adr size 
 51   
 52  method s write_name name 
 53    arg_rw Stream s ; arg Str name 
 54    var Int offset := (cast s:stream_write_cur Int) .-. (cast s:stream_write_buf Int) 
 55    var Int limit := (cast s:stream_write_stop Int) .-. (cast s:stream_write_buf Int) 
 56    write_name s:stream_write_buf offset limit name 
 57    s:stream_write_cur := s:stream_write_buf translate Byte offset 
 58   
 59  method s write_cached_name offset 
 60    arg_rw Stream s ; arg Int offset 
 61    var uInt16_hi tag := offset + 0C000h 
 62    s raw_write addressof:tag uInt16_hi:size 
 63   
 64  method s write_answer qtype length flags 
 65    arg_rw Stream s ; arg Int qtype ; arg Int length ; arg Int flags 
 66    var DnsTail t 
 67    t qclass := 1 
 68    t qtype := qtype 
 69    s raw_write addressof:t DnsTail:size 
 70    var DnsAnswer a 
 71    a ttl := shunt (flags .and. 1)<>0 120 dns_refresh 
 72    a rdlength := length 
 73    s raw_write addressof:a DnsAnswer:size 
 74   
 75  method s write_ip_answer ip1 ip2 ip3 ip4 flags 
 76    arg_rw Stream s ; arg uInt ip1 ip2 ip3 ip4 ; arg Int flags 
 77    s write_answer 1 uInt32_hi:size flags 
 78    var uInt32_hi ip := ip1*2^24+ip2*2^16+ip3*2^8+ip4 ; s raw_write addressof:ip uInt32_hi:size 
 79   
 80  method s write_ipv6_answer ip1 ip2 ip3 ip4 ip5 ip6 ip7 ip8 flags 
 81    arg_rw Stream s ; arg uInt ip1 ip2 ip3 ip4 ip5 ip6 ip7 ip8 ; arg Int flags 
 82    s write_answer 28 16 flags 
 83    var uInt16_hi u := ip1 ; s raw_write addressof:u uInt16_hi:size 
 84    var uInt16_hi u := ip2 ; s raw_write addressof:u uInt16_hi:size 
 85    var uInt16_hi u := ip3 ; s raw_write addressof:u uInt16_hi:size 
 86    var uInt16_hi u := ip4 ; s raw_write addressof:u uInt16_hi:size 
 87    var uInt16_hi u := ip5 ; s raw_write addressof:u uInt16_hi:size 
 88    var uInt16_hi u := ip6 ; s raw_write addressof:u uInt16_hi:size 
 89    var uInt16_hi u := ip7 ; s raw_write addressof:u uInt16_hi:size 
 90    var uInt16_hi u := ip8 ; s raw_write addressof:u uInt16_hi:size 
 91   
 92  method s no_answer 
 93    arg_rw Stream s 
 94    s stream_write_cur := s stream_write_buf 
 95   
 96   
 97  function is_ipv6 s ip1 ip2 ip3 ip4 ip5 ip6 ip7 ip8 -> answer 
 98    arg Str s ; arg_w uInt ip1 ip2 ip3 ip4 ip5 ip6 ip7 ip8 ; arg CBool answer 
 99    var (Array uInt 7) ips 
 100    var Int index := 0 ; var Int start := 0 ; var uInt value := 0 
 101    for (var Int i) 0 s:len-1 
 102      var Int c := s:i:number 
 103      if c=":":number  
 104        if i=start or index>=7 
 105          return false 
 106        ips index := value ; index += 1 
 107        start := i+1 ; value := 0 
 108      eif i-start>=4 
 109        return false 
 110      eif (c>="0":number and c<="9":number) 
 111        value := value*16+c-"0":number 
 112      eif (c>="A":number and c<="F":number) 
 113        value := value*16+c-"A":number+10 
 114      eif (c>="a":number and c<="f":number) 
 115        value := value*16+c-"a":number+10 
 116      else 
 117        return false 
 118    if i=start or index<>7 
 119      return false 
 120    ip1 := ips 0 
 121    ip2 := ips 1 
 122    ip3 := ips 2 
 123    ip4 := ips 3 
 124    ip5 := ips 4 
 125    ip6 := ips 5 
 126    ip7 := ips 6 
 127    ip8 := value 
 128    answer := true 
 129   
 130   
 131  type DnsExtra 
 132    field Int offset 
 133    field Str ip 
 134   
 135  method d record name s start 
 136    arg_rw Dictionary d ; arg Str name ; arg Stream s ; arg Address start 
 137    var Pointer:DnsExtra e :> d kmap name DnsExtra 
 138    e offset := (cast s:stream_write_cur Int) .-. (cast start Int) 
 139    e ip := name_ip name 
 140   
 141   
 142  doc 
 143    ['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.] 
 144   
 145  function build_soa_field d s 
 146    arg Data:NameDomain d ; arg_rw Stream s 
 147    var Str master := computer_fullname 
 148    part get_master_dns 
 149      each ns d:dns 
 150        master := ns 
 151        leave get_master_dns 
 152    var Str mailbox := d mailbox 
 153    if mailbox="" 
 154      mailbox := "postmaster@"+keyof:d 
 155    datetime:date split (var Int year) (var Int month) (var Int day) 
 156    var uInt32_hi serial := (cast year uInt)*100^3+(cast month uInt)*100^2+(cast day uInt)*100 
 157    var uInt32_hi refresh := dns_refresh 
 158    var uInt32_hi retry := 3600 
 159    var uInt32_hi expire := 7*86400 
 160    var uInt32_hi minimum := dns_refresh 
 161    s write_cached_name DnsHeader:size 
 162    s write_answer 6 master:len+2+mailbox:len+2+5*uInt32_hi:size 0 
 163    s write_name master 
 164    s write_name (replace mailbox "@" ".") 
 165    s raw_write addressof:serial uInt32_hi:size 
 166    s raw_write addressof:refresh uInt32_hi:size 
 167    s raw_write addressof:retry uInt32_hi:size 
 168    s raw_write addressof:expire uInt32_hi:size 
 169    s raw_write addressof:minimum uInt32_hi:size 
 170   
 171  function build_answer d d2 field flags adr size s 
 172    arg Data:NameDomain d d2 ; arg Int field flags ; arg Address adr ; arg Int size ; arg_rw Stream s 
 173    var Address start := s stream_write_cur 
 174    s write_header adr size flags 
 175    var Int count1 := 0 
 176    var Int count2 := 0 
 177    var Int count3 := 0 
 178    var Dictionary extra 
 179    if field=6 or field=255 # query SOA field 
 180      if exists:d and d:authoritative 
 181        build_soa_field d s 
 182        count1 += 1 
 183    if field=2 or field=255 # query NS field 
 184      each ns d:dns 
 185        s write_cached_name DnsHeader:size 
 186        s write_answer 2 ns:len+2 0 
 187        extra record ns s start 
 188        s write_name ns 
 189        count1 += 1 
 190    if field=15 or field=255 # query MX field 
 191      var uInt16_hi priority := 1 
 192      each m d:mail 
 193        s write_cached_name DnsHeader:size 
 194        s write_answer 15 uInt16_hi:size+m:len+2 0 
 195        s raw_write addressof:priority uInt16_hi:size ; priority += 1 
 196        extra record m s start 
 197        s write_name m 
 198        count1 += 1 
 199    if field=1 or field=255 # query A field 
 200      var Str answer := name_ip keyof:d 
 201      if http_proxy_user:len>0 and (s query "remote_ip_address")="127.0.0.1" 
 202        var Data:NameHost host :> name_database:data:host keyof:d 
 203        if exists:host and host:public_key:len>0 
 204          answer := "127.0.0.1" 
 205        var Data:Site site :> site_database:data:site keyof:d 
 206        if exists:site and site:public_key:len>0 
 207          answer := "127.0.0.1" 
 208      if (answer parse (var uInt ip1) "." (var uInt ip2) "." (var uInt ip3) "." (var uInt ip4)) 
 209        s write_cached_name DnsHeader:size 
 210        s write_ip_answer ip1 ip2 ip3 ip4 0 
 211        count1 += 1 
 212    if field=28 or field=255 # query AAAA field 
 213      var Str answer := name_ip keyof:d 
 214      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)) 
 215        s write_cached_name DnsHeader:size 
 216        s write_ipv6_answer ip1 ip2 ip3 ip4 ip5 ip6 ip7 ip8 0 
 217        count1 += 1 
 218    if field=12 or field=255 # query PTR field 
 219      var Data:NameReverse r :> name_database:data:reverse keyof:d 
 220      each ptr r:ptr 
 221        s write_cached_name DnsHeader:size 
 222        s write_answer 12 ptr:len+2 0 
 223        s write_name ptr 
 224        count1 += 1 
 225    if count1=0 and exists:d2 and d2:authoritative # autority SOA field 
 226      build_soa_field d2 s 
 227      count2 += 1 
 228    eif field<>2 and (field<>255 or not exists:d) # autority NS fields 
 229      each ns d2:dns 
 230        if count2=0 
 231          var Int offset2 := (cast s:stream_write_cur Int) .-. (cast start Int) 
 232          s write_name keyof:d2 
 233        else 
 234          s write_cached_name offset2 
 235        s write_answer 2 ns:len+2 0 
 236        extra record ns s start 
 237        s write_name ns 
 238        count2 += 1 
 239    each e extra type DnsExtra getkey n 
 240      if (e:ip parse (var uInt ip1) "." (var uInt ip2) "." (var uInt ip3) "." (var uInt ip4)) 
 241        s write_cached_name e:offset 
 242        s write_ip_answer ip1 ip2 ip3 ip4 0 
 243        count3 += 1 
 244      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)) 
 245        s write_cached_name e:offset 
 246        s write_ipv6_answer ip1 ip2 ip3 ip4 ip5 ip6 ip7 ip8 0 
 247        count3 += 1 
 248    (start translate uInt16_hi 3) map uInt16_hi := count1 
 249    (start translate uInt16_hi 4) map uInt16_hi := count2 
 250    (start translate uInt16_hi 5) map uInt16_hi := count3 
 251    var Pointer:DnsHeader h :> start map DnsHeader 
 252    if count1=0 and (h:flags .and. 15)=0 
 253      if field<>1 and field<>2 and field<>5 and field<>6 and field<>12 and field<>15 and field<>28 and field<>255 
 254        h flags += 4 # not implemented 
 255      eif not exists:d and (name_ip keyof:d)="" and not exists:(name_database:data:reverse keyof:d) and (flags .and. 400h)<>0 
 256        h flags += 3 # name does not exist (NXDOMAIN) 
 257       
 258   
 259 
 
 260   
 261  doc 
 262    [Parses then answer a client request.] 
 263   
 264   
 265  method server answer adr size s udp 
 266    arg_rw DnsServer server ; arg Address adr ; arg Int size ; arg_rw Stream s ; arg CBool udp 
 267    if size<DnsHeader:size 
 268      dns_trace trace "Received too short query from " (s query "remote_ip_address") ": no answer" 
 269      s no_answer ; return 
 270    var Pointer:DnsHeader h :> adr map DnsHeader 
 271    if (h:flags .and. 8000h)<>0 
 272      dns_trace trace "Received answer from " (s query "remote_ip_address") ": no answer" 
 273      s no_answer ; return 
 274    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 
 275      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" 
 276      h flags := 8000h+(h:flags .and. 7970h)+4 # not implemented 
 277      s raw_write adr size 
 278      return 
 279    var CBool local_query := server:cache:len<>0 and ((s query "remote_ip_address") is_inside_ip_domain server:cache) 
 280    var Int offset := DnsHeader:size 
 281    var Str name := lower (read_name adr offset size) 
 282    if local_query and server:default:len<>0 and (name search "." -1)=(-1) and (name_ip name+"."+server:default)<>"" 
 283      name += "."+server:default 
 284    if size<offset+DnsTail:size 
 285      dns_trace trace "Received too short query from " (s query "remote_ip_address") ": no answer" 
 286      s no_answer ; return 
 287    var Pointer:DnsTail t :> (adr translate Byte offset) map DnsTail 
 288    offset += DnsTail size 
 289    if offset>512 # try to avoid a few potencial buffer overflows 
 290      dns_trace trace "Received too long query from " (s query "remote_ip_address") ": no answer" 
 291      s no_answer ; return 
 292    part answer_query "answer DNS query "+name+" (qclass="+string:(cast t:qclass Int)+" qtype="+string:(cast t:qtype Int)+")" 
 293      var Int flags := 8000h+(h:flags .and. 100h) 
 294      var Data:NameDomain d :> name_database:data:domain name 
 295      var Data:NameDomain d2 :> d ; var Int pt := -1 
 296      while not exists:d2 and { var Int pt2 := (name pt+1 name:len) search "." -1 ; pt2<>(-1) } 
 297        pt := pt+1+pt2 
 298        d2 :> name_database:data:domain (name pt+1 name:len) 
 299      var CBool authoritative := exists:d2 and d2:authoritative 
 300      if authoritative 
 301        flags += 400h # set aa flag 
 302      if local_query 
 303        flags += 80h # set ra flag 
 304      if authoritative  
 305        # a query about a local domain: build the answer localy 
 306        dns_trace trace "Query " name " (qclass=" (cast t:qclass Int) " qtype=" (cast t:qtype Int) ") from " (s query "remote_ip_address") ": authoritative answer" 
 307        build_answer d d2 (shunt t:qclass=1 t:qtype -1) flags adr offset s 
 308      eif t:qclass=1 and (t:qtype=1 or t:qtype=28) and name_ip:name<>"" 
 309        dns_trace trace "Query IP address of " name " from " (s query "remote_ip_address") ": answer is " name_ip:name 
 310        # we know the name -> IP assignment, so answer whatever the domain is 
 311        build_answer d d2 t:qtype flags adr offset s 
 312      eif local_query 
 313        # a internal request about an external domain: query (then cache) the external DNS servers 
 314        (var Str query) set adr size false 
 315        var Str answer := query_cache query 
 316        if answer="" 
 317          if udp 
 318            if (server:resource nowait_request 1) 
 319              safe 
 320                var Str ip := s query "remote_ip_address" 
 321                var Str port := s query "remote_ip_port" 
 322                thread 
 323                  share server 
 324                  part query_external "Query external DNS ("+name+")" 
 325                    var Str answer2 := query_providers query 
 326                    if answer2<>"" 
 327                      dns_trace trace "Local query " name " (qclass=" (cast t:qclass Int) " qtype=" (cast t:qtype Int) ") from " ip ": forwarding answer" 
 328                      (var Stream back) open "udp://"+ip+"/client/"+port "local_ip_port 53" in+out+safe 
 329                      back configure "priority high" 
 330                      back writechars answer2 
 331                      back close 
 332                    else 
 333                      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" 
 334                    server:resource release 1 
 335              failure 
 336                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" 
 337                server:resource release 1 
 338            else 
 339              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" 
 340            s no_answer 
 341          else 
 342            answer := query_providers query 
 343            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") 
 344        else 
 345          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" 
 346        if answer<>"" 
 347          s writechars answer 
 348        else 
 349          s no_answer 
 350      eif exists:d2 and not local_query 
 351        # a query about a sub domain: build the answer localy 
 352        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" 
 353        build_answer d d2 (shunt t:qclass=1 t:qtype -1) flags adr offset s 
 354      else 
 355        s write_header adr offset flags+5 # refused 
 356   
 357   
 358  doc 
 359    [General loop handling requests received on TCP port 53.] 
 360   
 361  method server service s 
 362    arg_rw DnsServer server ; arg_rw Stream s 
 363    while not s:atend 
 364      s raw_read addressof:(var uInt16_hi length) uInt16_hi:size 
 365      var Int size := length 
 366      var Address adr := memory_allocate size null 
 367      s raw_read adr size 
 368      if s=failure 
 369        memory_free adr 
 370        return 
 371      length := 0 ; s raw_write addressof:length uInt16_hi:size 
 372      server answer adr size s false 
 373      memory_free adr 
 374      if s:stream_write_cur=s:stream_write_buf 
 375        return 
 376      s:stream_write_buf map uInt16_hi := (cast s:stream_write_cur Int) .-. (cast s:stream_write_buf Int) .-. uInt16_hi:size 
 377      s flush anytime 
 378   
 379   
 380  doc 
 381    [When the DNS TCP service starts, we start another thread handling UDP requests, and we stop this thread when the DNS TCP service stops.] 
 382   
 383  method server start_checkup -> status 
 384    arg_rw DnsServer server ; arg Status status 
 385    server:resource configure server:parallel 
 386    (var Stream test) open "udp:/server/53" in+out+safe 
 387    if test=failure 
 388      return failure 
 389    test close 
 390    dns_hits := 0 
 391    server please_stop_udp := false 
 392    thread 
 393      share server 
 394      part udp_server "UDP DNS server" 
 395        (var Stream s) open "udp:/server/53" in+out+safe 
 396        s configure "priority high" 
 397        while not server:please_stop_udp 
 398          part wait_for_request "wait for UDP request" 
 399            s read_available (var Address adr) (var Int size) 
 400          dns_hits += 1 
 401          part answer_request "answer UDP request" 
 402            server answer adr size s true 
 403          part reset_stream "reset UDP stream" 
 404            s configure "reset" 
 405          if s:is_crashed 
 406            console "DNS UDP stream crashed !  Restarting it." eol 
 407            s open "udp:/server/53" in+out+safe 
 408            s configure "priority high" 
 409        server please_stop_udp := false 
 410    status := success 
 411   
 412  method server stop_checkup 
 413    arg_rw DnsServer server 
 414    server please_stop_udp := true 
 415    while server:please_stop_udp 
 416      (var Stream s) open "udp://127.0.0.1/client/53" in+out+safe 
 417      s raw_write "[0]":characters 1 
 418      s close 
 419      sleep 0.1 
 420      
 421   
 422  define_tcp_server DnsServer dns_server 
 423  export dns_server dns_refresh dns_hits