diff options
author | Sergey Poznyakoff <gray@gnu.org.ua> | 2003-10-23 14:50:16 +0000 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org.ua> | 2003-10-23 14:50:16 +0000 |
commit | 4c6de4be1b8652212d06188a4dd511243babd0be (patch) | |
tree | 50b81530a7791bae15748e441b012de82317165f | |
parent | d4f7664f03264b91a70dc91fc9d0d673715a7fb3 (diff) | |
download | gamma-4c6de4be1b8652212d06188a4dd511243babd0be.tar.gz gamma-4c6de4be1b8652212d06188a4dd511243babd0be.tar.bz2 |
Fixed parsing of command line options, added options to the whoisd interface.
-rw-r--r-- | examples/whoisd.scm | 239 |
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))) |