aboutsummaryrefslogtreecommitdiff
path: root/examples/whoisd.scm
diff options
context:
space:
mode:
Diffstat (limited to 'examples/whoisd.scm')
-rw-r--r--examples/whoisd.scm239
1 files changed, 198 insertions, 41 deletions
diff --git a/examples/whoisd.scm b/examples/whoisd.scm
index 7cce910..b433709 100644
--- a/examples/whoisd.scm
+++ b/examples/whoisd.scm
@@ -18,9 +18,10 @@
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;;;;
-(set! %load-path (append %load-path (list "/usr/local/lib/guile")))
+(set! %load-path (append %load-path (list "/usr/local/share/guile-sql")))
(use-modules (ice-9 getopt-long))
-(use-modules (util sql))
+(use-modules (ice-9 format))
+(use-modules (sql))
;;; User-definable variables
(define sql-iface "mysql")
@@ -29,6 +30,7 @@
(define sql-database "whois")
(define sql-username "whois")
(define sql-password "secret")
+(define base-domain-list (list "domain.com" "domain.net"))
;;; End of user-definable variables
(define progname "whoisd")
@@ -77,7 +79,52 @@
fields)
(else
(append fields (list str))))))
-
+
+(define (whitespace? ch)
+ (or
+ (char=? ch #\space)
+ (char=? ch #\ht)))
+
+(define (string-empty? line)
+ (do ((i 0 (+ i 1)))
+ ((or
+ (= i (string-length line))
+ (not (whitespace? (string-ref line i))))
+ (= i (string-length line)))))
+
+(define (whitespace-index str ind)
+ (let ((space (string-index str #\space ind))
+ (ht (string-index str #\ht ind)))
+ (if (and space ht)
+ (min space ht)
+ (or space ht))))
+
+(define (word-index str ind)
+ (let ((x (whitespace-index str ind)))
+ (if x
+ (do ((i x (+ i 1)))
+ ((or
+ (= i (string-length str))
+ (not (whitespace? (string-ref str i))))
+ i))
+ ind)))
+
+(define (string->list str)
+ (let loop ((fields '())
+ (ind (if (whitespace? (string-ref str 0))
+ (word-index str 0)
+ 0)))
+ (cond
+ ((whitespace-index str ind)
+ => (lambda (w)
+ (loop
+ (append fields (list (substring str ind w)))
+ (word-index str ind))))
+ ((= ind (string-length str))
+ fields)
+ (else
+ (append fields (list (substring str ind (string-length str))))))))
+
(define (display-multiline prefix text port)
(if text
(display-list prefix (multiline->list text) port)))
@@ -87,7 +134,13 @@
(number->string code))
text port))
-(define (whois-query port conn key)
+(define (whois-warning port code . text)
+ (debug 1 "TEXT " text)
+ (display-list (string-append "%WARNING:"
+ (number->string code))
+ text port))
+
+(define (whois-query-primitive port conn key)
(debug 2 "key " key)
(let ((dom-res (sql-query conn (string-append
"SELECT \
@@ -107,7 +160,7 @@ WHERE domain=\"" key "\"")))
WHERE domain=\"" key "\""))))
(debug 2 "result: " dom-res)
(if (null? dom-res)
- (whois-error port 100 "No entries found")
+ #f
(let ((dr (car dom-res)))
(display "domain: " port)(display (car dr) port)(newline port)
(display-multiline "descr" (list-ref dr 1) port)
@@ -126,7 +179,33 @@ WHERE domain=\"" key "\""))))
(display (list-ref dr 6) port)
(newline port)
(newline port)
- (force-output port)))))
+ (force-output port)
+ #t))))
+
+(define (whois-query port conn key args)
+ (let* ((keyval (string-downcase key))
+ (result (whois-query-primitive port conn keyval)))
+ (cond
+ ((member #:-L args)
+ (whois-warning port 200
+ (string-append "Exact key " key " was not found.")
+ "Less specific matches follow")
+ (if (not (do ((res (whois-query-primitive port conn keyval)
+ (or (whois-query-primitive port conn keyval) res)))
+ ((or (member keyval base-domain-list)
+ (begin
+ (set! keyval (strip-element keyval))
+ (not keyval)))
+ res)))
+ (whois-error port 100 "No entries found")))
+ ((not result)
+ (whois-error port 100 "No entries found")))))
+
+(define (strip-element name)
+ (let ((index (string-index name #\.)))
+ (if index
+ (substring name (1+ index))
+ #f)))
(define whois-standalone #t)
(define single-process #f)
@@ -146,6 +225,12 @@ WHERE domain=\"" key "\""))))
(debug 1 "Timed out in waiting for input")
(exit 1))
+(define (strip-cr str)
+ (let ((len (string-length str)))
+ (if (char=? (string-ref str (- len 1)))
+ (substring str 0 (- len 1))
+ str)))
+
(define (read-or-timeout port)
(sigaction SIGALRM sigalrm-handler)
(alarm whoisd-idle-timeout)
@@ -153,22 +238,87 @@ WHERE domain=\"" key "\""))))
((char-ready? port) #f))
(let ((value (read-line port)))
(sigaction SIGALRM SIG_IGN)
- value))
+ (strip-cr value)))
+
+(define whoisd-grammar
+ `((help (single-char #\H)
+ (value #f))
+ (less-specific (single-char #\L)
+ (value #f))))
+
+(define (whoisd-help port)
+ (with-output-to-port port
+ (lambda ()
+ (display "% WHOISD command line syntax:\n")
+ (display "%\n")
+ (display "% <domain-name> Look for exact match\n")
+ (display "% -L <domain-name> Return all less-specific matches\n")
+ (display "% -H Return this help summary\n"))))
+
+(define (whoisd-run-command out command-list)
+ (let ((args '())
+ (key #f))
+ (catch #t
+ (lambda ()
+ (for-each
+ (lambda (x)
+ (cond
+ ((pair? x)
+ (case (car x)
+ ((help)
+ (whoisd-help out)
+ (throw 'whoisd-done))
+ ((less-specific)
+ (set! args (append args (list #:-L))))
+ (else
+ (cond
+ ((null? (car x))
+ (cond
+ (key
+ (throw 'whoisd-extra-key))
+ ((null? (cdr x)) ); Continue
+ ((= (length (cdr x)) 1)
+ (set! key (cadr x)))
+ (else
+ (throw 'whoisd-extra-key))))
+ (else
+ (throw 'whoisd-unknown-option))))))))
+ (getopt-long (cons "whoisd" command-list) whoisd-grammar))
+
+ (let ((conn (sql-connect
+ sql-iface sql-host sql-port sql-database
+ sql-username sql-password)))
+ (cond
+ (conn
+ (whois-query out conn key args)
+ (sql-connect-close conn))
+ (else
+ (whois-error out 500 "Database is not available")))))
+
+ (lambda (key . args)
+ (case key
+ ((whoisd-unknown-option)
+ (whois-error out 511 "Unknown option"))
+ ((whoisd-extra-key)
+ (whois-error out 512 "Extra key"))
+ ((whoisd-done) ) ; Nothing
+ ('misc-error
+ ; FIXME:
+ (whois-error out 513 (apply format args)))
+ (else
+ ; FIXME
+ ;(write key out)
+ ;(write args out)
+ (debug 1 "EXCEPTION" args)
+ (whois-error out 600 "Internal error. Please report to administrator")))))))
(define (whois-server in out . rest)
(if (not (null? rest))
(let ((conn-info (car rest)))
(debug 1 "Connect from " (inet-ntoa (vector-ref conn-info 1)))))
- (let ((key (read-or-timeout in))
- (conn (sql-connect
- sql-iface sql-host sql-port sql-database
- sql-username sql-password)))
- (cond
- (conn
- (whois-query out conn key)
- (sql-connect-close conn))
- (else
- (whois-error out 500 "Database is not available")))))
+ (let ((input (read-or-timeout in)))
+ (if (not (string-null? input))
+ (whoisd-run-command out (string->list input)))))
(define (sigchld-handler sig)
(catch 'system-error
@@ -282,34 +432,41 @@ The following options may be used in daemon mode only:\n\
-p, --port NUMBER Listen on this port number.\n\
-u, --user USER Run with this user privileges. Default is \"daemon\"\n\
"))
-
-;; Parse command line
+;; Parse command line
(for-each
(lambda (x)
- (and (pair? x)
- (case (car x)
- ((help)
- (print-help)
- (exit 0))
- ((port)
- (set! whois-port (string->number (cdr x))))
- ((ip-address)
- (set! whois-address (inet-aton (cdr x))))
- ((debug)
- (set! debug-level (string->number (cdr x))))
- ((daemon)
- (set! max-children (string->number (cdr x))))
- ((single)
- (set! single-process (cdr x)))
- ((foreground)
+ (cond
+ ((pair? x)
+ (case (car x)
+ ((help)
+ (print-help)
+ (exit 0))
+ ((port)
+ (set! whois-port (string->number (cdr x))))
+ ((ip-address)
+ (set! whois-address (inet-aton (cdr x))))
+ ((debug)
+ (set! debug-level (string->number (cdr x))))
+ ((daemon)
+ (set! max-children (string->number (cdr x))))
+ ((single)
+ (set! single-process (cdr x)))
+ ((foreground)
(set! foreground-mode (cdr x)))
- ((user)
- (set! whoisd-user (cdr x)))
- ((timeout)
- (set! whoisd-idle-timeout (string->number (cdr x))))
- ((inetd)
- (set! whois-standalone (not (cdr x)))))))
+ ((user)
+ (set! whoisd-user (cdr x)))
+ ((timeout)
+ (set! whoisd-idle-timeout (string->number (cdr x))))
+ ((inetd)
+ (set! whois-standalone (not (cdr x))))
+ (else
+ (cond
+ ((not (null? (cdr x)))
+ (whois-error (current-error-port) 500 "Command line usage")
+ (exit 1))))))
+ (else
+ (whois-error (current-error-port) 500 "Command line usage: unexpected argument"))))
(getopt-long (command-line) grammar))
(let ((pwd (getpwnam whoisd-user)))

Return to:

Send suggestions and report system problems to the System administrator.