Changeset 838


Ignore:
Timestamp:
Jun 27, 2004, 8:55:12 AM (15 years ago)
Author:
gb
Message:

new version from Barry Perryman

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/examples/finger.lisp

    r6 r838  
    11;;;; -*- mode: lisp -*-
    2 ;;;; Copyright 2002 Barry Perryman. All rights reserved.
     2;;;; Copyright (C) 2002-2003 Barry Perryman.
    33;;;;
    4 ;;;; Please send all problem reports to gekki_uk@hotmail.com
    5 ;;;;
    6 ;;;; Redistribution and use in source and binary forms, with or without
    7 ;;;; modification, are permitted provided that the following conditions are
    8 ;;;; met:
    9 ;;;;
    10 ;;;;    1. Redistributions of source code must retain the above copyright
    11 ;;;;       notice, this list of conditions and the following disclaimer.
    12 ;;;;    2. Redistributions in binary form must reproduce the above
    13 ;;;;       copyright notice, this list of conditions and the following
    14 ;;;;       disclaimer in the documentation and/or other materials provided
    15 ;;;;       with the distribution.
    16 ;;;;
    17 ;;;; THIS SOFTWARE IS PROVIDED BY THE BARRY PERRYMAN ``AS IS'' AND ANY
    18 ;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
    19 ;;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
    20 ;;;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE BARRY PERRYMAN OR
    21 ;;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
    22 ;;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
    23 ;;;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
    24 ;;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
    25 ;;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
    26 ;;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
    27 ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    28 ;;;;
    294;;;; finger.lisp
    305;;;; A simple finger client and server as specified by RFC 1288.
    316;;;;
     7;;;; Anyone who wants to use this code for any purpose is free to do so.
     8;;;; In doing so, the user acknowledges that this code is provided "as is",
     9;;;; without warranty of any kind, and that no other party is legally or
     10;;;; otherwise responsible for any consequences of its use.
     11;;;;
    3212;;;; Changes:
     13;;;; 2003-xx-xx: General tidy up of code, especially the interface to the
     14;;;;             server. Add some error handling. Update copyright.
     15;;;;             Remove package.
    3316;;;; 2002-07-15: New processes are optional. The system can now forward on
    3417;;;;             nested queries onto other servers, which can be a security
    3518;;;;             risk, so by default this is not enabled.
    3619;;;;
    37 ;;;;
    38 ;;;; TODO:
    39 ;;;; * Gracefully handle errors - well, any error handling would be good.
    40 ;;;;
    41 
    42 (defpackage NET.PROTOCOLS
    43   (:use common-lisp ccl)
    44   (:export
    45    "WRITE-NET-LINE"
    46    "READ-NET-LINE"
    47    "FINGER"
    48    "POPULATE-VENDING-MACHINE"
    49    "VENDING-MACHINE-DEMO"))
    50 
    51 (in-package :net.protocols)
    5220
    5321(defconstant +input-buffer-size+ 1024
     
    7947
    8048;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    81 ;; Now we get on with the meat of it.
     49;; Finger client
    8250(defun %finger (host query port)
    8351  "Send query to host:port using the finger protocol, RFC 1288. Returns the output as a string."
     
    9159           ((zerop pos) output)))))
    9260
    93 (defun finger (query &optional (verbose nil) (port 79))
     61(defun finger (query &key (verbose nil) (port 79))
    9462  "Takes a query, in the same format as the unix command line tool and execute it."
    9563  (let (host
     
    10371;; For testing try:
    10472;;   (finger "idsoftware.com")
    105 ;; and/or
    10673;;   (finger "johnc@idsoftware.com")
    107 ;; to find out how Doom 3 is comming along!
    10874
    10975;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    11076;; Server code
    111 (defun finger-daemon (handler &optional (port 79) &key (new-process t) (subqueries nil))
     77(defun finger-daemon (handler &key (port 79) (subqueries nil))
    11278  "Start up a listner on port that responds to the finger protocol"
    113   (process-run-function (format nil "finger-daemon on port ~d" port) #'%finger-daemon handler port new-process subqueries))
     79  (process-run-function (format nil "finger-daemon on port ~d" port)
     80                        #'%finger-daemon handler port subqueries))
    11481 
    115 (defun %finger-daemon (handler port new-process subqueries)
     82(defun %finger-daemon (handler port subqueries)
    11683  "Specific implementation routine."
    117   (declare (ignore subqueries))
    11884  (with-open-socket (sock :type :stream :connect :passive :local-port port :reuse-address t)
    119     (do* ((insock (accept-connection sock) (accept-connection sock))
    120           (line (read-net-line insock) (read-net-line insock))
    121           (proc-handler (if (find #\@ line) #'finger-forward-handler handler)
    122                         (if (find #\@ line) #'finger-forward-handler handler)))
    123          ((null insock) nil)
    124       (if new-process
    125           (process-run-function "Finger request handler" #'%finger-daemon-handler proc-handler insock line)
    126           (funcall #'%finger-daemon-handler proc-handler insock line)))))
     85    (loop
     86       (let ((insock (accept-connection sock)))
     87         (process-run-function "Finger request handler"
     88                               #'%finger-daemon-handler handler insock subqueries)))))
    12789
    128 (defun %finger-daemon-handler (handler socket line)
    129   (let* ((verbose (and (>= (length line) 3)
     90(defun %finger-daemon-handler (handler socket subqueries)
     91  (let* ((line (read-net-line socket))
     92         (verbose (and (>= (length line) 3)
    13093                       (string= line "/W " :end1 3)))
    131          (proc-line (if verbose (subseq line 3) line)))
    132     (funcall handler proc-line verbose socket)
     94         (proc-line (if verbose (subseq line 3) line))
     95         (req-sub (find #\@ line :test #'char=))
     96         (ret-str (cond ((and subqueries req-sub)
     97                         (finger-forward-handler proc-line verbose))
     98                        (req-sub
     99                         "Sub-Queries not supported.")
     100                        (t
     101                         (funcall handler proc-line verbose)))))
     102    (if (null ret-str)
     103        (write-sequence "Unknown." socket)
     104        (write-sequence ret-str socket))
    133105    (force-output socket)
    134106    (close socket)))
    135107
    136 (defun finger-forward-handler (line verbose socket)
     108(defun finger-forward-handler (line verbose)
    137109  "Handler for forwarding requests a third party"
    138110  (handler-bind ((error #'(lambda (c)
    139111                            (declare (ignore c))
    140                             (format socket "Unable to process the request.")
    141                             (return-from finger-forward-handler nil))))
    142     (let ((ret (finger line verbose)))
    143       (write-sequence ret socket))))
     112                            (return-from finger-forward-handler "Unable to process the request."))))
     113    (finger line :verbose verbose)))
    144114
    145115;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    172142   ("H1" "Hot Chocolate" "Carefull, this is so hot it'll cook your tastebuds." 1.0)))
    173143
    174 (defun write-vending-machine-details (stream)
    175   (format stream "~%Button~10,0TContents~50,4TPrice~%")
    176   (format stream "-------------------------------------------------------~%")
    177   (dolist (i *vending-machine*)
    178     (format stream "~a~10,0T~a~50,4T~,2f~%"
    179             (vending-button i)
    180             (vending-contents i)
    181             (vending-price i))))
     144(defun vending-machine-details ()
     145  (with-output-to-string (stream)
     146    (format stream "~%Button~10,0TContents~50,4TPrice~%")
     147    (format stream "-------------------------------------------------------~%")
     148    (dolist (i *vending-machine*)
     149      (format stream "~a~10,0T~a~50,4T~,2f~%"
     150              (vending-button i)
     151              (vending-contents i)
     152              (vending-price i)))))
    182153
    183 (defun write-specific-button-details (button stream)
     154(defun specific-button-details (button)
    184155  "This write the specific information for the button"
    185   (let ((item (find button *vending-machine*
    186                     :key #'vending-button
    187                     :test #'string-equal)))
    188     (cond ((null item)
    189            (format stream "Not available on this machine.~%"))
    190           (t
    191            (format stream "Button: ~a~50,0tPrice: ~,2f~%"
    192                    (vending-button item)
    193                    (vending-price item))
    194            (format stream "Contents: ~a~%"
    195                    (vending-contents item))
    196            (format stream "Description: ~a~%"
    197                    (vending-description item))))))
     156  (with-output-to-string (stream)
     157    (let ((item (find button *vending-machine*
     158                      :key #'vending-button
     159                      :test #'string-equal)))
     160      (cond ((null item)
     161             (format stream "Not available on this machine.~%"))
     162            (t
     163             (format stream "Button: ~a~50,0tPrice: ~,2f~%"
     164                     (vending-button item)
     165                     (vending-price item))
     166             (format stream "Contents: ~a~%"
     167                     (vending-contents item))
     168             (format stream "Description: ~a~%"
     169                     (vending-description item)))))))
    198170
    199 (defun process-vending-machine-command (command verbose stream)
     171(defun process-vending-machine-command (command verbose)
    200172  "This is the vending machine."
    201173  (declare (ignore verbose))
    202174  (if (string= command "")
    203       (write-vending-machine-details stream)
    204       (write-specific-button-details command stream)))
     175      (vending-machine-details)
     176      (specific-button-details command)))
    205177
    206178(defun vending-machine-demo (port)
    207   (finger-daemon #'process-vending-machine-command port :new-process t))
     179  (finger-daemon #'process-vending-machine-command :port port))
Note: See TracChangeset for help on using the changeset viewer.