sunet/scheme/dnsd/db-options.scm

;; ------------------------
;; --- Database-Options ---
;; ------------------------

; Database-Options for DNS-Server based on the RFCs: 1034 / 1035 

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

; The format and style of the option procedures is the same as seen 
; in the SUNet HTTPD & FTPD - Files


(define-record-type dnsddb-options :dnsddb-options
  (really-make-dnsddb-options name class type primary? file filetype master-name master-ip)
  dnsddb-options?
  (name        dnsddb-options-name        set-dnsddb-options-name!)
  (class       dnsddb-options-class       set-dnsddb-options-class!)
  (type        dnsddb-options-type        set-dnsddb-options-type!)
  (primary?    dnsddb-options-primary?    set-dnsddb-options-primary?!) ;;depreaced
  (file        dnsddb-options-file        set-dnsddb-options-file!)
  (filetype    dnsddb-options-filetype    set-dnsddb-options-filetype!)
  (master-name dnsddb-options-master-name set-dnsddb-options-master-name!)
  (master-ip   dnsddb-options-master-ip   set-dnsddb-options-master-ip!))


(define (make-default-dnsddb-options)
  (really-make-dnsddb-options 
   ""        ;; the name of the zone
   (message-class in)
   "primary" ;;
   #t        ;; is primary?
   ""        ;; a filename
   "dnsd"    ;; "dnsd" or "rfc"
   #f        ;; Has to be set by dnsd-zones.scm, e.g. "dns01.my.example."
   #f))      ;; e.g. "192.168.2.1" or #f


(define (copy-dnsddb-options options)
  (really-make-dnsddb-options 
   (dnsddb-options-name options)
   (dnsddb-options-class options)
   (dnsddb-options-type options)
   (dnsddb-options-primary? options)
   (dnsddb-options-file options)
   (dnsddb-options-filetype options)
   (dnsddb-options-master-name options)
   (dnsddb-options-master-ip options)))


(define (make-dnsddb-options-transformer set-option!)
  (lambda (new-value . stuff)
    (let ((new-options (if (not (null? stuff))
			   (copy-dnsddb-options (car stuff))
			   (make-default-dnsddb-options))))
      (set-option! new-options new-value)
      new-options)))


(define with-name
  (make-dnsddb-options-transformer set-dnsddb-options-name!))
(define with-class
  (make-dnsddb-options-transformer set-dnsddb-options-class!))
(define with-type
  (make-dnsddb-options-transformer set-dnsddb-options-type!))
(define with-primary?
  (make-dnsddb-options-transformer set-dnsddb-options-primary?!))
(define with-file
  (make-dnsddb-options-transformer set-dnsddb-options-file!))
(define with-filetype
  (make-dnsddb-options-transformer set-dnsddb-options-filetype!))
(define with-master-name
  (make-dnsddb-options-transformer set-dnsddb-options-master-name!))
(define with-master-ip
  (make-dnsddb-options-transformer set-dnsddb-options-master-ip!))


(define (make-dnsddb-options . stuff)
  (let loop ((options (make-default-dnsddb-options))
	     (stuff stuff))
    (if (null? stuff)
	options
	(let* ((transformer (car stuff))
	       (value (cadr stuff)))
	  (loop (transformer value options)
		(cddr stuff))))))


(define (make-db-options-from-list o-list)
  (let ((options (make-default-dnsddb-options)))
    (if (eq? (car o-list) 'zone)
	(begin
	  (for-each 
	   (lambda (e)
	     (let ((id (car e))
		   (value (cadr e)))
	       (case id
		 ((name)
		  (if (string? value)
		      (set-dnsddb-options-name! 
		       options (make-fqdn-name value))
		      (error "Bad option argument.")))
		 ((type)
		  (if (or (string-ci=? "primary" value) 
			  (string-ci=? "secondary" value)
			  (string-ci=? "master" value)
			  (string-ci=? "slave" value))
		      (set-dnsddb-options-type! options value)
		      (error "Bad option argument.")))
		 ((file)
		  (if (and (string? value) (file-name-non-directory? value))
		      (set-dnsddb-options-file! options value)
		      (error "Bad option argument.")))
		 ((filetype)
		  (if (or (string-ci=? "dnsd" value) 
			  (string-ci=? "rfc" value))
		      (set-dnsddb-options-filetype! options value)
		      (error "Bad option argument.")))
		 ((master-name)
		  (if (string? value)
		      (set-dnsddb-options-master-name! options value)
		      (error "Bad option argument.")))
		 ((master-ip)
		  (if (string? value)
		      (set-dnsddb-options-master-ip! options value)
		      (error "Bad option argument.")))
		 (else (error "Bad option.")))))
	   (cdr o-list))
	  options)
	(error "Not an option list."))))