extra/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.cleave
   9        newfx
  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 [ 16 base> ] 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       [ name>>                 dn->ba ]
 150       [ type>>  type-table  of uint16->ba ]
 151       [ class>> class-table of uint16->ba ]
 152     }
 153   <arr> concat ;
 154
 155 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 156
 157 : hinfo->ba ( rdata -- ba )
 158     [ cpu>> label->ba ]
 159     [ os>>  label->ba ]
 160   bi append ;
 161
 162 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 163
 164 : mx->ba ( rdata -- ba )
 165     [ preference>> uint16->ba ]
 166     [ exchange>>   dn->ba ]
 167   bi append ;
 168
 169 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 170
 171 : soa->ba ( rdata -- ba )
 172     {
 173       [ mname>>   dn->ba ]
 174       [ rname>>   dn->ba ]
 175       [ serial>>  uint32->ba ]
 176       [ refresh>> uint32->ba ]
 177       [ retry>>   uint32->ba ]
 178       [ expire>>  uint32->ba ]
 179       [ minimum>> uint32->ba ]
 180     }
 181   <arr> concat ;
 182
 183 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 184
 185 : rdata->ba ( type rdata -- ba )
 186   swap
 187     {
 188       { CNAME [ dn->ba ] }
 189       { HINFO [ hinfo->ba ] }
 190       { MX    [ mx->ba ] }
 191       { NS    [ dn->ba ] }
 192       { PTR   [ dn->ba ] }
 193       { SOA   [ soa->ba ] }
 194       { A     [ ip->ba ] }
 195     }
 196   case ;
 197
 198 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 199
 200 : rr->ba ( rr -- ba )
 201     {
 202       [ name>>                 dn->ba     ]
 203       [ type>>  type-table  of uint16->ba ]
 204       [ class>> class-table of uint16->ba ]
 205       [ ttl>>   uint32->ba ]
 206       [
 207         [ type>>            ] [ rdata>> ] bi rdata->ba
 208         [ length uint16->ba ] [         ] bi append
 209       ]
 210     }
 211   <arr> concat ;
 212
 213 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 214
 215 : header-bits-ba ( message -- ba )
 216     {
 217       [ qr>>                     15 shift ]
 218       [ opcode>> opcode-table of 11 shift ]
 219       [ aa>>                     10 shift ]
 220       [ tc>>                      9 shift ]
 221       [ rd>>                      8 shift ]
 222       [ ra>>                      7 shift ]
 223       [ z>>                       4 shift ]
 224       [ rcode>>  rcode-table of   0 shift ]
 225     }
 226   <arr> sum uint16->ba ;
 227
 228 : message->ba ( message -- ba )
 229     {
 230       [ id>> uint16->ba ]
 231       [ header-bits-ba ]
 232       [ question-section>>   length uint16->ba ]
 233       [ answer-section>>     length uint16->ba ]
 234       [ authority-section>>  length uint16->ba ]
 235       [ additional-section>> length uint16->ba ]
 236       [ question-section>>   [ query->ba ] map concat ]
 237       [ answer-section>>     [ rr->ba    ] map concat ]
 238       [ authority-section>>  [ rr->ba    ] map concat ]
 239       [ additional-section>> [ rr->ba    ] map concat ]
 240     }
 241   <arr> concat ;
 242
 243 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 244
 245 : get-single ( ba i -- n ) at ;
 246 : get-double ( ba i -- n ) dup 2 + subseq be> ;
 247 : get-quad   ( ba i -- n ) dup 4 + subseq be> ;
 248
 249 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 250
 251 : label-length ( ba i -- length ) get-single ;
 252
 253 : skip-label ( ba i -- ba i ) 2dup label-length + 1 + ;
 254
 255 : null-label? ( ba i -- ? ) get-single 0 = ;
 256
 257 : get-label ( ba i -- label ) [ 1 + ] [ skip-label nip ] 2bi subseq >string ;
 258
 259 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 260
 261 : bit-test ( a b -- ? ) bitand 0 = not ;
 262
 263 : pointer? ( ba i -- ? ) get-single BIN: 11000000 bit-test ;
 264
 265 : pointer ( ba i -- val ) get-double BIN: 0011111111111111 bitand ;
 266
 267 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 268
 269 : skip-name ( ba i -- ba i )
 270     {
 271       { [ 2dup null-label? ] [ 1 + ] }
 272       { [ 2dup pointer?    ] [ 2 + ] }
 273       { [ t ] [ skip-label skip-name ] }
 274     }
 275   cond ;
 276
 277 : get-name ( ba i -- name )
 278     {
 279       { [ 2dup null-label? ] [ 2drop "" ] }
 280       { [ 2dup pointer?    ] [ dupd pointer get-name ] }
 281       {
 282         [ t ]
 283         [
 284           [ get-label ]
 285           [ skip-label get-name ]
 286           2bi
 287           "." glue
 288         ]
 289       }
 290     }
 291   cond ;
 292
 293 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 294
 295 : get-query ( ba i -- query )
 296     [ get-name ]
 297     [
 298       skip-name
 299       [ 0 + get-double type-table  key-of ]
 300       [ 2 + get-double class-table key-of ]
 301       2bi
 302     ]
 303   2bi query boa ;
 304
 305 : skip-query ( ba i -- ba i ) skip-name 4 + ;
 306
 307 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 308
 309 : get-mx ( ba i -- mx ) [ get-double ] [ 2 + get-double ] 2bi mx boa ;
 310
 311 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 312
 313 : get-soa ( ba i -- soa )
 314     {
 315       [           get-name ]
 316       [ skip-name get-name ]
 317       [
 318         skip-name
 319         skip-name
 320         {
 321           [  0 + get-quad ]
 322           [  4 + get-quad ]
 323           [  8 + get-quad ]
 324           [ 12 + get-quad ]
 325           [ 16 + get-quad ]
 326         }
 327           2cleave
 328       ]
 329     }
 330   2cleave soa boa ;
 331
 332 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 333
 334 : get-ip ( ba i -- ip ) dup 4 + subseq >array [ number>string ] map "." join ;
 335
 336 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 337
 338 : get-ipv6 ( ba i -- ip )
 339   dup 16 + subseq 2 group [ be> 16 >base ] map ":" join ;
 340
 341 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 342
 343 : get-rdata ( ba i type -- rdata )
 344     {
 345       { CNAME [ get-name ] }
 346       { NS    [ get-name ] }
 347       { PTR   [ get-name ] }
 348       { MX    [ get-mx   ] }
 349       { SOA   [ get-soa  ] }
 350       { A     [ get-ip   ] }
 351       { AAAA  [ get-ipv6 ] }
 352     }
 353   case ;
 354
 355 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 356
 357 : get-rr ( ba i -- rr )
 358   [ get-name ]
 359   [
 360     skip-name
 361       {
 362         [ 0 + get-double type-table  key-of ]
 363         [ 2 + get-double class-table key-of ]
 364         [ 4 + get-quad   ]
 365         [ [ 10 + ] [ get-double type-table key-of ] 2bi get-rdata ]
 366       }
 367     2cleave
 368   ]
 369     2bi rr boa ;
 370
 371 : skip-rr ( ba i -- ba i ) skip-name 8 + 2dup get-double + 2 + ;
 372
 373 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 374
 375 : get-question-section ( ba i count -- seq ba i )
 376   [ drop [ skip-query ] [ get-query ] 2bi ] map -rot ;
 377
 378 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 379
 380 : get-rr-section ( ba i count -- seq ba i )
 381   [ drop [ skip-rr ] [ get-rr ] 2bi ] map -rot ;
 382
 383 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 384
 385 : >> ( x n -- y ) neg shift ;
 386
 387 : get-header-bits ( ba i -- qr opcode aa tc rd ra z rcode )
 388     get-double
 389     {
 390       [ 15 >> BIN:    1 bitand ]
 391       [ 11 >> BIN:  111 bitand opcode-table key-of ]
 392       [ 10 >> BIN:    1 bitand ]
 393       [  9 >> BIN:    1 bitand ]
 394       [  8 >> BIN:    1 bitand ]
 395       [  7 >> BIN:    1 bitand ]
 396       [  4 >> BIN:  111 bitand ]
 397       [       BIN: 1111 bitand rcode-table key-of ]
 398     }
 399   cleave ;
 400
 401 : parse-message ( ba -- message )
 402   0
 403   {
 404     [ get-double ]
 405     [ 2 + get-header-bits ]
 406     [
 407       4 +
 408       {
 409         [ 8 +            ]
 410         [ 0 + get-double ]
 411         [ 2 + get-double ]
 412         [ 4 + get-double ]
 413         [ 6 + get-double ]
 414       }
 415         2cleave
 416       >r >r >r
 417       get-question-section r>
 418       get-rr-section       r>
 419       get-rr-section       r>
 420       get-rr-section
 421       2drop
 422     ]
 423   }
 424     2cleave message boa ;
 425
 426 : ba->message ( ba -- message ) parse-message ;
 427
 428 : with-message-bytes ( ba quot -- ) >r ba->message r> call message->ba ; inline
 429
 430 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 431
 432 : send-receive-udp ( ba server -- ba )
 433   f 0 <inet4> <datagram>
 434     [
 435       [ send ] [ receive drop ] bi
 436     ]
 437   with-disposal ;
 438
 439 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 440
 441 : send-receive-tcp ( ba server -- ba )
 442   [ dup length 2 >be prepend ] [ ] bi*
 443   binary
 444     [
 445       write flush
 446       2 read be> read
 447     ]
 448   with-client ;
 449
 450 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 451
 452 : >dns-inet4 ( obj -- inet4 )
 453   dup string?
 454     [ 53 <inet4> ]
 455     [            ]
 456   if ;
 457
 458 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 459
 460 : ask-server ( message server -- message )
 461   [ message->ba ] [ >dns-inet4 ] bi*
 462   2dup
 463   send-receive-udp parse-message
 464   dup tc>> 1 =
 465     [ drop send-receive-tcp parse-message ]
 466     [ nip nip                             ]
 467   if ;
 468
 469 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 470
 471 : dns-servers ( -- seq ) V{ } ;
 472
 473 : dns-server ( -- server ) dns-servers random ;
 474
 475 : ask ( message -- message ) dns-server ask-server ;
 476
 477 : query->message ( query -- message ) <message> swap {1} >>question-section ;
 478
 479 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 480
 481 : message-query ( message -- query ) question-section>> 1st ;
 482
 483 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 484
 485 ERROR: name-error name ;
 486
 487 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 488
 489 : fully-qualified ( name -- name )
 490     {
 491       { [ dup empty?         ] [ "." append ] }
 492       { [ dup peek CHAR: . = ] [            ] }
 493       { [ t                  ] [ "." append ] }
 494     }
 495   cond ;