178 lines
5.0 KiB
Scheme
178 lines
5.0 KiB
Scheme
; ----------------------------------
|
|
; --- Resource-Record-Definition ---
|
|
; ----------------------------------
|
|
|
|
; Wrapper for (make-resource-record ___) from dns.scm:
|
|
; * Abstraction of (make-resource-record ___ (make-resource-record-data-* ___))
|
|
; * Now for all supported types: (dns-rr-<type> ...)
|
|
|
|
|
|
; This file is part of the Scheme Untergrund Networking package
|
|
|
|
; Copyright (c) 2005/2006 by Norbert Freudemann
|
|
; <nofreude@informatik.uni-tuebingen.de>
|
|
|
|
; For copyright information, see the file COPYING which comes with
|
|
; the distribution.
|
|
|
|
|
|
; Interface:
|
|
|
|
; (dns-rr-a ...)
|
|
; (dns-rr-txt ...)
|
|
; etc..
|
|
|
|
|
|
|
|
; Abstraction of (make-resource-record ... (make-resource-record-data-* ...))
|
|
; Now: (dns-rr-* ...), trying to include data-integrity.
|
|
|
|
; *** Some stuff ***
|
|
|
|
(define (make-message-class class)
|
|
(cond
|
|
((number? class)
|
|
(message-class-number->type class))
|
|
((symbol? class)
|
|
(message-class-symbol->type class))
|
|
((message-class? class)
|
|
class)
|
|
(else #f)))
|
|
|
|
(define (make-message-type type)
|
|
(cond
|
|
((number? type)
|
|
(message-type-number->type type))
|
|
((symbol? type)
|
|
(message-type-symbol->type type))
|
|
((message-type? type)
|
|
type)
|
|
(else #f)))
|
|
|
|
(define (make-address32 ip)
|
|
(cond
|
|
((address32? ip) ip)
|
|
((ip-string? ip)
|
|
(ip-string->address32 ip))
|
|
(else #f)))
|
|
|
|
|
|
; Nice to know: valid ttls: 0-2147483647
|
|
|
|
; *02* - (dns-rr-* ...) functions:
|
|
|
|
; Warning: This functions won't work with any other class than 'IN'!
|
|
|
|
; TYPES: name x class x ttl x data -> resource-record-record-type or #f
|
|
|
|
(define (dns-rr-a name class ttl data)
|
|
(and-let* ((name (make-fqdn-name name))
|
|
(whatever (fqdn? name))
|
|
(class (make-message-class class))
|
|
(whatever (eq? class (message-class in)))
|
|
(a32 (make-address32 data)))
|
|
(make-resource-record
|
|
name (message-type a)
|
|
class ttl
|
|
(make-resource-record-data-a a32))))
|
|
|
|
(define (dns-rr-ns name class ttl data)
|
|
(and-let* ((name (make-fqdn-name name))
|
|
(whatever (fqdn? name))
|
|
(class (make-message-class class))
|
|
(whatever (eq? class (message-class in)))
|
|
(ns-name (make-fqdn-name data))
|
|
(whatever (fqdn? ns-name)))
|
|
(make-resource-record
|
|
name (message-type ns)
|
|
class ttl
|
|
(make-resource-record-data-ns ns-name))))
|
|
|
|
(define (dns-rr-cname name class ttl data)
|
|
(and-let* ((name (make-fqdn-name name))
|
|
(whatever (fqdn? name))
|
|
(class (make-message-class class))
|
|
(whatever (eq? class (message-class in)))
|
|
(cname-name (make-fqdn-name data))
|
|
(whatever (fqdn? cname-name)))
|
|
(make-resource-record
|
|
name (message-type cname)
|
|
class ttl
|
|
(make-resource-record-data-cname cname-name))))
|
|
|
|
(define (dns-rr-soa name class ttl data)
|
|
(and-let* ((name (make-fqdn-name name))
|
|
(whatever (fqdn? name))
|
|
(class (make-message-class class))
|
|
(whatever (eq? class (message-class in)))
|
|
(mname (make-fqdn-name (car data)))
|
|
(whatever (fqdn? mname))
|
|
(rname (make-fqdn-name (cadr data)))) ;! what's with fqdn...
|
|
(make-resource-record
|
|
name (message-type soa)
|
|
class ttl
|
|
(make-resource-record-data-soa
|
|
mname rname
|
|
(caddr data)
|
|
(cadddr data)
|
|
(cadr (cdddr data))
|
|
(caddr (cdddr data))
|
|
(cadddr (cdddr data))))))
|
|
|
|
(define (dns-rr-ptr name class ttl data)
|
|
(and-let* ((name (make-fqdn-name name))
|
|
(whatever (fqdn? name))
|
|
(class (make-message-class class))
|
|
(whatever (eq? class (message-class in)))
|
|
(ptr-name (make-fqdn-name data))
|
|
(whatever (fqdn? ptr-name)))
|
|
(make-resource-record
|
|
name (message-type ptr)
|
|
class ttl
|
|
(make-resource-record-data-ptr ptr-name))))
|
|
|
|
(define (dns-rr-hinfo name class ttl data)
|
|
(and-let* ((name (make-fqdn-name name))
|
|
(whatever (fqdn? name))
|
|
(class (make-message-class class))
|
|
(whatever (eq? class (message-class in))))
|
|
(make-resource-record
|
|
name (message-type hinfo)
|
|
class ttl
|
|
(make-resource-record-data-hinfo data))))
|
|
|
|
(define (dns-rr-mx name class ttl data)
|
|
(and-let* ((name (make-fqdn-name name))
|
|
(whatever (fqdn? name))
|
|
(class (make-message-class class))
|
|
(whatever (eq? class (message-class in)))
|
|
(pref (car data))
|
|
(whatever (number? pref))
|
|
(mx-name (make-fqdn-name (cadr data)))
|
|
(whatever (fqdn? mx-name)))
|
|
(make-resource-record
|
|
name (message-type mx)
|
|
class ttl
|
|
(make-resource-record-data-mx
|
|
pref mx-name))))
|
|
|
|
(define (dns-rr-txt name class ttl data)
|
|
(and-let* ((name (make-fqdn-name name))
|
|
(whatever (fqdn? name))
|
|
(class (make-message-class class))
|
|
(whatever (eq? class (message-class in))))
|
|
(make-resource-record
|
|
name (message-type txt)
|
|
class ttl
|
|
(make-resource-record-data-txt data))))
|
|
|
|
(define (dns-rr-aaaa name class ttl data)
|
|
(and-let* ((name (make-fqdn-name name))
|
|
(whatever (fqdn? name))
|
|
(class (make-message-class class))
|
|
(whatever (eq? class (message-class in))))
|
|
(make-resource-record
|
|
name (message-type aaaa)
|
|
class ttl
|
|
(make-resource-record-data-aaaa data))))
|