aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org.ua>2002-05-24 10:46:09 +0000
committerSergey Poznyakoff <gray@gnu.org.ua>2002-05-24 10:46:09 +0000
commit9aa77cf19e445f9fe70dec878cba73b2b58e05f0 (patch)
treec2eccb561bf1afec0c6840c5cf5922d629af2363
parentafafee263a58050fa70b2c62fdb5ea7c126fbc37 (diff)
downloadgamma-9aa77cf19e445f9fe70dec878cba73b2b58e05f0.tar.gz
gamma-9aa77cf19e445f9fe70dec878cba73b2b58e05f0.tar.bz2
Added to repository
-rw-r--r--examples/Makefile.am1
-rw-r--r--examples/README32
-rw-r--r--examples/whoisd.scm323
3 files changed, 356 insertions, 0 deletions
diff --git a/examples/Makefile.am b/examples/Makefile.am
new file mode 100644
index 0000000..ca2d904
--- /dev/null
+++ b/examples/Makefile.am
@@ -0,0 +1 @@
+EXTRA_DIST = whoisd.scm README
diff --git a/examples/README b/examples/README
new file mode 100644
index 0000000..a56a725
--- /dev/null
+++ b/examples/README
@@ -0,0 +1,32 @@
+This directory contains examples of guile-sql usage.
+
+whoisd -- a simple whois daemon.
+
+Here is the database structure for use with this daemon:
+
+CREATE DATABASE whois
+CREATE TABLE admin_c (
+ domain varchar(255) default '' not null,
+ contact char(24) default '' not null
+);
+CREATE TABLE tech_c (
+ domain varchar(255) default '' not null,
+ contact char(24) default '' not null
+);
+CREATE TABLE zone_c (
+ domain varchar(255) default '' not null,
+ contact char(24) default '' not null
+);
+CREATE TABLE nserver (
+ 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,
+ changed_by char(128),
+ descr text,
+ remark text,
+ source char(24) default 'UNKNOWN' not null
+);
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))))

Return to:

Send suggestions and report system problems to the System administrator.