sunet/scheme/dnsd/rr-def.scm

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