source: trunk/source/examples/finger.lisp @ 13062

Last change on this file since 13062 was 11970, checked in by gb, 10 years ago

Try to increase the likelyhood that people will think before invoking
a test case. (Possibly a lost cause.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 6.8 KB
Line 
1;;;; -*- mode: lisp -*-
2;;;; Copyright (C) 2002-2003 Barry Perryman.
3;;;;
4;;;; finger.lisp
5;;;; A simple finger client and server as specified by RFC 1288.
6;;;;
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;;;;
12;;;; 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.
16;;;; 2002-07-15: New processes are optional. The system can now forward on
17;;;;             nested queries onto other servers, which can be a security
18;;;;             risk, so by default this is not enabled.
19;;;;
20
21(defconstant +input-buffer-size+ 1024
22  "Size of the input buffer used by read-sequence.")
23
24;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
25;; Start off with a couple of utility functions
26(defun write-net-line (line stream)
27  "Write out the string line to the stream, terminating with CRLF."
28  (format stream "~a~c~c" line #\return #\linefeed))
29
30(defun read-net-line (stream)
31  "Read a line from stream."
32  (let ((line (make-array 10 :element-type 'character :adjustable t :fill-pointer 0)))
33    (do ((c (read-char stream nil nil) (read-char stream nil nil)))
34        ((or (null c)
35             (and (char= c #\return)
36                  (char= (peek-char nil stream nil nil) #\linefeed)))
37         (progn
38           (read-char stream nil nil)
39           line))
40      (vector-push-extend c line))))
41
42(defmacro aif (test yes no)
43  `(let ((it ,test))
44    (if it
45        ,yes
46        ,no)))
47
48;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
49;; Finger client
50(defun %finger (host query port)
51  "Send query to host:port using the finger protocol, RFC 1288. Returns the output as a string."
52  (declare (ignore verbose))
53  (with-open-socket (net :remote-host host :remote-port port)
54    (write-net-line query net)
55    (force-output net)                  ; Doesn't seem to be needed, but just incase
56    (let ((inbuf (make-array +input-buffer-size+ :element-type 'character :initial-element #\space)))
57      (do* ((pos (read-sequence inbuf net) (read-sequence inbuf net))
58            (output (subseq inbuf 0 pos) (concatenate 'string output (subseq inbuf 0 pos))))
59           ((zerop pos) output)))))
60
61(defun finger (query &key (verbose nil) (port 79))
62  "Takes a query, in the same format as the unix command line tool and execute it."
63  (let (host
64        (host-query (if verbose "/W " "")))
65    (aif (position #\@ query :from-end t)
66         (setf host (subseq query (1+ it))
67               host-query (concatenate 'string host-query (subseq query 0 it)))
68         (setf host query))
69    (%finger host host-query port)))
70
71;; For testing try:
72;; (where "some-host.com" is a host running a finger server):
73;;   (finger "some-host.com")
74;;   (finger "user@some-host.com")
75
76;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
77;; Server code
78(defun finger-daemon (handler &key (port 79) (subqueries nil))
79  "Start up a listner on port that responds to the finger protocol"
80  (process-run-function (format nil "finger-daemon on port ~d" port)
81                        #'%finger-daemon handler port subqueries))
82 
83(defun %finger-daemon (handler port subqueries)
84  "Specific implementation routine."
85  (with-open-socket (sock :type :stream :connect :passive :local-port port :reuse-address t)
86    (loop
87       (let ((insock (accept-connection sock)))
88         (process-run-function "Finger request handler"
89                               #'%finger-daemon-handler handler insock subqueries)))))
90
91(defun %finger-daemon-handler (handler socket subqueries)
92  (let* ((line (read-net-line socket))
93         (verbose (and (>= (length line) 3)
94                       (string= line "/W " :end1 3)))
95         (proc-line (if verbose (subseq line 3) line))
96         (req-sub (find #\@ line :test #'char=))
97         (ret-str (cond ((and subqueries req-sub)
98                         (finger-forward-handler proc-line verbose))
99                        (req-sub
100                         "Sub-Queries not supported.")
101                        (t
102                         (funcall handler proc-line verbose)))))
103    (if (null ret-str)
104        (write-sequence "Unknown." socket)
105        (write-sequence ret-str socket))
106    (force-output socket)
107    (close socket)))
108
109(defun finger-forward-handler (line verbose)
110  "Handler for forwarding requests a third party"
111  (handler-bind ((error #'(lambda (c)
112                            (declare (ignore c))
113                            (return-from finger-forward-handler "Unable to process the request."))))
114    (finger line :verbose verbose)))
115
116;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
117;; Vending machine code, which becomes a simple server
118(defstruct vending
119  button
120  contents
121  description
122  price)
123
124(defparameter *vending-machine* nil
125  "Holds the data for the vending machine.")
126
127(defun populate-vending-machine (data)
128  "Takes a list of data in the format (button short-desc long-desc price) and turns it into a vending mahcine."
129  (setf *vending-machine* (mapcar #'(lambda (x)
130                                      (destructuring-bind (b c d p) x
131                                        (make-vending :button b
132                                                      :contents c
133                                                      :description d
134                                                      :price p)))
135                                  data)))
136
137(populate-vending-machine
138 '(("T1" "English Breakfast Tea" "Probably the best tea in the world." 1.0)
139   ("T2" "Earl Grey" "Well if you like the taste of washing up liquid..." 1.1)
140   ("T3" "Herbal Tea (Various)" "Smells great, tastes just like water." 0.80)
141   ("C1" "Cheap 'n' Nasty coffee." "It's awful, doesn't even taste like coffee." 0.50)
142   ("C2" "Freeze Dried Coffee." "Do yourself a favour and go to a coffee shop and get a real coffee." 1.0)
143   ("H1" "Hot Chocolate" "Carefull, this is so hot it'll cook your tastebuds." 1.0)))
144
145(defun vending-machine-details ()
146  (with-output-to-string (stream)
147    (format stream "~%Button~10,0TContents~50,4TPrice~%")
148    (format stream "-------------------------------------------------------~%")
149    (dolist (i *vending-machine*)
150      (format stream "~a~10,0T~a~50,4T~,2f~%"
151              (vending-button i)
152              (vending-contents i)
153              (vending-price i)))))
154
155(defun specific-button-details (button)
156  "This write the specific information for the button"
157  (with-output-to-string (stream)
158    (let ((item (find button *vending-machine*
159                      :key #'vending-button
160                      :test #'string-equal)))
161      (cond ((null item)
162             (format stream "Not available on this machine.~%"))
163            (t
164             (format stream "Button: ~a~50,0tPrice: ~,2f~%"
165                     (vending-button item)
166                     (vending-price item))
167             (format stream "Contents: ~a~%"
168                     (vending-contents item))
169             (format stream "Description: ~a~%"
170                     (vending-description item)))))))
171
172(defun process-vending-machine-command (command verbose)
173  "This is the vending machine."
174  (declare (ignore verbose))
175  (if (string= command "")
176      (vending-machine-details)
177      (specific-button-details command)))
178
179(defun vending-machine-demo (port)
180  (finger-daemon #'process-vending-machine-command :port port))
Note: See TracBrowser for help on using the repository browser.