sunet/scheme/dnsd/rr-def.scm

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))))