77 lines
2.9 KiB
Racket
77 lines
2.9 KiB
Racket
#lang racket/base
|
|
;; DNS drivers using marketplace.
|
|
;;
|
|
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
|
|
;;;
|
|
;;; This file is part of marketplace-dns.
|
|
;;;
|
|
;;; marketplace-dns is free software: you can redistribute it and/or
|
|
;;; modify it under the terms of the GNU General Public License as
|
|
;;; published by the Free Software Foundation, either version 3 of the
|
|
;;; License, or (at your option) any later version.
|
|
;;;
|
|
;;; marketplace-dns is distributed in the hope that it will be useful,
|
|
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;; General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with marketplace-dns. If not, see
|
|
;;; <http://www.gnu.org/licenses/>.
|
|
|
|
(require racket/set)
|
|
(require racket/match)
|
|
(require "codec.rkt")
|
|
(require syndicate/actor)
|
|
(require syndicate/protocol/standard-relay)
|
|
(require syndicate/drivers/udp)
|
|
|
|
(provide (struct-out bad-dns-packet)
|
|
(struct-out dns-request)
|
|
(struct-out dns-reply)
|
|
dns-read-driver
|
|
dns-write-driver
|
|
dns-spy)
|
|
|
|
(struct bad-dns-packet (detail source sink reason) #:transparent)
|
|
(struct dns-request (message source sink) #:transparent)
|
|
(struct dns-reply (message source sink) #:transparent)
|
|
|
|
(define (dns-read-driver s)
|
|
(spawn
|
|
#:name (list 'dns-read-driver s)
|
|
(on (message (inbound (udp-packet $source s #"")))
|
|
(log-info "Debug dump packet received")
|
|
(send! `(debug-dump)))
|
|
(on (message (inbound (udp-packet $source s $body)))
|
|
(when (positive? (bytes-length body))
|
|
(send!
|
|
(with-handlers ((exn:fail? (lambda (e)
|
|
(bad-dns-packet body source s 'unparseable))))
|
|
(define message (packet->dns-message body))
|
|
(case (dns-message-direction message)
|
|
((request) (dns-request message source s))
|
|
((response) (dns-reply message source s)))))))))
|
|
|
|
(define (translate message s sink)
|
|
(with-handlers ((exn:fail? (lambda (e) (bad-dns-packet message s sink 'unencodable))))
|
|
(outbound (udp-packet s sink (dns-message->packet message)))))
|
|
|
|
(define (dns-write-driver s)
|
|
(spawn #:name (list 'dns-write-driver s)
|
|
(on (message (dns-request $message s $sink))
|
|
(send! (translate message s sink)))
|
|
(on (message (dns-reply $message s $sink))
|
|
(send! (translate message s sink)))))
|
|
|
|
(define (dns-spy)
|
|
(spawn #:name 'dns-spy
|
|
(on (message (dns-request $message $source $sink))
|
|
(log-info (format "DNS: ~v asks ~v ~v~n : ~v"
|
|
source sink (dns-message-id message)
|
|
(dns-message-questions message))))
|
|
(on (message (dns-reply $message $source $sink))
|
|
(log-info (format "DNS: ~v answers ~v~n : ~v"
|
|
source sink
|
|
message)))))
|