diff options
Diffstat (limited to 'examples/whoisd.scm')
-rw-r--r-- | examples/whoisd.scm | 323 |
1 files changed, 323 insertions, 0 deletions
diff --git a/examples/whoisd.scm b/examples/whoisd.scm new file mode 100644 index 0000000..31a7fd9 --- /dev/null +++ b/examples/whoisd.scm @@ -0,0 +1,323 @@ +#! /usr/local/bin/guile -s +!# +;;;; This is Scheme whoisd daemon +;;;; Copyright (C) 2002, Sergey Poznyakoff +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;;; + +(set! %load-path (append %load-path (list "/usr/local/lib/guile"))) +(use-modules (ice-9 getopt-long)) +(use-modules (util sql)) + +;;; User-definable variables +(define sql-iface "mysql") +(define sql-host "") +(define sql-port 3306) +(define sql-database "whois") +(define sql-username "whois") +(define sql-password "secret") +;;; End of user-definable variables + +(define progname "whoisd") +(define debug-level 0) + +(define (debug level . text) + (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"))))) + +(define (convert-date date) + (string-append (substring date 0 4) + (substring date 5 7) + (substring date 8))) + +(define (display-list prefix data port) + (for-each + (lambda (x) + (if (pair? x) + (display-list prefix x port) + (begin + (display prefix port) + (display ": " port) + (display x port) + (newline port)))) + data)) + +(define (multiline->list str) + (let loop ((fields '()) + (str str)) + (cond + ((string-index str #\newline) + => (lambda (w) + (loop + (append fields (list (substring str 0 w))) + (substring str (1+ w))))) + ((= (string-length str) 0) + fields) + (else + (append fields (list str)))))) + +(define (display-multiline prefix text port) + (if text + (display-list prefix (multiline->list text) port))) + +(define (whois-error port code . text) + (display-list (string-append "%ERROR:" + (number->string code)) + text port)) + +(define (whois-query port conn key) + (debug 2 "key " key) + (let ((dom-res (sql-query conn (string-append + "SELECT \ +domain,descr,remark,created,changed,changed_by,source \ +FROM domain WHERE domain=\"" key "\""))) + (admin-c (sql-query conn (string-append + "SELECT contact FROM admin_c \ +WHERE domain=\"" key "\""))) + (tech-c (sql-query conn (string-append + "SELECT contact FROM tech_c \ +WHERE domain=\"" key "\""))) + (zone-c (sql-query conn (string-append + "SELECT contact FROM zone_c \ +WHERE domain=\"" key "\""))) + (nserver (sql-query conn (string-append + "SELECT nserver FROM nserver \ +WHERE domain=\"" key "\"")))) + (debug 2 "result: " dom-res) + (if (null? dom-res) + (whois-error port 100 "No entries found") + (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 (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))))) + +(define whois-standalone #t) +(define single-process #f) +(define foreground-mode #f) +(define whois-address INADDR_ANY) +(define whois-port 43) +(define max-children 10) +(define num-children 0) + +(define whoisd-idle-timeout 5) +(define whoisd-gid -1) +(define whoisd-uid -1) + +(define whoisd-user "daemon") + +(define (sigalrm-handler sig) + (debug 1 "Timed out in waiting for input") + (exit 1)) + +(define (read-or-timeout port) + (sigaction SIGALRM sigalrm-handler) + (alarm whoisd-idle-timeout) + (do () + ((char-ready? port) #f)) + (let ((value (read-line port))) + (sigaction SIGALRM SIG_IGN) + value)) + +(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"))))) + +(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)) + (set! num-children (1- num-children)))) + (lambda args #f))) + + +(define (ready-for-reading? fd) + (catch 'system-error + (lambda () + (let ((r (select (list fd) '() '() 1))) + (member fd (car r)))) + (lambda args #f))) + +(define (whois-mainloop) + (let ((socket (socket AF_INET SOCK_STREAM 0))) + (bind socket AF_INET whois-address whois-port) + (if (not foreground-mode) + (begin + (setgid whoisd-gid) + (setuid whoisd-uid))) + (sigaction SIGCHLD sigchld-handler SA_RESTART) + (listen socket 5) + (do () + (#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))))))) + +(define (whois-daemon) + (close-all-ports-except (current-error-port)) + (sigaction SIGCHLD SIG_IGN) + (case foreground-mode + ((#f) + (let ((pid (primitive-fork))) + (cond + ((= pid 0) + (chdir "/") + (setsid) + (whois-mainloop)) + (else + (debug 10 "Started child " pid) + (primitive-exit))))) + ((#t) + (whois-mainloop)))) + +(define grammar + `((help (single-char #\h) + (value #f)) + (single (single-char #\s) + (value #f)) + (foreground (single-char #\f) + (value #f)) + (debug (single-char #\x) + (value #t)) + (inetd (single-char #\i) + (value #f)) + (daemon (single-char #\d) + (value #t)) + (ip-address (single-char #\a) + (value #t)) + (port (single-char #\p) + (value #t)) + (timeout (single-char #\t) + (value #t)) + (user (single-char #\u) + (value #t)))) + +(define (print-help) + (display "\ +Usage: whoisd [OPTIONS]\n\ +whoisd -- The whois daemon.\n\ +\n\ +-h, --help Display this help\n\ +-x, --debug VALUE Set debugging level\n\ +-t, --timeout Set idle timeout for a request\n\ +\n\ +-i, --inetd Run in inetd mode.\n\ +\n\ +-d, --daemon NUMBER Run in daemon mode. Limit number of children spawned\n\ + simultaneously to NUMBER. This is the default mode,\n\ + NUMBER defaults to 10.\n\ +\n\ +The following options may be used in daemon mode only:\n\ +\n\ +-s, --single Single-process mode: do not spawn children\n\ + for handling requests.\n\ +-f, --foreground Stay in foreground.\n\ +-a, --ip-address ADDRESS Listen on this IP address\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 + +(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) + (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))))))) + (getopt-long (command-line) grammar)) + +(let ((pwd (getpwnam whoisd-user))) + (set! whoisd-uid (vector-ref pwd 2)) + (set! whoisd-gid (vector-ref pwd 3))) + +(case whois-standalone + ((#t) + (whois-daemon)) + ((#f) + (whois-server (current-input-port) (current-output-port)))) |