/[eclipse]/eclipse/lib/sm/sm.lisp
ViewVC logotype

Contents of /eclipse/lib/sm/sm.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Thu Jan 15 13:43:15 2004 UTC (10 years, 3 months ago) by ihatchondo
Branch: MAIN
Changes since 1.1: +15 -1 lines
close-sm-connection [ function ] sm-connection &key reason added.
1 ihatchondo 1.1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SM-LIB; -*-
2 ihatchondo 1.2 ;;; $Id: sm.lisp,v 1.2 2004/01/15 13:43:15 ihatchondo Exp $
3 ihatchondo 1.1 ;;; ---------------------------------------------------------------------------
4     ;;; Title: SM Library
5     ;;; Created: 2004 01 15 15:28
6     ;;; Author: Iban Hatchondo <hatchond@labri.fr>
7     ;;; ---------------------------------------------------------------------------
8     ;;; (c) copyright 2004 by Iban Hatchondo
9    
10     ;;;
11     ;;; Permission is granted to any individual or institution to use,
12     ;;; copy, modify, and distribute this software, provided that this
13     ;;; complete copyright and permission notice is maintained, intact, in
14     ;;; all copies and supporting documentation.
15     ;;;
16     ;;; This program is distributed in the hope that it will be useful,
17     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
19     ;;;
20    
21     (in-package :SM-LIB)
22    
23     ;;;; Constants & vars
24    
25     (defvar *xsmp* nil)
26    
27     ;; Protocol version
28    
29     (defconstant +sm-proto-major+ 1)
30     (defconstant +sm-proto-minor+ 0)
31    
32     ;; Protocol release and vendor names
33    
34     (defconstant +release-name+ "CL-SM-1.0")
35     (defconstant +vendor-name+ "LoopFor & Mapcar corp")
36    
37     ;;;; Types.
38    
39     (deftype interact-style () `(member :none :errors :any))
40     (deftype dialog-type () `(member :error :normal))
41     (deftype save-type () `(member :global :local :both))
42     (deftype array8 () `(simple-array card8 (*)))
43     (deftype client-id () `string)
44    
45     (deftype array8s () 'list)
46     (deftype properties () 'list)
47    
48     (defstruct property
49     (name nil :type (or null string))
50     (type nil :type (or null string))
51     (values nil :type array8s))
52    
53     ;; <type>-length functions
54    
55     (defun interact-style-length (value)
56     (declare (ignore value))
57     (declare (optimize (speed 3) (safety 0)))
58     1)
59    
60     (defun dialog-type-length (value)
61     (declare (ignore value))
62     (declare (optimize (speed 3) (safety 0)))
63     1)
64    
65     (defun save-type-length (value)
66     (declare (ignore value))
67     (declare (optimize (speed 3) (safety 0)))
68     1)
69    
70     (defun string-length (string)
71     (declare (type (or null simple-string) string))
72     (let ((length (+ 4 (if (null string) 0 (length string)))))
73     (+ length (mod (- length) 8))))
74    
75     (defun array8-length (array)
76     (declare (type (or null array8) array))
77     (let ((length (+ 4 (if (null array) 0 (length array)))))
78     (+ length (mod (- length) 8))))
79    
80     (defun client-id-length (client-id)
81     (declare (type (or null client-id) client-id))
82     (string-length client-id))
83    
84     (defun array8s-length (arrays)
85     (declare (type array8s arrays))
86     (+ 8 (loop for a in arrays sum (array8-length a))))
87    
88     (defun property-length (property)
89     (declare (type property property))
90     (+ (string-length (property-name property))
91     (string-length (property-type property))
92     (array8s-length (property-values property))))
93    
94     (defun properties-length (properties)
95     (declare (type properties properties))
96     (+ 8 (loop for p in properties sum (property-length p))))
97    
98     ;; type constructor
99    
100     (defun make-array8 (len &rest args &key (initial-element 0) &allow-other-keys)
101     "Creates and returns an array constructed of the most specialized type that
102     can accommodate elements of type (unsigned-byte 8). For the rest of the
103     options see common-lisp:make-array."
104     (declare (type fixnum len))
105     (if (getf args :initial-contents)
106     (remf args :initial-element)
107     (setf (getf args :initial-element) initial-element))
108     (apply #'make-array len :element-type 'card8 args))
109    
110     ;; macro accessor
111    
112     (defmacro define-sequence-accessor (type element-type)
113     (let ((read (sintern (format nil "BUFFER-READ-~a" element-type)))
114     (write (sintern (format nil "BUFFER-WRITE-~a" element-type))))
115     `(define-accessor ,type
116     ((byte-order buffer index)
117     (with-gensym (count _buff)
118     `(let* ((,_buff ,buffer)
119     (,count (buffer-read-card32 ,byte-order ,buffer ,index)))
120     (incf ,index 4)
121     (loop for i from 0 below ,count
122     collect (,',read ,byte-order ,_buff ,index)))))
123     ((seq byte-order buffer index)
124     (with-gensym (_seq _buff)
125     `(let ((,_seq ,seq) (,_buff ,buffer))
126     (buffer-write-card32 (length ,_seq) ,byte-order ,_buff ,index)
127     (incf ,index 4)
128     (loop for e in ,_seq
129     do (,',write e ,byte-order ,_buff ,index))))))))
130    
131     ;; <type>-{writer,reader} macros
132    
133     (define-member8-accessor interact-style '#(:none :errors :any))
134    
135     (define-member8-accessor dialog-type '#(:error :normal))
136    
137     (define-member8-accessor save-type '#(:global :local :both))
138    
139     (define-accessor string
140     ((byte-order buffer index)
141     `(map 'string #'code-char (buffer-read-array8 ,byte-order ,buffer ,index)))
142     ((string byte-order buffer index)
143     `(buffer-write-array8
144     (map 'vector #'char-code ,string) ,byte-order ,buffer ,index)))
145    
146     (define-sequence-accessor strings string)
147    
148     (define-accessor array8
149     ((byte-order buffer index)
150     (with-gensym (length array _buff)
151     `(let* ((,_buff ,buffer)
152     (,length (buffer-read-card32 ,byte-order ,_buff ,index))
153     (,array (buffer-read-data ,byte-order ,_buff ,index ,length)))
154     (incf ,index (mod (- (+ 4 ,length)) 8))
155     ,array)))
156     ((array byte-order buffer index)
157     (with-gensym (length _buff)
158     `(let ((,length (if (null ,array) 0 (length ,array)))
159     (,_buff ,buffer))
160     (buffer-write-card32 ,length ,byte-order ,_buff ,index)
161     (buffer-write-data ,array ,byte-order ,_buff ,index)
162     (incf ,index (mod (- (+ 4 ,length)) 8))))))
163    
164     (define-sequence-accessor array8s array8)
165    
166     (define-accessor client-id
167     ((byte-order buffer index)
168     `(buffer-read-string ,byte-order ,buffer ,index))
169     ((id byte-order buffer index)
170     `(buffer-write-string ,id ,byte-order ,buffer ,index)))
171    
172     (define-accessor property
173     ((byte-order buffer index)
174     (with-gensym (_buff)
175     `(let ((,_buff ,buffer))
176     (make-property
177     :name (buffer-read-string ,byte-order ,_buff ,index)
178     :type (buffer-read-string ,byte-order ,_buff ,index)
179     :values (buffer-read-array8s ,byte-order ,_buff ,index)))))
180     ((prop byte-order buffer index)
181     (with-gensym (_prop _buff)
182     `(multiple-value-bind (,_prop ,_buff) (values ,prop ,buffer)
183     (buffer-write-string (property-name ,_prop) ,byte-order ,_buff ,index)
184     (buffer-write-string (property-type ,_prop) ,byte-order ,_buff ,index)
185     (buffer-write-array8s
186     (property-values ,_prop) ,byte-order ,_buff ,index)))))
187    
188     (define-sequence-accessor properties property)
189    
190     ;;;; Request declarations.
191    
192     (define-request :register-client 1)
193     (define-request :register-client-reply 2)
194     (define-request :save-yourself 3)
195     (define-request :save-yourself-request 4)
196     (define-request :interact-request 5)
197     (define-request :interact 6)
198     (define-request :interact-done 7)
199     (define-request :save-yourself-done 8)
200     (define-request :die 9)
201     (define-request :shutdown-cancelled 10)
202     (define-request :connection-closed 11)
203     (define-request :set-properties 12)
204     (define-request :delete-properties 13)
205     (define-request :get-properties 14)
206     (define-request :get-properties-reply 15)
207     (define-request :save-yourself-phase2-request 16)
208     (define-request :save-yourself-phase2 17)
209     (define-request :save-complete 18)
210    
211     (declare-request register-client (request)
212     ((major-opcode :initform *xsmp* :type card8)
213     (minor-opcode :type card8 :pad-size 2)
214     (previous-id :type client-id)))
215    
216     (declare-request register-client-reply (request)
217     ((major-opcode :initform *xsmp* :type card8)
218     (minor-opcode :type card8 :pad-size 2)
219     (client-id :type client-id)))
220    
221     (declare-request save-yourself (request)
222     ((major-opcode :initform *xsmp* :type card8)
223     (minor-opcode :type card8 :pad-size 2)
224     (type :type save-type)
225     (shutdown-p :type boolean)
226     (interact-style :type interact-style)
227     (fast-p :type boolean :pad-size 4)))
228    
229     (declare-request save-yourself-request (request)
230     ((major-opcode :initform *xsmp* :type card8)
231     (minor-opcode :type card8 :pad-size 2)
232     (type :type save-type)
233     (shutdown-p :type boolean)
234     (interact-style :type interact-style)
235     (fast-p :type boolean)
236     (global-p :type boolean :pad-size 3)))
237    
238     (declare-request interact-request (request)
239     ((major-opcode :initform *xsmp* :type card8)
240     (minor-opcode :type card8)
241     (dialog-type :type dialog-type :pad-size 5)))
242    
243     (declare-request interact (request)
244     ((major-opcode :initform *xsmp* :type card8)
245     (minor-opcode :type card8 :pad-size 2)))
246    
247     (declare-request interact-done (request)
248     ((major-opcode :initform *xsmp* :type card8)
249     (minor-opcode :type card8)
250     (cancel-shutdown-p :type boolean :pad-size 1)))
251    
252     (declare-request save-yourself-done (request)
253     ((major-opcode :initform *xsmp* :type card8)
254     (minor-opcode :type card8)
255     (success-p :type boolean :pad-size 1)))
256    
257     (declare-request die (request)
258     ((major-opcode :initform *xsmp* :type card8)
259     (minor-opcode :type card8 :pad-size 2)))
260    
261     (declare-request shutdown-cancelled (request)
262     ((major-opcode :initform *xsmp* :type card8)
263     (minor-opcode :type card8 :pad-size 2)))
264    
265     (declare-request connection-closed (request)
266     ((major-opcode :initform *xsmp* :type card8)
267     (minor-opcode :type card8 :pad-size 2)
268     (reason :type array8s)))
269    
270     (declare-request set-properties (request)
271     ((major-opcode :initform *xsmp* :type card8)
272     (minor-opcode :type card8 :pad-size 2)
273     (properties :type properties)))
274    
275     (declare-request delete-properties (request)
276     ((major-opcode :initform *xsmp* :type card8)
277     (minor-opcode :type card8 :pad-size 2)
278     (properties :type array8s)))
279    
280     (declare-request get-properties (request)
281     ((major-opcode :initform *xsmp* :type card8)
282     (minor-opcode :type card8 :pad-size 2)))
283    
284     (declare-request get-properties-reply (request)
285     ((major-opcode :initform *xsmp* :type card8)
286     (minor-opcode :type card8 :pad-size 2)
287     (properties :type properties)))
288    
289     (declare-request save-yourself-phase2-request (request)
290     ((major-opcode :initform *xsmp* :type card8)
291     (minor-opcode :type card8 :pad-size 2)))
292    
293     (declare-request save-yourself-phase2 (request)
294     ((major-opcode :initform *xsmp* :type card8)
295     (minor-opcode :type card8 :pad-size 2)))
296    
297     (declare-request save-complete (request)
298     ((major-opcode :initform *xsmp* :type card8)
299     (minor-opcode :type card8 :pad-size 2)))
300    
301     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
302     ;;;; ;;;;
303     ;;;; SM Library ;;;;
304     ;;;; ;;;;
305     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
306    
307     (defclass sm-connection (ice-connection)
308     ((client-id
309     :initform nil :initarg :client-id :type client-id
310     :accessor sm-client-id)
311     (sm-release
312     :initform nil :initarg :sm-release :type string
313     :accessor sm-release)
314     (sm-vendor
315     :initform nil :initarg :sm-vendor :type string
316     :accessor sm-vendor)
317     (sm-protocol-version
318     :initform nil :initarg :sm-protocol-version
319     :accessor sm-protocol-version)
320     (sm-protocol-revision
321     :initform nil :initarg :sm-protocol-revision
322     :accessor sm-protocol-revision)))
323    
324     (defun register-xsmp-protocol (opcode)
325     (register-protocol opcode
326     '#(:request-error :register-client :register-client-reply :save-yourself
327     :save-yourself-request :interact-request :interact :interact-done
328     :save-yourself-done :die :shutdown-cancelled :connection-closed
329     :set-properties :delete-properties :get-properties :get-properties-reply
330     :save-yourself-phase2-request :save-yourself-phase2 :save-complete)))
331    
332     (define-condition session-manager-unavailable (error)
333     ((reason
334     :initarg :reason :type string
335     :reader session-manager-unavailable-reason))
336     (:report (lambda (condition stream)
337     (format stream
338     "Unable to connect to session manager: ~a~%"
339     (session-manager-unavailable-reason condition)))))
340    
341     (defmacro signal-sm-error (string &rest args)
342     `(error 'session-manager-unavailable :reason (format nil ,string ,@args)))
343    
344     (defun open-sm-connection (&key must-authenticate-p previous-id network-ids)
345     "Returns an sm-connection object if it succeeds. Otherwise an error will be
346     signaled. (its type will depend on the reason of the failure)
347    
348     - :network-ids : if given, must be a list of network-id for the session
349     manager. If not given, the value of the SESSION_MANAGER environment variable
350     will be used. An attempt will be made to use the first network-id. If this
351     fails an attempt will be made to use the second one, and so on. Each
352     network-id has the following format:
353     local/<HOST-NAME>:<PATH>
354     tcp/<HOST-NAME>:<PORT-NUMBER>
355     decnet/<HOST-NAME>::<OBJ>
356    
357     - :previous-id : if the client is restarted from a previous session, should
358     contain the previous client-id of that previous session. If :previous-id is
359     specified, but is determined to be invalid by the session manager, we will
360     re-register the client with a previous-id set to NIL. If the client is first
361     joining the session :previous-id can be NIL (default) or the empty string.
362    
363     Any authentication requirements are handled internally by the SM Library.
364     The method by which authentication data is obtained is implementation
365     dependent. We only use and know the default use of the ICEauthority file.
366     You will need to register your own methods for other authentication methods.
367     To do so see and use register-ice-authentication-protocol."
368     (declare (type (or null list) network-ids))
369     (declare (type (or null client-id) previous-id))
370     (declare (type boolean must-authenticate-p))
371     (unless network-ids
372     (setf network-ids (list (get-environment-variable)))
373     (when (null (car network-ids))
374     (signal-sm-error "SESSION_MANAGER environment variable is undefined.")))
375     (let ((sm-conn (make-instance 'sm-connection)))
376     (open-connection
377     network-ids :connection sm-conn :must-authenticate-p must-authenticate-p)
378     ;; Send protocol-setup request and wait for protocol-reply,then
379     ;; send register-client and wait for register-client-reply.
380     ;; Authentication will take place behind the scene.
381     (let ((error-handler (ice-error-handler sm-conn))
382     (protocols
383     (available-authentication-protocols
384     "XSMP" (ice-connection-string sm-conn) (ice-auth-proto-names)))
385     (versions (make-default-versions
386     :major +sm-proto-major+ :minor +sm-proto-minor+)))
387     (post-request :protocol-setup sm-conn
388     :protocol-name "XSMP"
389     :protocol-major-opcode +sm-proto-major+
390     :number-of-versions-offered (length versions)
391     :must-authenticate-p must-authenticate-p
392     :vendor-name +vendor-name+
393     :release-name +release-name+
394     :authentication-protocol-names protocols
395     :version-list versions
396     :number-of-authentication-protocol-names-offered
397     (length protocols))
398     (setf (ice-error-handler sm-conn) (lambda (x) x))
399     (request-case (sm-conn :timeout nil :place request :ice-flush-p nil)
400     (authentication-required ((index authentication-protocol-index))
401     (let ((name (aref protocols index)))
402     (funcall (get-protocol-handler name) sm-conn request))
403     (values))
404     (protocol-reply (protocol-major-opcode vendor-name release-name)
405     ;; internally register the protocol.
406     (setf *xsmp* protocol-major-opcode)
407     (register-xsmp-protocol protocol-major-opcode)
408     ;; send the register-client request.
409     (post-request :register-client sm-conn :previous-id previous-id)
410     ;; collect some connection infos.
411     (with-slots (version-index) request
412     (let ((version (aref versions version-index)))
413     (setf (sm-protocol-version sm-conn) (aref version 0))
414     (setf (sm-protocol-revision sm-conn) (aref version 1))))
415     (setf (sm-release sm-conn) release-name)
416     (setf (sm-vendor sm-conn) vendor-name)
417     (values))
418     (register-client-reply (client-id)
419     (setf (sm-client-id sm-conn) client-id))
420     (request-error ((omo offending-minor-opcode) (mo major-opcode))
421     (let ((offender (decode-ice-minor-opcode omo mo)))
422     (if (and (bad-value-p request) (eq offender :register-client))
423     ;; Could not register the client because the previous ID
424     ;; was bad. So now we register the client with the
425     ;; previous ID set to empy string.
426     (post-request :register-client sm-conn :previous-id "")
427     (signal-request-error request)))
428     (values))
429     ;; bad state signal an error.
430     (t (signal-sm-error "bad state during protocol setup: ~a." request)))
431     ;; Reset the error handler and Returns the sm-connection instance.
432     (setf (ice-error-handler sm-conn) error-handler)
433     sm-conn)))
434 ihatchondo 1.2
435     (defun close-sm-connection (sm-conn &key reason)
436     "Close a connection with a session manager."
437     (declare (type sm-connection sm-conn))
438     (declare (type (or null string) reason))
439     (ice-lib:post-request :want-to-close sm-conn)
440     (ice-lib:post-request :connection-closed sm-conn :reason reason)
441     (ice-flush sm-conn)
442     (setf (sm-release sm-conn) nil)
443     (setf (sm-vendor sm-conn) nil)
444     (setf (ice-release sm-conn) nil)
445     (setf (ice-vendor sm-conn) nil)
446     (setf (ice-connection-string sm-conn) nil)
447     (close (ice-lib:connection-stream sm-conn)))

  ViewVC Help
Powered by ViewVC 1.1.5