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