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

Last change on this file since 9793 was 838, checked in by gb, 15 years ago

new version from Barry Perryman

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 6.7 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;;   (finger "idsoftware.com")
73;;   (finger "johnc@idsoftware.com")
74
75;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
76;; Server code
77(defun finger-daemon (handler &key (port 79) (subqueries nil))
78  "Start up a listner on port that responds to the finger protocol"
79  (process-run-function (format nil "finger-daemon on port ~d" port)
80                        #'%finger-daemon handler port subqueries))
81 
82(defun %finger-daemon (handler port subqueries)
83  "Specific implementation routine."
84  (with-open-socket (sock :type :stream :connect :passive :local-port port :reuse-address t)
85    (loop
86       (let ((insock (accept-connection sock)))
87         (process-run-function "Finger request handler"
88                               #'%finger-daemon-handler handler insock subqueries)))))
89
90(defun %finger-daemon-handler (handler socket subqueries)
91  (let* ((line (read-net-line socket))
92         (verbose (and (>= (length line) 3)
93                       (string= line "/W " :end1 3)))
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))
105    (force-output socket)
106    (close socket)))
107
108(defun finger-forward-handler (line verbose)
109  "Handler for forwarding requests a third party"
110  (handler-bind ((error #'(lambda (c)
111                            (declare (ignore c))
112                            (return-from finger-forward-handler "Unable to process the request."))))
113    (finger line :verbose verbose)))
114
115;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
116;; Vending machine code, which becomes a simple server
117(defstruct vending
118  button
119  contents
120  description
121  price)
122
123(defparameter *vending-machine* nil
124  "Holds the data for the vending machine.")
125
126(defun populate-vending-machine (data)
127  "Takes a list of data in the format (button short-desc long-desc price) and turns it into a vending mahcine."
128  (setf *vending-machine* (mapcar #'(lambda (x)
129                                      (destructuring-bind (b c d p) x
130                                        (make-vending :button b
131                                                      :contents c
132                                                      :description d
133                                                      :price p)))
134                                  data)))
135
136(populate-vending-machine
137 '(("T1" "English Breakfast Tea" "Probably the best tea in the world." 1.0)
138   ("T2" "Earl Grey" "Well if you like the taste of washing up liquid..." 1.1)
139   ("T3" "Herbal Tea (Various)" "Smells great, tastes just like water." 0.80)
140   ("C1" "Cheap 'n' Nasty coffee." "It's awful, doesn't even taste like coffee." 0.50)
141   ("C2" "Freeze Dried Coffee." "Do yourself a favour and go to a coffee shop and get a real coffee." 1.0)
142   ("H1" "Hot Chocolate" "Carefull, this is so hot it'll cook your tastebuds." 1.0)))
143
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)))))
153
154(defun specific-button-details (button)
155  "This write the specific information for the button"
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)))))))
170
171(defun process-vending-machine-command (command verbose)
172  "This is the vending machine."
173  (declare (ignore verbose))
174  (if (string= command "")
175      (vending-machine-details)
176      (specific-button-details command)))
177
178(defun vending-machine-demo (port)
179  (finger-daemon #'process-vending-machine-command :port port))
Note: See TracBrowser for help on using the repository browser.