Changeset 838 for trunk/ccl/examples/finger.lisp

Timestamp:

Jun 27, 2004, 8:55:12 AM (17 years ago)

Author:

gb

Message:

new version from Barry Perryman

File:

• trunk/ccl/examples/finger.lisp (modified) (5 diffs)

trunk/ccl/examples/finger.lisp

@@ -1 +1 @@
 ;;;; -*- mode: lisp -*-
-;;;; Copyright 2002 Barry Perryman. All rights reserved.
+;;;; Copyright (C) 2002-2003 Barry Perryman.
 ;;;; 
-;;;; Please send all problem reports to gekki_uk@hotmail.com
-;;;;
-;;;; Redistribution and use in source and binary forms, with or without
-;;;; modification, are permitted provided that the following conditions are
-;;;; met:
-;;;; 
-;;;;    1. Redistributions of source code must retain the above copyright
-;;;;       notice, this list of conditions and the following disclaimer.
-;;;;    2. Redistributions in binary form must reproduce the above
-;;;;       copyright notice, this list of conditions and the following
-;;;;       disclaimer in the documentation and/or other materials provided
-;;;;       with the distribution.
-;;;; 
-;;;; THIS SOFTWARE IS PROVIDED BY THE BARRY PERRYMAN ``AS IS'' AND ANY
-;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-;;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-;;;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE BARRY PERRYMAN OR
-;;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-;;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-;;;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-;;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-;;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-;;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-;;;;
 ;;;; finger.lisp
 ;;;; A simple finger client and server as specified by RFC 1288.
 ;;;;
+;;;; Anyone who wants to use this code for any purpose is free to do so.
+;;;; In doing so, the user acknowledges that this code is provided "as is",
+;;;; without warranty of any kind, and that no other party is legally or
+;;;; otherwise responsible for any consequences of its use.
+;;;;
 ;;;; Changes:
+;;;; 2003-xx-xx: General tidy up of code, especially the interface to the
+;;;;             server. Add some error handling. Update copyright.
+;;;;             Remove package.
 ;;;; 2002-07-15: New processes are optional. The system can now forward on
 ;;;;             nested queries onto other servers, which can be a security
 ;;;;             risk, so by default this is not enabled.
 ;;;;
-;;;;
-;;;; TODO:
-;;;; * Gracefully handle errors - well, any error handling would be good.
-;;;;
-
-(defpackage NET.PROTOCOLS
-  (:use common-lisp ccl)
-  (:export
-   "WRITE-NET-LINE"
-   "READ-NET-LINE"
-   "FINGER"
-   "POPULATE-VENDING-MACHINE"
-   "VENDING-MACHINE-DEMO"))
-
-(in-package :net.protocols)
 
 (defconstant +input-buffer-size+ 1024
@@ -79 +47 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Now we get on with the meat of it.
+;; Finger client
 (defun %finger (host query port)
   "Send query to host:port using the finger protocol, RFC 1288. Returns the output as a string."
@@ -91 +59 @@
            ((zerop pos) output)))))
 
-(defun finger (query &optional (verbose nil) (port 79))
+(defun finger (query &key (verbose nil) (port 79))
   "Takes a query, in the same format as the unix command line tool and execute it."
   (let (host
@@ -103 +71 @@
 ;; For testing try:
 ;;   (finger "idsoftware.com")
-;; and/or
 ;;   (finger "johnc@idsoftware.com") 
-;; to find out how Doom 3 is comming along!
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Server code
-(defun finger-daemon (handler &optional (port 79) &key (new-process t) (subqueries nil))
+(defun finger-daemon (handler &key (port 79) (subqueries nil))
   "Start up a listner on port that responds to the finger protocol"
-  (process-run-function (format nil "finger-daemon on port ~d" port) #'%finger-daemon handler port new-process subqueries))
+  (process-run-function (format nil "finger-daemon on port ~d" port)
+                        #'%finger-daemon handler port subqueries))
   
-(defun %finger-daemon (handler port new-process subqueries)
+(defun %finger-daemon (handler port subqueries)
   "Specific implementation routine."
-  (declare (ignore subqueries))
   (with-open-socket (sock :type :stream :connect :passive :local-port port :reuse-address t)
-    (do* ((insock (accept-connection sock) (accept-connection sock))
-          (line (read-net-line insock) (read-net-line insock))
-          (proc-handler (if (find #\@ line) #'finger-forward-handler handler)
-                        (if (find #\@ line) #'finger-forward-handler handler)))
-         ((null insock) nil)
-      (if new-process
-          (process-run-function "Finger request handler" #'%finger-daemon-handler proc-handler insock line)
-          (funcall #'%finger-daemon-handler proc-handler insock line)))))
+    (loop
+       (let ((insock (accept-connection sock)))
+         (process-run-function "Finger request handler"
+                               #'%finger-daemon-handler handler insock subqueries)))))
 
-(defun %finger-daemon-handler (handler socket line)
-  (let* ((verbose (and (>= (length line) 3)
+(defun %finger-daemon-handler (handler socket subqueries)
+  (let* ((line (read-net-line socket))
+         (verbose (and (>= (length line) 3)
                        (string= line "/W " :end1 3)))
-         (proc-line (if verbose (subseq line 3) line)))
-    (funcall handler proc-line verbose socket)
+         (proc-line (if verbose (subseq line 3) line))
+         (req-sub (find #\@ line :test #'char=))
+         (ret-str (cond ((and subqueries req-sub)
+                         (finger-forward-handler proc-line verbose))
+                        (req-sub
+                         "Sub-Queries not supported.")
+                        (t
+                         (funcall handler proc-line verbose)))))
+    (if (null ret-str)
+        (write-sequence "Unknown." socket)
+        (write-sequence ret-str socket))
     (force-output socket)
     (close socket)))
 
-(defun finger-forward-handler (line verbose socket)
+(defun finger-forward-handler (line verbose)
   "Handler for forwarding requests a third party"
   (handler-bind ((error #'(lambda (c)
                             (declare (ignore c))
-                            (format socket "Unable to process the request.")
-                            (return-from finger-forward-handler nil))))
-    (let ((ret (finger line verbose)))
-      (write-sequence ret socket))))
+                            (return-from finger-forward-handler "Unable to process the request."))))
+    (finger line :verbose verbose)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -172 +142 @@
    ("H1" "Hot Chocolate" "Carefull, this is so hot it'll cook your tastebuds." 1.0)))
 
-(defun write-vending-machine-details (stream)
-  (format stream "~%Button~10,0TContents~50,4TPrice~%")
-  (format stream "-------------------------------------------------------~%")
-  (dolist (i *vending-machine*)
-    (format stream "~a~10,0T~a~50,4T~,2f~%"
-            (vending-button i)
-            (vending-contents i)
-            (vending-price i))))
+(defun vending-machine-details ()
+  (with-output-to-string (stream)
+    (format stream "~%Button~10,0TContents~50,4TPrice~%")
+    (format stream "-------------------------------------------------------~%")
+    (dolist (i *vending-machine*)
+      (format stream "~a~10,0T~a~50,4T~,2f~%"
+              (vending-button i)
+              (vending-contents i)
+              (vending-price i)))))
 
-(defun write-specific-button-details (button stream)
+(defun specific-button-details (button)
   "This write the specific information for the button"
-  (let ((item (find button *vending-machine*
-                    :key #'vending-button
-                    :test #'string-equal)))
-    (cond ((null item)
-           (format stream "Not available on this machine.~%"))
-          (t
-           (format stream "Button: ~a~50,0tPrice: ~,2f~%"
-                   (vending-button item)
-                   (vending-price item))
-           (format stream "Contents: ~a~%"
-                   (vending-contents item))
-           (format stream "Description: ~a~%"
-                   (vending-description item))))))
+  (with-output-to-string (stream)
+    (let ((item (find button *vending-machine*
+                      :key #'vending-button
+                      :test #'string-equal)))
+      (cond ((null item)
+             (format stream "Not available on this machine.~%"))
+            (t
+             (format stream "Button: ~a~50,0tPrice: ~,2f~%"
+                     (vending-button item)
+                     (vending-price item))
+             (format stream "Contents: ~a~%"
+                     (vending-contents item))
+             (format stream "Description: ~a~%"
+                     (vending-description item)))))))
 
-(defun process-vending-machine-command (command verbose stream)
+(defun process-vending-machine-command (command verbose)
   "This is the vending machine."
   (declare (ignore verbose))
   (if (string= command "")
-      (write-vending-machine-details stream)
-      (write-specific-button-details command stream)))
+      (vending-machine-details)
+      (specific-button-details command)))
 
 (defun vending-machine-demo (port)
-  (finger-daemon #'process-vending-machine-command port :new-process t))
+  (finger-daemon #'process-vending-machine-command :port port))