source: trunk/ccl/examples/finger.lisp @ 6

Last change on this file since 6 was 6, checked in by gb, 17 years ago

Initial revision

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 8.1 KB
Line 
1;;;; -*- mode: lisp -*-
2;;;; Copyright 2002 Barry Perryman. All rights reserved.
3;;;;
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;;;;
29;;;; finger.lisp
30;;;; A simple finger client and server as specified by RFC 1288.
31;;;;
32;;;; Changes:
33;;;; 2002-07-15: New processes are optional. The system can now forward on
34;;;;             nested queries onto other servers, which can be a security
35;;;;             risk, so by default this is not enabled.
36;;;;
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)
52
53(defconstant +input-buffer-size+ 1024
54  "Size of the input buffer used by read-sequence.")
55
56;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
57;; Start off with a couple of utility functions
58(defun write-net-line (line stream)
59  "Write out the string line to the stream, terminating with CRLF."
60  (format stream "~a~c~c" line #\return #\linefeed))
61
62(defun read-net-line (stream)
63  "Read a line from stream."
64  (let ((line (make-array 10 :element-type 'character :adjustable t :fill-pointer 0)))
65    (do ((c (read-char stream nil nil) (read-char stream nil nil)))
66        ((or (null c)
67             (and (char= c #\return)
68                  (char= (peek-char nil stream nil nil) #\linefeed)))
69         (progn
70           (read-char stream nil nil)
71           line))
72      (vector-push-extend c line))))
73
74(defmacro aif (test yes no)
75  `(let ((it ,test))
76    (if it
77        ,yes
78        ,no)))
79
80;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
81;; Now we get on with the meat of it.
82(defun %finger (host query port)
83  "Send query to host:port using the finger protocol, RFC 1288. Returns the output as a string."
84  (declare (ignore verbose))
85  (with-open-socket (net :remote-host host :remote-port port)
86    (write-net-line query net)
87    (force-output net)                  ; Doesn't seem to be needed, but just incase
88    (let ((inbuf (make-array +input-buffer-size+ :element-type 'character :initial-element #\space)))
89      (do* ((pos (read-sequence inbuf net) (read-sequence inbuf net))
90            (output (subseq inbuf 0 pos) (concatenate 'string output (subseq inbuf 0 pos))))
91           ((zerop pos) output)))))
92
93(defun finger (query &optional (verbose nil) (port 79))
94  "Takes a query, in the same format as the unix command line tool and execute it."
95  (let (host
96        (host-query (if verbose "/W " "")))
97    (aif (position #\@ query :from-end t)
98         (setf host (subseq query (1+ it))
99               host-query (concatenate 'string host-query (subseq query 0 it)))
100         (setf host query))
101    (%finger host host-query port)))
102
103;; For testing try:
104;;   (finger "idsoftware.com")
105;; and/or
106;;   (finger "johnc@idsoftware.com")
107;; to find out how Doom 3 is comming along!
108
109;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
110;; Server code
111(defun finger-daemon (handler &optional (port 79) &key (new-process t) (subqueries nil))
112  "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))
114 
115(defun %finger-daemon (handler port new-process subqueries)
116  "Specific implementation routine."
117  (declare (ignore subqueries))
118  (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)))))
127
128(defun %finger-daemon-handler (handler socket line)
129  (let* ((verbose (and (>= (length line) 3)
130                       (string= line "/W " :end1 3)))
131         (proc-line (if verbose (subseq line 3) line)))
132    (funcall handler proc-line verbose socket)
133    (force-output socket)
134    (close socket)))
135
136(defun finger-forward-handler (line verbose socket)
137  "Handler for forwarding requests a third party"
138  (handler-bind ((error #'(lambda (c)
139                            (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))))
144
145;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
146;; Vending machine code, which becomes a simple server
147(defstruct vending
148  button
149  contents
150  description
151  price)
152
153(defparameter *vending-machine* nil
154  "Holds the data for the vending machine.")
155
156(defun populate-vending-machine (data)
157  "Takes a list of data in the format (button short-desc long-desc price) and turns it into a vending mahcine."
158  (setf *vending-machine* (mapcar #'(lambda (x)
159                                      (destructuring-bind (b c d p) x
160                                        (make-vending :button b
161                                                      :contents c
162                                                      :description d
163                                                      :price p)))
164                                  data)))
165
166(populate-vending-machine
167 '(("T1" "English Breakfast Tea" "Probably the best tea in the world." 1.0)
168   ("T2" "Earl Grey" "Well if you like the taste of washing up liquid..." 1.1)
169   ("T3" "Herbal Tea (Various)" "Smells great, tastes just like water." 0.80)
170   ("C1" "Cheap 'n' Nasty coffee." "It's awful, doesn't even taste like coffee." 0.50)
171   ("C2" "Freeze Dried Coffee." "Do yourself a favour and go to a coffee shop and get a real coffee." 1.0)
172   ("H1" "Hot Chocolate" "Carefull, this is so hot it'll cook your tastebuds." 1.0)))
173
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))))
182
183(defun write-specific-button-details (button stream)
184  "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))))))
198
199(defun process-vending-machine-command (command verbose stream)
200  "This is the vending machine."
201  (declare (ignore verbose))
202  (if (string= command "")
203      (write-vending-machine-details stream)
204      (write-specific-button-details command stream)))
205
206(defun vending-machine-demo (port)
207  (finger-daemon #'process-vending-machine-command port :new-process t))
Note: See TracBrowser for help on using the repository browser.