aboutsummaryrefslogtreecommitdiff
path: root/examples
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org.ua>2010-03-21 03:21:05 +0200
committerSergey Poznyakoff <gray@gnu.org.ua>2010-03-21 03:21:05 +0200
commit31bda1c64c9171a043875d2537dae338d7ab66e3 (patch)
tree985ea742efcec325d3c642a80c698465f1571260 /examples
parent45f6d751fc2a585efaad9c210734914270be0ad7 (diff)
downloadgamma-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/README18
-rw-r--r--examples/whoisd.scm327
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))

Return to:

Send suggestions and report system problems to the System administrator.