unmaintained/dns/dns.factor

   1
   2 USING: kernel byte-arrays combinators strings arrays sequences splitting
   3        grouping
   4        math math.functions math.parser random
   5        destructors
   6        io io.binary io.sockets io.encodings.binary
   7        accessors
   8        combinators.smart
   9        assocs
  10        ;
  11
  12 IN: dns
  13
  14 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  15
  16 TUPLE: query name type class ;
  17
  18 TUPLE: rr name type class ttl rdata ;
  19
  20 TUPLE: hinfo cpu os ;
  21
  22 TUPLE: mx preference exchange ;
  23
  24 TUPLE: soa mname rname serial refresh retry expire minimum ;
  25
  26 TUPLE: message
  27        id qr opcode aa tc rd ra z rcode
  28        question-section
  29        answer-section
  30        authority-section
  31        additional-section ;
  32
  33 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  34
  35 : random-id ( -- id ) 2 16 ^ random ;
  36
  37 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  38 ! TYPE
  39 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  40
  41 SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT AAAA ;
  42
  43 : type-table ( -- table )
  44   {
  45     { A     1 }
  46     { NS    2 }
  47     { MD    3 }
  48     { MF    4 }
  49     { CNAME 5 }
  50     { SOA   6 }
  51     { MB    7 }
  52     { MG    8 }
  53     { MR    9 }
  54     { NULL  10 }
  55     { WKS   11 }
  56     { PTR   12 }
  57     { HINFO 13 }
  58     { MINFO 14 }
  59     { MX    15 }
  60     { TXT   16 }
  61     { AAAA  28 }
  62   } ;
  63
  64 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  65 ! CLASS
  66 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  67
  68 SYMBOLS: IN CS CH HS ;
  69
  70 : class-table ( -- table )
  71   {
  72     { IN 1 }
  73     { CS 2 }
  74     { CH 3 }
  75     { HS 4 }
  76   } ;
  77
  78 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  79 ! OPCODE
  80 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  81
  82 SYMBOLS: QUERY IQUERY STATUS ;
  83
  84 : opcode-table ( -- table )
  85   {
  86     { QUERY  0 }
  87     { IQUERY 1 }
  88     { STATUS 2 }
  89   } ;
  90
  91 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  92 ! RCODE
  93 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  94
  95 SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
  96          REFUSED ;
  97
  98 : rcode-table ( -- table )
  99   {
 100     { NO-ERROR        0 }
 101     { FORMAT-ERROR    1 }
 102     { SERVER-FAILURE  2 }
 103     { NAME-ERROR      3 }
 104     { NOT-IMPLEMENTED 4 }
 105     { REFUSED         5 }
 106   } ;
 107
 108 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 109
 110 : <message> ( -- message )
 111   message new
 112     random-id >>id
 113     0         >>qr
 114     QUERY     >>opcode
 115     0         >>aa
 116     0         >>tc
 117     1         >>rd
 118     0         >>ra
 119     0         >>z
 120     NO-ERROR  >>rcode
 121     { }       >>question-section
 122     { }       >>answer-section
 123     { }       >>authority-section
 124     { }       >>additional-section ;
 125
 126 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 127
 128 : ip->ba ( ip -- ba ) "." split [ string>number ] map >byte-array ;
 129
 130 : ipv6->ba ( ip -- ba ) ":" split [ hex> ] map [ 2 >be ] map concat ;
 131
 132 : label->ba ( label -- ba ) [ >byte-array ] [ length ] bi prefix ;
 133
 134 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 135
 136 : uint8->ba  ( n -- ba ) 1 >be ;
 137 : uint16->ba ( n -- ba ) 2 >be ;
 138 : uint32->ba ( n -- ba ) 4 >be ;
 139 : uint64->ba ( n -- ba ) 8 >be ;
 140
 141 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 142
 143 : dn->ba ( dn -- ba ) "." split [ label->ba ] map concat ;
 144
 145 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 146
 147 : query->ba ( query -- ba )
 148   [
 149     {
 150       [ name>>                 dn->ba ]
 151       [ type>>  type-table  at uint16->ba ]
 152       [ class>> class-table at uint16->ba ]
 153     } cleave
 154   ] output>array concat ;
 155
 156 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 157
 158 : hinfo->ba ( rdata -- ba )
 159     [ cpu>> label->ba ]
 160     [ os>>  label->ba ]
 161   bi append ;
 162
 163 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 164
 165 : mx->ba ( rdata -- ba )
 166     [ preference>> uint16->ba ]
 167     [ exchange>>   dn->ba ]
 168   bi append ;
 169
 170 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 171
 172 : soa->ba ( rdata -- ba )
 173   [
 174     {
 175       [ mname>>   dn->ba ]
 176       [ rname>>   dn->ba ]
 177       [ serial>>  uint32->ba ]
 178       [ refresh>> uint32->ba ]
 179       [ retry>>   uint32->ba ]
 180       [ expire>>  uint32->ba ]
 181       [ minimum>> uint32->ba ]
 182     } cleave
 183   ] output>array concat ;
 184
 185 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 186
 187 : rdata->ba ( type rdata -- ba )
 188   swap
 189     {
 190       { CNAME [ dn->ba ] }
 191       { HINFO [ hinfo->ba ] }
 192       { MX    [ mx->ba ] }
 193       { NS    [ dn->ba ] }
 194       { PTR   [ dn->ba ] }
 195       { SOA   [ soa->ba ] }
 196       { A     [ ip->ba ] }
 197     }
 198   case ;
 199
 200 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 201
 202 : rr->ba ( rr -- ba )
 203   [
 204     {
 205       [ name>>                 dn->ba     ]
 206       [ type>>  type-table  at uint16->ba ]
 207       [ class>> class-table at uint16->ba ]
 208       [ ttl>>   uint32->ba ]
 209       [
 210         [ type>>            ] [ rdata>> ] bi rdata->ba
 211         [ length uint16->ba ] [         ] bi append
 212       ]
 213     } cleave
 214   ] output>array concat ;
 215
 216 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 217
 218 : header-bits-ba ( message -- ba )
 219   [
 220     {
 221       [ qr>>                     15 shift ]
 222       [ opcode>> opcode-table at 11 shift ]
 223       [ aa>>                     10 shift ]
 224       [ tc>>                      9 shift ]
 225       [ rd>>                      8 shift ]
 226       [ ra>>                      7 shift ]
 227       [ z>>                       4 shift ]
 228       [ rcode>>  rcode-table at   0 shift ]
 229     } cleave
 230   ] sum-outputs uint16->ba ;
 231
 232 : message->ba ( message -- ba )
 233   [
 234     {
 235       [ id>> uint16->ba ]
 236       [ header-bits-ba ]
 237       [ question-section>>   length uint16->ba ]
 238       [ answer-section>>     length uint16->ba ]
 239       [ authority-section>>  length uint16->ba ]
 240       [ additional-section>> length uint16->ba ]
 241       [ question-section>>   [ query->ba ] map concat ]
 242       [ answer-section>>     [ rr->ba    ] map concat ]
 243       [ authority-section>>  [ rr->ba    ] map concat ]
 244       [ additional-section>> [ rr->ba    ] map concat ]
 245     } cleave
 246   ] output>array concat ;
 247
 248 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 249
 250 : get-single ( ba i -- n ) at ;
 251 : get-double ( ba i -- n ) dup 2 + subseq be> ;
 252 : get-quad   ( ba i -- n ) dup 4 + subseq be> ;
 253
 254 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 255
 256 : label-length ( ba i -- length ) get-single ;
 257
 258 : skip-label ( ba i -- ba i ) 2dup label-length + 1 + ;
 259
 260 : null-label? ( ba i -- ? ) get-single 0 = ;
 261
 262 : get-label ( ba i -- label ) [ 1 + ] [ skip-label nip ] 2bi subseq >string ;
 263
 264 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 265
 266 : bit-test ( a b -- ? ) bitand 0 = not ;
 267
 268 : pointer? ( ba i -- ? ) get-single 0b11000000 bit-test ;
 269
 270 : pointer ( ba i -- val ) get-double 0b0011111111111111 bitand ;
 271
 272 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 273
 274 : skip-name ( ba i -- ba i )
 275     {
 276       { [ 2dup null-label? ] [ 1 + ] }
 277       { [ 2dup pointer?    ] [ 2 + ] }
 278       { [ t ] [ skip-label skip-name ] }
 279     }
 280   cond ;
 281
 282 : get-name ( ba i -- name )
 283     {
 284       { [ 2dup null-label? ] [ 2drop "" ] }
 285       { [ 2dup pointer?    ] [ dupd pointer get-name ] }
 286       {
 287         [ t ]
 288         [
 289           [ get-label ]
 290           [ skip-label get-name ]
 291           2bi
 292           "." glue
 293         ]
 294       }
 295     }
 296   cond ;
 297
 298 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 299
 300 : get-query ( ba i -- query )
 301     [ get-name ]
 302     [
 303       skip-name
 304       [ 0 + get-double type-table  value-at ]
 305       [ 2 + get-double class-table value-at ]
 306       2bi
 307     ]
 308   2bi query boa ;
 309
 310 : skip-query ( ba i -- ba i ) skip-name 4 + ;
 311
 312 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 313
 314 : get-mx ( ba i -- mx ) [ get-double ] [ 2 + get-double ] 2bi mx boa ;
 315
 316 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 317
 318 : get-soa ( ba i -- soa )
 319     {
 320       [           get-name ]
 321       [ skip-name get-name ]
 322       [
 323         skip-name
 324         skip-name
 325         {
 326           [  0 + get-quad ]
 327           [  4 + get-quad ]
 328           [  8 + get-quad ]
 329           [ 12 + get-quad ]
 330           [ 16 + get-quad ]
 331         }
 332           2cleave
 333       ]
 334     }
 335   2cleave soa boa ;
 336
 337 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 338
 339 : get-ip ( ba i -- ip ) dup 4 + subseq >array [ number>string ] map "." join ;
 340
 341 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 342
 343 : get-ipv6 ( ba i -- ip )
 344   dup 16 + subseq 2 group [ be> >hex ] map ":" join ;
 345
 346 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 347
 348 : get-rdata ( ba i type -- rdata )
 349     {
 350       { CNAME [ get-name ] }
 351       { NS    [ get-name ] }
 352       { PTR   [ get-name ] }
 353       { MX    [ get-mx   ] }
 354       { SOA   [ get-soa  ] }
 355       { A     [ get-ip   ] }
 356       { AAAA  [ get-ipv6 ] }
 357     }
 358   case ;
 359
 360 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 361
 362 : get-rr ( ba i -- rr )
 363   [ get-name ]
 364   [
 365     skip-name
 366       {
 367         [ 0 + get-double type-table  value-at ]
 368         [ 2 + get-double class-table value-at ]
 369         [ 4 + get-quad   ]
 370         [ [ 10 + ] [ get-double type-table value-at ] 2bi get-rdata ]
 371       }
 372     2cleave
 373   ]
 374     2bi rr boa ;
 375
 376 : skip-rr ( ba i -- ba i ) skip-name 8 + 2dup get-double + 2 + ;
 377
 378 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 379
 380 : get-question-section ( ba i count -- seq ba i )
 381   [ drop [ skip-query ] [ get-query ] 2bi ] map -rot ;
 382
 383 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 384
 385 : get-rr-section ( ba i count -- seq ba i )
 386   [ drop [ skip-rr ] [ get-rr ] 2bi ] map -rot ;
 387
 388 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 389
 390 : >> ( x n -- y ) neg shift ;
 391
 392 : get-header-bits ( ba i -- qr opcode aa tc rd ra z rcode )
 393     get-double
 394     {
 395       [ 15 >> 0b1 bitand ]
 396       [ 11 >> 0b111 bitand opcode-table value-at ]
 397       [ 10 >> 0b1 bitand ]
 398       [  9 >> 0b1 bitand ]
 399       [  8 >> 0b1 bitand ]
 400       [  7 >> 0b1 bitand ]
 401       [  4 >> 0b111 bitand ]
 402       [       0b1111 bitand rcode-table value-at ]
 403     }
 404   cleave ;
 405
 406 : parse-message ( ba -- message )
 407   0
 408   {
 409     [ get-double ]
 410     [ 2 + get-header-bits ]
 411     [
 412       4 +
 413       {
 414         [ 8 +            ]
 415         [ 0 + get-double ]
 416         [ 2 + get-double ]
 417         [ 4 + get-double ]
 418         [ 6 + get-double ]
 419       }
 420         2cleave
 421       {
 422         [ get-question-section ]
 423         [ get-rr-section ]
 424         [ get-rr-section ]
 425         [ get-rr-section ]
 426       } spread
 427       2drop
 428     ]
 429   }
 430     2cleave message boa ;
 431
 432 : ba->message ( ba -- message ) parse-message ;
 433
 434 : with-message-bytes ( ba quot -- ) [ ba->message ] dip call message->ba ; inline
 435
 436 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 437
 438 : send-receive-udp ( ba server -- ba )
 439   f 0 <inet4> <datagram>
 440     [
 441       [ send ] [ receive drop ] bi
 442     ]
 443   with-disposal ;
 444
 445 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 446
 447 : send-receive-tcp ( ba server -- ba )
 448   [ dup length 2 >be prepend ] [ ] bi*
 449   binary
 450     [
 451       write flush
 452       2 read be> read
 453     ]
 454   with-client ;
 455
 456 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 457
 458 : >dns-inet4 ( obj -- inet4 )
 459   dup string?
 460     [ 53 <inet4> ]
 461     [            ]
 462   if ;
 463
 464 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 465
 466 : ask-server ( message server -- message )
 467   [ message->ba ] [ >dns-inet4 ] bi*
 468   2dup
 469   send-receive-udp parse-message
 470   dup tc>> 1 =
 471     [ drop send-receive-tcp parse-message ]
 472     [ nip nip                             ]
 473   if ;
 474
 475 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 476
 477 : dns-servers ( -- seq ) V{ } ;
 478
 479 : dns-server ( -- server ) dns-servers random ;
 480
 481 : ask ( message -- message ) dns-server ask-server ;
 482
 483 : query->message ( query -- message ) <message> swap 1array >>question-section ;
 484
 485 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 486
 487 : message-query ( message -- query ) question-section>> first ;
 488
 489 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 490
 491 ERROR: name-error name ;
 492
 493 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 494
 495 : fully-qualified ( name -- name )
 496     {
 497       { [ dup empty?         ] [ "." append ] }
 498       { [ dup last CHAR: . = ] [            ] }
 499       { [ t                  ] [ "." append ] }
 500     }
 501   cond ;