diff options
author | Sergey Poznyakoff <gray@gnu.org.ua> | 2010-03-21 03:21:05 +0200 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org.ua> | 2010-03-21 03:21:05 +0200 |
commit | 31bda1c64c9171a043875d2537dae338d7ab66e3 (patch) | |
tree | 985ea742efcec325d3c642a80c698465f1571260 /examples | |
parent | 45f6d751fc2a585efaad9c210734914270be0ad7 (diff) | |
download | gamma-31bda1c64c9171a043875d2537dae338d7ab66e3.tar.gz gamma-31bda1c64c9171a043875d2537dae338d7ab66e3.tar.bz2 |
Implement syslog output ports.
* am/guile.m4: Check for scm_t_off.
* doc/.gitignore: Update.
* examples/README: Update.
* examples/whoisd.scm: Rewrite using new Gamma
features.
* modules/syslog (sources): Add syslog-port.c
* src/.gitignore: Update.
* src/syslog-port.c: New file.
* src/syslog.c (syslog_init): Call _gamma_init_syslog_port.
* src/syslog.sci: Include syslog-port.inc
* doc/syslog.texi: Update.
Diffstat (limited to 'examples')
-rw-r--r-- | examples/README | 18 | ||||
-rw-r--r-- | examples/whoisd.scm | 327 |
2 files changed, 193 insertions, 152 deletions
diff --git a/examples/README b/examples/README index 58ac7fc..c6f8c74 100644 --- a/examples/README +++ b/examples/README @@ -25,28 +25,28 @@ Here is the database structure for use with this daemon: CREATE DATABASE whois CREATE TABLE admin_c ( - domain varchar(255) default '' not null, + domain varchar(255) default '' not null, contact char(24) default '' not null ); CREATE TABLE tech_c ( - domain varchar(255) default '' not null, + domain varchar(255) default '' not null, contact char(24) default '' not null ); CREATE TABLE zone_c ( - domain varchar(255) default '' not null, + domain varchar(255) default '' not null, contact char(24) default '' not null ); CREATE TABLE nserver ( - domain varchar(255) default '' not null, + domain varchar(255) default '' not null, nserver varchar(255) default '' not null ); CREATE TABLE domain ( - domain varchar(255) default '' not null, - created date, - changed date, + domain varchar(255) default '' not null, + created date, + changed date, changed_by char(128), - descr text, - remark text, + descr text, + remark text, source char(24) default 'UNKNOWN' not null ); diff --git a/examples/whoisd.scm b/examples/whoisd.scm index 058136a..8b100a7 100644 --- a/examples/whoisd.scm +++ b/examples/whoisd.scm @@ -19,52 +19,43 @@ (use-modules (ice-9 getopt-long) (ice-9 format) - (gamma sql)) + (ice-9 rdelim) + (gamma sql) + (gamma syslog)) ;;; User-definable variables (define sql-param (list (cons #:iface "mysql") - (cons #:host "host.name.com") - (cons #:port 3306) - (cons #:db "whois") - (cons #:username "whois") - (cons #:pass "secret"))) + (cons #:config-file "/etc/whoisd.cnf") + (cons #:config-group "server"))) (define base-domain-list (list "domain.com" "domain.net")) ;;; End of user-definable variables (define progname "whoisd") (define debug-level 0) +(define debug-port (current-error-port)) -(define (debug level . text) +(define (debug level fmt . rest) (if (<= level debug-level) - (map (lambda (x) - (display x (current-error-port))) - (append - (list - (if foreground-mode - progname - (strftime "%c" (localtime (current-time)))) - ":debug:" (number->string level) ": ") - text - (list "\n"))))) + (apply format debug-port fmt rest))) (define (convert-date date) (string-append (substring date 0 4) (substring date 5 7) (substring date 8))) -(define (display-list prefix data port) +(define (display-list prefix data) (for-each (lambda (x) (if (pair? x) - (display-list prefix x port) - (begin - (display prefix port) - (display ": " port) - (display x port) - (newline port)))) + (display-list prefix x) + (begin + (display prefix) + (display ": ") + (display x) + (newline)))) data)) (define (multiline->list str) @@ -126,23 +117,24 @@ (else (append fields (list (substring str ind (string-length str)))))))) -(define (display-multiline prefix text port) +(define (display-multiline prefix text) (if text - (display-list prefix (multiline->list text) port))) + (display-list prefix (multiline->list text)))) -(define (whois-error port code . text) - (display-list (string-append "%ERROR:" - (number->string code)) - text port)) +(define (whois-error code . text) + (lambda () + (display-list (string-append "%ERROR:" + (number->string code)) + text))) -(define (whois-warning port code . text) - (debug 1 "TEXT " text) +(define (whois-warning code . text) + (debug 1 "TEXT ~A~%" text) (display-list (string-append "%WARNING:" (number->string code)) - text port)) + text)) -(define (whois-query-primitive port conn key) - (debug 2 "key " key) +(define (whois-query-primitive conn key) + (debug 2 "key ~A~%" key) (let ((dom-res (sql-query conn (string-append "SELECT \ domain,descr,remark,created,changed,changed_by,source \ @@ -159,48 +151,51 @@ WHERE domain=\"" key "\""))) (nserver (sql-query conn (string-append "SELECT nserver FROM nserver \ WHERE domain=\"" key "\"")))) - (debug 2 "result: " dom-res) + (debug 2 "result: ~A~%" dom-res) (if (null? dom-res) #f (let ((dr (car dom-res))) - (display "domain: " port)(display (car dr) port)(newline port) - (display-multiline "descr" (list-ref dr 1) port) - (display-multiline "remark" (list-ref dr 2) port) - (display-list "admin-c" admin-c port) - (display-list "tech-c" tech-c port) - (display-list "zone-c" zone-c port) - (display-list "nserver" nserver port) + (display "domain: ") + (display (car dr)) + (newline) + + (display-multiline "descr" (list-ref dr 1)) + (display-multiline "remark" (list-ref dr 2)) + (display-list "admin-c" admin-c) + (display-list "tech-c" tech-c) + (display-list "zone-c" zone-c) + (display-list "nserver" nserver) (display (string-append "changed: " (list-ref dr 5) " " - (convert-date (list-ref dr 4))) port) - (newline port) - (display "source: " port) - (display (list-ref dr 6) port) - (newline port) - (newline port) - (force-output port) + (convert-date (list-ref dr 4)))) + (newline) + (display "source: ") + (display (list-ref dr 6)) + (newline) + (newline) + (force-output) #t)))) -(define (whois-query port conn key args) +(define (whois-query conn key args) (let* ((keyval (string-downcase key)) - (result (whois-query-primitive port conn keyval))) + (result (whois-query-primitive conn keyval))) (cond ((member #:-L args) - (whois-warning port 200 + (whois-warning 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))) + (if (not (do ((res (whois-query-primitive conn keyval) + (or (whois-query-primitive 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"))) + (whois-error 100 "No entries found"))) ((not result) - (whois-error port 100 "No entries found"))))) + (whois-error 100 "No entries found"))))) (define (strip-element name) (let ((index (string-index name #\.))) @@ -208,6 +203,8 @@ WHERE domain=\"" key "\"")))) (substring name (1+ index)) #f))) +(define log-facility LOG_DAEMON) +(define log-tag "whoisd") (define whois-standalone #t) (define single-process #f) (define foreground-mode #f) @@ -223,7 +220,7 @@ WHERE domain=\"" key "\"")))) (define whoisd-user "daemon") (define (sigalrm-handler sig) - (debug 1 "Timed out in waiting for input") + (debug 1 "Timed out in waiting for input~%") (exit 1)) (define (strip-cr str) @@ -232,12 +229,12 @@ WHERE domain=\"" key "\"")))) (substring str 0 (- len 1)) str))) -(define (read-or-timeout port) +(define (read-or-timeout) (sigaction SIGALRM sigalrm-handler) (alarm whoisd-idle-timeout) (do () - ((char-ready? port) #f)) - (let ((value (read-line port))) + ((char-ready?) #f)) + (let ((value (read-line))) (sigaction SIGALRM SIG_IGN) (strip-cr value))) @@ -256,75 +253,80 @@ WHERE domain=\"" key "\"")))) (display "% -L <domain-name> Return all less-specific matches\n") (display "% -H Return this help summary\n")))) -(define (whoisd-run-command out command-list) +(define (whoisd-run-command command-list) + (debug 1 "whoisd-run-command ~S~%" 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-open-connection sql-paramd))) - (cond - (conn - (whois-query out conn key args) - (sql-close-connection 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) + (call-with-current-continuation + (lambda (quit) + (catch #t + (lambda () + (for-each + (lambda (x) + (debug 1 "Reading ~A~%" x) + (cond + ((pair? x) + (case (car x) + ((help) + (whoisd-help) + (quit)) + ((less-specific) + (set! args (append args (list #:-L)))) + (else + (cond + ((null? (car x)) + (cond + (key + (error 'whoisd-error "whoisd-run-command" + "~A: ~A" (list "Extra key" key) + (list 512))) + ((null? (cdr x)) #f); Continue + ((= (length (cdr x)) 1) + (set! key (cadr x))) + (else + (error 'whoisd-error "whoisd-run-command" + "~A" (list "Extra key") + (list 512))))) + (else + (error 'whoisd-error "whoisd-run-command" + "~A" (list "Unknown option") + (list 511))))))))) + (getopt-long (cons "whoisd" command-list) whoisd-grammar)) + + (let ((conn (sql-open-connection sql-param))) + (cond + (conn + (whois-query conn key args) + (sql-close-connection conn)) + (else + (whois-error 500 "Database is not available"))))) + + (lambda (key func fmt args data) + (debug 1 "Got error ~A ~S~%" fmt args) + (with-output-to-port + (current-error-port) + (lambda () + (apply format #t fmt args) + (newline))) + (case key + ((whoisd-error) + (apply whois-error (car data) (format #f fmt args)))))))))) + +(define (whois-server . rest) (if (not (null? rest)) (let ((conn-info (car rest))) - (debug 1 "Connect from " (inet-ntoa (vector-ref conn-info 1))))) - (let ((input (read-or-timeout in))) + (debug 1 "Connect from ~A~%" (inet-ntoa (vector-ref conn-info 1))))) + (let ((input (read-or-timeout))) (if (not (string-null? input)) - (whoisd-run-command out (string->list input))))) + (whoisd-run-command (string->list input))))) (define (sigchld-handler sig) (catch 'system-error (lambda () (do ((pid (waitpid WAIT_ANY WNOHANG) (waitpid WAIT_ANY WNOHANG))) ((= (car pid) 0) #f) - (debug 1 "Child " (car pid) " terminated with code " (cdr pid)) + (debug 1 "Child ~A terminated with code ~A~%" (car pid) (cdr pid)) (set! num-children (1- num-children)))) (lambda args #f))) @@ -338,6 +340,7 @@ WHERE domain=\"" key "\"")))) (define (whois-mainloop) (let ((socket (socket AF_INET SOCK_STREAM 0))) + (setsockopt socket SOL_SOCKET SO_REUSEADDR 1) (bind socket AF_INET whois-address whois-port) (if (not foreground-mode) (begin @@ -349,27 +352,43 @@ WHERE domain=\"" key "\"")))) (#f #f) (if (or (= 0 num-children) (ready-for-reading? socket)) - (let ((conn (accept socket))) - (cond - ((>= num-children max-children) - (debug 1 "Too many connections active (" num-children ")") - (whois-error (car conn) 501 "Too many connections active")) - (else - (let ((pid (primitive-fork))) - (cond - ((= pid 0) - (close-port socket) - (whois-server (car conn) (car conn) (cdr conn)) - (shutdown (car conn) 2) - (exit 0)) - (else - (set! num-children (1+ num-children)) - (debug 1 "Child " pid " started. Total " - num-children ".")))))) - (close-port (car conn))))))) + (let* ((conn (accept socket)) + (port (car conn))) + (with-output-to-port + port + (lambda () + (cond + ((>= num-children max-children) + (debug 1 "Too many connections active (~A)~%" num-children) + (whois-error 501 "Too many connections active")) + (else + (let ((pid (primitive-fork))) + (cond + ((= pid 0) + (close-port socket) + (with-input-from-port + port + (lambda () + (whois-server (cdr conn)))) + (shutdown (car conn) 2) + (exit 0)) + (else + (set! num-children (1+ num-children)) + (debug 1 "Child ~A started. Total children ~A~%" + pid num-children)))))))) + (close-port port)))))) (define (whois-daemon) - (close-all-ports-except (current-error-port)) + (let ((kept-ports (list + debug-port + (current-error-port) + (current-output-port) + (current-input-port)))) + (port-for-each + (lambda (port) + (if (not (memq port kept-ports)) + (close-port port))))) + (sigaction SIGCHLD SIG_IGN) (case foreground-mode ((#f) @@ -380,7 +399,7 @@ WHERE domain=\"" key "\"")))) (setsid) (whois-mainloop)) (else - (debug 10 "Started child " pid) + (debug 10 "Started child ~A~%" pid) (primitive-exit))))) ((#t) (whois-mainloop)))) @@ -394,6 +413,10 @@ WHERE domain=\"" key "\"")))) (value #f)) (debug (single-char #\x) (value #t)) + (tag (single-char #\L) + (value #t)) + (facility (single-char #\f) + (value #t)) (inetd (single-char #\i) (value #f)) (daemon (single-char #\d) @@ -414,6 +437,8 @@ whoisd -- The whois daemon.\n\ \n\ -h, --help Display this help\n\ -x, --debug VALUE Set debugging level\n\ +-L, --tag TAG Set syslog tag\n\ +-F, --facility LF Set syslog facility\n\ -t, --timeout Set idle timeout for a request\n\ \n\ -i, --inetd Run in inetd mode.\n\ @@ -459,19 +484,35 @@ The following options may be used in daemon mode only:\n\ (set! whoisd-idle-timeout (string->number (cdr x)))) ((inetd) (set! whois-standalone (not (cdr x)))) + ((facility) + (set! log-facility (string-eval (cdr x)))) + ((tag) + (set! log-tag (cdr x))) (else (cond ((not (null? (cdr x))) - (whois-error (current-error-port) 500 "Command line usage") + (with-output-to-port + (current-error-port) + (lambda () + (whois-error 500 "Command line usage"))) (exit 1)))))) (else - (whois-error (current-error-port) 500 "Command line usage: unexpected argument")))) + (with-output-to-port + (current-error-port) + (lambda () + (whois-error 500 "Command line usage: unexpected argument")))))) (getopt-long (command-line) grammar)) (let ((pwd (getpwnam whoisd-user))) (set! whoisd-uid (vector-ref pwd 2)) (set! whoisd-gid (vector-ref pwd 3))) +(openlog (or log-tag (car (command-line))) LOG_PID log-facility) +(set! debug-port (open-syslog-port LOG_DEBUG)) +(set-current-error-port (open-syslog-port LOG_ERR)) +(set-current-output-port (open-syslog-port LOG_INFO)) +(set-current-input-port (open-input-file "/dev/null")) + (if whois-standalone - (whois-daemon) - (whois-server (current-input-port) (current-output-port))) + (whois-daemon) + (whois-server)) |