/[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.8 - (hide annotations)
Mon Jul 12 21:22:55 2004 UTC (9 years, 9 months ago) by ihatchondo
Branch: MAIN
Changes since 1.7: +6 -6 lines
fix wrong slot type declaration in class ice-authority-entry.
remove wrong slots initform from classes ice-connection and sm-connection.
1 ihatchondo 1.1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SM-LIB; -*-
2 ihatchondo 1.8 ;;; $Id: sm.lisp,v 1.8 2004/07/12 21:22:55 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 ihatchondo 1.6 (deftype strings () 'list)
47 ihatchondo 1.1 (deftype properties () 'list)
48    
49     (defstruct property
50     (name nil :type (or null string))
51     (type nil :type (or null string))
52     (values nil :type array8s))
53    
54 ihatchondo 1.6 (defun string->array8 (string)
55     "transform a string into an sm-lib:array8."
56     (declare (type simple-string string))
57     (map 'array8 #'char-code string))
58    
59     (defun array8->string (array)
60     "transform an sm-lib:array8 into a string."
61     (declare (type array8 array))
62     (map 'string #'code-char array))
63    
64     (defun strings->array8s (&rest strings)
65     "transform the given strings into a list of sm-lib:array8."
66     (declare (type list strings))
67     (mapcar #'string->array8 strings))
68    
69     (defun array8s->strings (&rest array8s)
70     "transform the given sm-lib:array8's into a list of simple-string"
71     (declare (type array8s array8s))
72     (mapcar #'array8->string array8s))
73    
74 ihatchondo 1.1 ;; <type>-length functions
75    
76     (defun interact-style-length (value)
77     (declare (ignore value))
78     (declare (optimize (speed 3) (safety 0)))
79     1)
80    
81     (defun dialog-type-length (value)
82     (declare (ignore value))
83     (declare (optimize (speed 3) (safety 0)))
84     1)
85    
86     (defun save-type-length (value)
87     (declare (ignore value))
88     (declare (optimize (speed 3) (safety 0)))
89     1)
90    
91     (defun string-length (string)
92     (declare (type (or null simple-string) string))
93     (let ((length (+ 4 (if (null string) 0 (length string)))))
94     (+ length (mod (- length) 8))))
95    
96     (defun array8-length (array)
97     (declare (type (or null array8) array))
98     (let ((length (+ 4 (if (null array) 0 (length array)))))
99     (+ length (mod (- length) 8))))
100    
101     (defun client-id-length (client-id)
102     (declare (type (or null client-id) client-id))
103     (string-length client-id))
104    
105 ihatchondo 1.6 (defun strings-length (strings)
106     (declare (type strings strings))
107     (+ 8 (loop for s in strings sum (string-length s))))
108    
109 ihatchondo 1.1 (defun array8s-length (arrays)
110     (declare (type array8s arrays))
111     (+ 8 (loop for a in arrays sum (array8-length a))))
112    
113     (defun property-length (property)
114     (declare (type property property))
115     (+ (string-length (property-name property))
116     (string-length (property-type property))
117     (array8s-length (property-values property))))
118    
119     (defun properties-length (properties)
120     (declare (type properties properties))
121     (+ 8 (loop for p in properties sum (property-length p))))
122    
123     ;; type constructor
124    
125     (defun make-array8 (len &rest args &key (initial-element 0) &allow-other-keys)
126     "Creates and returns an array constructed of the most specialized type that
127     can accommodate elements of type (unsigned-byte 8). For the rest of the
128     options see common-lisp:make-array."
129     (declare (type fixnum len))
130     (if (getf args :initial-contents)
131     (remf args :initial-element)
132     (setf (getf args :initial-element) initial-element))
133     (apply #'make-array len :element-type 'card8 args))
134    
135     ;; macro accessor
136    
137     (defmacro define-sequence-accessor (type element-type)
138     (let ((read (sintern (format nil "BUFFER-READ-~a" element-type)))
139     (write (sintern (format nil "BUFFER-WRITE-~a" element-type))))
140     `(define-accessor ,type
141     ((byte-order buffer index)
142 ihatchondo 1.4 (with-gensym (count buff)
143     `(let* ((,buff ,buffer)
144 ihatchondo 1.1 (,count (buffer-read-card32 ,byte-order ,buffer ,index)))
145 ihatchondo 1.4 (declare (type buffer ,buff))
146 ihatchondo 1.1 (incf ,index 4)
147     (loop for i from 0 below ,count
148 ihatchondo 1.4 collect (,',read ,byte-order ,buff ,index)))))
149     ((sequence byte-order buffer index)
150     (with-gensym (seq buff)
151     `(let ((,seq ,sequence) (,buff ,buffer))
152     (declare (type buffer ,buff))
153     (buffer-write-card32 (length ,seq) ,byte-order ,buff ,index)
154 ihatchondo 1.1 (incf ,index 4)
155 ihatchondo 1.4 (loop for e in ,seq
156     do (,',write e ,byte-order ,buff ,index))))))))
157 ihatchondo 1.1
158     ;; <type>-{writer,reader} macros
159    
160     (define-member8-accessor interact-style '#(:none :errors :any))
161    
162     (define-member8-accessor dialog-type '#(:error :normal))
163    
164     (define-member8-accessor save-type '#(:global :local :both))
165    
166     (define-accessor array8
167     ((byte-order buffer index)
168 ihatchondo 1.4 (with-gensym (length array buff)
169     `(let* ((,buff ,buffer)
170     (,length (buffer-read-card32 ,byte-order ,buff ,index))
171     (,array (buffer-read-data ,byte-order ,buff ,index ,length)))
172     (declare (type buffer ,buff))
173 ihatchondo 1.1 (incf ,index (mod (- (+ 4 ,length)) 8))
174     ,array)))
175     ((array byte-order buffer index)
176 ihatchondo 1.4 (with-gensym (length buff)
177 ihatchondo 1.1 `(let ((,length (if (null ,array) 0 (length ,array)))
178 ihatchondo 1.4 (,buff ,buffer))
179     (declare (type buffer ,buff))
180     (buffer-write-card32 ,length ,byte-order ,buff ,index)
181     (buffer-write-data ,array ,byte-order ,buff ,index)
182 ihatchondo 1.1 (incf ,index (mod (- (+ 4 ,length)) 8))))))
183    
184 ihatchondo 1.6 (define-accessor string
185     ((byte-order buffer index)
186     `(map 'string #'code-char (buffer-read-array8 ,byte-order ,buffer ,index)))
187     ((string byte-order buffer index)
188     `(buffer-write-array8
189     (map 'array8 #'char-code ,string) ,byte-order ,buffer ,index)))
190    
191     (define-sequence-accessor strings string)
192    
193 ihatchondo 1.1 (define-sequence-accessor array8s array8)
194    
195     (define-accessor client-id
196     ((byte-order buffer index)
197     `(buffer-read-string ,byte-order ,buffer ,index))
198     ((id byte-order buffer index)
199     `(buffer-write-string ,id ,byte-order ,buffer ,index)))
200    
201     (define-accessor property
202     ((byte-order buffer index)
203 ihatchondo 1.4 (with-gensym (buff)
204     `(let ((,buff ,buffer))
205     (declare (type buffer ,buff))
206 ihatchondo 1.1 (make-property
207 ihatchondo 1.4 :name (buffer-read-string ,byte-order ,buff ,index)
208     :type (buffer-read-string ,byte-order ,buff ,index)
209     :values (buffer-read-array8s ,byte-order ,buff ,index)))))
210     ((property byte-order buffer index)
211     (with-gensym (prop buff)
212     `(multiple-value-bind (,prop ,buff) (values ,property ,buffer)
213     (declare (type buffer ,buff))
214     (buffer-write-string (property-name ,prop) ,byte-order ,buff ,index)
215     (buffer-write-string (property-type ,prop) ,byte-order ,buff ,index)
216 ihatchondo 1.1 (buffer-write-array8s
217 ihatchondo 1.6 (property-values ,prop) ,byte-order ,buff ,index)))))
218 ihatchondo 1.1
219     (define-sequence-accessor properties property)
220    
221     ;;;; Request declarations.
222    
223     (define-request :register-client 1)
224     (define-request :register-client-reply 2)
225     (define-request :save-yourself 3)
226     (define-request :save-yourself-request 4)
227     (define-request :interact-request 5)
228     (define-request :interact 6)
229     (define-request :interact-done 7)
230     (define-request :save-yourself-done 8)
231     (define-request :die 9)
232     (define-request :shutdown-cancelled 10)
233     (define-request :connection-closed 11)
234     (define-request :set-properties 12)
235     (define-request :delete-properties 13)
236     (define-request :get-properties 14)
237     (define-request :get-properties-reply 15)
238     (define-request :save-yourself-phase2-request 16)
239     (define-request :save-yourself-phase2 17)
240     (define-request :save-complete 18)
241    
242     (declare-request register-client (request)
243     ((major-opcode :initform *xsmp* :type card8)
244     (minor-opcode :type card8 :pad-size 2)
245 ihatchondo 1.6 (previous-id :type client-id))
246     (:documentation "The client must send this message to the SM to register the
247     client's existence. If a client is being restarted from a previous session,
248     the previous-ID field must contain the client ID string from the previous
249     session. For new clients, previous-ID should be NIL or the empty string. If
250     previous-ID is not valid, the SM will send a BadValue error message to the
251     client. At this point the SM reverts to the register state and waits for
252     another RegisterClient. The client should then send a Register-Client with
253     a NIL previous-ID field."))
254 ihatchondo 1.1
255     (declare-request register-client-reply (request)
256     ((major-opcode :initform *xsmp* :type card8)
257     (minor-opcode :type card8 :pad-size 2)
258 ihatchondo 1.6 (client-id :type client-id))
259     (:documentation "The client-id specifies a unique identification string for
260     this client. If the client had specified an id in the previous-ID field of
261     the RegisterClient message, client-ID will be identical to the previously
262     specified id.
263     If previous-id was NIL, client-id will be a unique id freshly generated by
264     the SM. The client-id format is specified in section 6 of xsmp specification.
265     If the client didn't supply a previous-id field to the RegisterClient
266     message, the SM must send a SaveYourself message with
267     type = :local, shutdown-p = NIL, interact-style = :none, and fast-p = NIL
268     immediately after the RegisterClientReply. The client should respond to this
269     like any other SaveYourself message."))
270 ihatchondo 1.1
271     (declare-request save-yourself (request)
272     ((major-opcode :initform *xsmp* :type card8)
273     (minor-opcode :type card8 :pad-size 2)
274     (type :type save-type)
275     (shutdown-p :type boolean)
276     (interact-style :type interact-style)
277 ihatchondo 1.6 (fast-p :type boolean :pad-size 4))
278     (:documentation "The SM sends this message to a client to ask it to save its
279     state. The client writes a state file, if necessary, and, if necessary, uses
280     SetProperties to inform the SM of how to restart it and how to discard the
281     saved state. During this process it can, if allowed by interact-style,
282     request permission to interact with the user by sending an InteractRequest
283     message. After the state has been saved, or if it cannot be successfully
284     saved, and the properties are appropriately set, the client sends a
285     SaveYourselfDone message.
286     If the client wants to save additional information after all the other
287     clients have finished changing their own state, the client should send
288     SaveYourselfPhase2Request instead of SaveYourselfDone. The client must then
289     freeze interaction with the user and wait until it receives a SaveComplete,
290     Die, or a ShutdownCancelled message.
291     If interact-style is :none, the client must not interact with the user while
292     saving state. If the interact-style is :errors, the client may interact with
293     the user only if an error condition arises.
294     If interact-style is :any, then the client may interact with the user for
295     any purpose. This is done by sending an InteractRequest message. The SM will
296     send an Interact message to each client that sent an InteractRequest.
297    
298     When a client receives SaveYourself and has not yet responded
299     SaveYourselfDone to a previous SaveYourself, it must send a SaveYourselfDone
300     and may then begin responding as appropriate to the newly received
301     SaveYourself.
302    
303     The type slot specifies the type of information that should be saved:
304     :local indicates that the application must update the properties to
305     reflect its current state, send a SaveYourselfDone and continue.
306     Specifically it should save enough information to restore the state
307     as seen by the user of this client. It should not affect the state
308     as seen by other users.
309     :global indicates that the user wants the client to commit all of its data
310     to permanent, globally-accessible storage.
311     :both indicates that the client should do both of these. In this case,
312     the client should first commit the data to permanent storage before
313     updating its SM properties.
314    
315     The shutdown-p slot specifies whether the system is being shut down.
316    
317     The fast slot specifies whether or not the client should save its state as
318     quickly as possible. For example, if the SM knows that power is about to
319     fail, it should set the fast field to True."))
320 ihatchondo 1.1
321     (declare-request save-yourself-request (request)
322     ((major-opcode :initform *xsmp* :type card8)
323     (minor-opcode :type card8 :pad-size 2)
324     (type :type save-type)
325     (shutdown-p :type boolean)
326     (interact-style :type interact-style)
327     (fast-p :type boolean)
328 ihatchondo 1.6 (global-p :type boolean :pad-size 3))
329     (:documentation "An application sends this to the SM to request a checkpoint.
330     When the SM receives this request it may generate a SaveYourself message in
331     response and it may leave the slots intact.
332     If global-p is set True, then the resulting SaveYourself should be sent to
333     all applications.
334     If global-p is NIL, then the resulting SaveYourself should be sent to the
335     application that sent the SaveYourselfRequest."))
336 ihatchondo 1.1
337     (declare-request interact-request (request)
338     ((major-opcode :initform *xsmp* :type card8)
339     (minor-opcode :type card8)
340 ihatchondo 1.6 (dialog-type :type dialog-type :pad-size 5))
341     (:documentation "During a checkpoint or session-save operation, only one
342     client at a time might be granted the privilege of interacting with the user.
343     The InteractRequest message causes the SM to emit an Interact message at some
344     later time if the shutdown is not cancelled by another client first.
345     The dialog-type slot is one of :error :normal, indicating that the client
346     wants to start an error dialog or normal, meaning the client wishes to start
347     a non-error dialog."))
348 ihatchondo 1.1
349     (declare-request interact (request)
350     ((major-opcode :initform *xsmp* :type card8)
351 ihatchondo 1.6 (minor-opcode :type card8 :pad-size 2))
352     (:documentation "This message grants the client the privilege of interacting
353     with the user. When the client is done interacting with the user it must send
354     an InteractDone message to the SM unless a shutdown cancel is received."))
355 ihatchondo 1.1
356     (declare-request interact-done (request)
357     ((major-opcode :initform *xsmp* :type card8)
358     (minor-opcode :type card8)
359 ihatchondo 1.6 (cancel-shutdown-p :type boolean :pad-size 1))
360     (:documentation "This message is used by a client to notify the SM that it is
361     done interacting. Setting the cancel-shutdown-p to True indicates that the
362     user has requested that the entire shutdown be cancelled. Cancel-shutdown-p
363     may only be True if the corresponding SaveYourself message specified True in
364     the shutdown-p slot and :any or :errors in the interact-style slot. Otherwise,
365     cancel-shutdown-p must be NIL."))
366 ihatchondo 1.1
367     (declare-request save-yourself-done (request)
368     ((major-opcode :initform *xsmp* :type card8)
369     (minor-opcode :type card8)
370 ihatchondo 1.6 (success-p :type boolean :pad-size 1))
371     (:documentation "This message is sent by a client to indicate that all of the
372     properties representing its state have been updated. After sending
373     SaveYourselfDone the client must wait for a SaveComplete, ShutdownCancelled,
374     or Die message before changing its state. If the SaveYourself operation was
375     successful, then the client should set the success-p slot to True; otherwise
376     the client should set it to False."))
377 ihatchondo 1.1
378     (declare-request die (request)
379     ((major-opcode :initform *xsmp* :type card8)
380 ihatchondo 1.6 (minor-opcode :type card8 :pad-size 2))
381     (:documentation "When the SM wants a client to die it sends a Die message.
382     Before the client dies it responds by sending a ConnectionClosed message
383     and may then close its connection to the SM at any time."))
384 ihatchondo 1.1
385     (declare-request shutdown-cancelled (request)
386     ((major-opcode :initform *xsmp* :type card8)
387 ihatchondo 1.6 (minor-opcode :type card8 :pad-size 2))
388     (:documentation "The shutdown currently in process has been aborted. The
389     client can now continue as if the shutdown had never happened. If the client
390     has not sent SaveYourselfDone yet, the client can either abort the save and
391     send SaveYourselfDone with the success-p slot set to Nil, or it can continue
392     with the save and send a SaveYourselfDone with the success-p slot set to
393     reflect the outcome of the save."))
394 ihatchondo 1.1
395     (declare-request connection-closed (request)
396     ((major-opcode :initform *xsmp* :type card8)
397     (minor-opcode :type card8 :pad-size 2)
398 ihatchondo 1.6 (reason :type strings))
399     (:documentation "Specifies that the client has decided to terminate. It
400     should be immediately followed by closing the connection.
401     The reason slot specifies why the client is resigning from the session. It
402     is encoded as alist of simple strings. If the resignation is expected by the
403     user, there will typically be a NIL or a null string here. But if the client
404     encountered an unexpected fatal error, the error message (which might
405     otherwise be printed on *standard-error*) should be forwarded to the SM here,
406     one string per line of the message. It is the responsibility of the SM to
407     display this reason to the user.
408     After sending this message, the client must not send any additional XSMP
409     messages to the SM."))
410 ihatchondo 1.1
411     (declare-request set-properties (request)
412     ((major-opcode :initform *xsmp* :type card8)
413     (minor-opcode :type card8 :pad-size 2)
414 ihatchondo 1.6 (properties :type properties))
415     (:documentation "Sets the specified properties to the specified values.
416     Existing properties not specified in the SetProperties message are
417     unaffected. Some properties have predefined semantics. See section 11,
418     ``Predefined Properties.'' The protocol specification recommends that
419     property names used for properties not defined by the standard should begin
420     with an underscore. To prevent conflicts among organizations, additional
421     prefixes should be chosen. The organizational prefixes should be registered
422     with the X Registry. The XSMP reserves all property names not beginning with
423     an underscore for future use."))
424 ihatchondo 1.1
425     (declare-request delete-properties (request)
426     ((major-opcode :initform *xsmp* :type card8)
427     (minor-opcode :type card8 :pad-size 2)
428 ihatchondo 1.6 (properties :type strings))
429     (:documentation "Removes the named properties."))
430 ihatchondo 1.1
431     (declare-request get-properties (request)
432     ((major-opcode :initform *xsmp* :type card8)
433 ihatchondo 1.6 (minor-opcode :type card8 :pad-size 2))
434     (:documentation "Requests that the SM respond with the values of all the
435     properties for this client."))
436 ihatchondo 1.1
437     (declare-request get-properties-reply (request)
438     ((major-opcode :initform *xsmp* :type card8)
439     (minor-opcode :type card8 :pad-size 2)
440 ihatchondo 1.6 (properties :type properties))
441     (:documentation "This message is sent in reply to a GetProperties message
442     and includes the values of all the properties."))
443 ihatchondo 1.1
444     (declare-request save-yourself-phase2-request (request)
445     ((major-opcode :initform *xsmp* :type card8)
446 ihatchondo 1.6 (minor-opcode :type card8 :pad-size 2))
447     (:documentation "This message is sent by a client to indicate that it needs
448     to be informed when all the other clients are quiescent, so it can continue
449     its state."))
450 ihatchondo 1.1
451     (declare-request save-yourself-phase2 (request)
452     ((major-opcode :initform *xsmp* :type card8)
453 ihatchondo 1.6 (minor-opcode :type card8 :pad-size 2))
454     (:documentation "The SM sends this message to a client that has previously
455     sent a SaveYourselfPhase2Request message. This message informs the client
456     that all other clients are in a fixed state and this client can save state
457     that is associated with other clients.
458     The client writes a state file, if necessary, and, if necessary, uses
459     SetProperties to inform the SM of how to restart it and how to discard the
460     saved state. During this process it can request permission to interact with
461     the user by sending an InteractRequest message. This should only be done if
462     an error occurs that requires user interaction to resolve. After the state
463     has been saved, or if it cannot be successfully saved, and the properties
464     are appropriately set, the client sends a SaveYourselfDone message."))
465 ihatchondo 1.1
466     (declare-request save-complete (request)
467     ((major-opcode :initform *xsmp* :type card8)
468 ihatchondo 1.6 (minor-opcode :type card8 :pad-size 2))
469     (:documentation "When the SM is done with a checkpoint, it will send each
470     of the clients a SaveComplete message. The client is then free to change
471     its state."))
472 ihatchondo 1.1
473     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
474     ;;;; ;;;;
475     ;;;; SM Library ;;;;
476     ;;;; ;;;;
477     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
478    
479     (defclass sm-connection (ice-connection)
480     ((client-id
481 ihatchondo 1.8 :initarg :client-id :type client-id
482 ihatchondo 1.1 :accessor sm-client-id)
483     (sm-release
484 ihatchondo 1.8 :initarg :sm-release :type string
485 ihatchondo 1.1 :accessor sm-release)
486     (sm-vendor
487 ihatchondo 1.8 :initarg :sm-vendor :type string
488 ihatchondo 1.1 :accessor sm-vendor)
489     (sm-protocol-version
490 ihatchondo 1.8 :initarg :sm-protocol-version :type card16
491 ihatchondo 1.1 :accessor sm-protocol-version)
492     (sm-protocol-revision
493 ihatchondo 1.8 :initarg :sm-protocol-revision :type card16
494 ihatchondo 1.1 :accessor sm-protocol-revision)))
495    
496     (defun register-xsmp-protocol (opcode)
497     (register-protocol opcode
498     '#(:request-error :register-client :register-client-reply :save-yourself
499     :save-yourself-request :interact-request :interact :interact-done
500     :save-yourself-done :die :shutdown-cancelled :connection-closed
501     :set-properties :delete-properties :get-properties :get-properties-reply
502     :save-yourself-phase2-request :save-yourself-phase2 :save-complete)))
503    
504     (define-condition session-manager-unavailable (error)
505     ((reason
506     :initarg :reason :type string
507     :reader session-manager-unavailable-reason))
508     (:report (lambda (condition stream)
509     (format stream
510 ihatchondo 1.3 "SM-lib: Unable to connect to session manager: ~a~%"
511 ihatchondo 1.1 (session-manager-unavailable-reason condition)))))
512    
513     (defmacro signal-sm-error (string &rest args)
514     `(error 'session-manager-unavailable :reason (format nil ,string ,@args)))
515    
516     (defun open-sm-connection (&key must-authenticate-p previous-id network-ids)
517     "Returns an sm-connection object if it succeeds. Otherwise an error will be
518     signaled. (its type will depend on the reason of the failure)
519    
520     - :network-ids : if given, must be a list of network-id for the session
521     manager. If not given, the value of the SESSION_MANAGER environment variable
522     will be used. An attempt will be made to use the first network-id. If this
523     fails an attempt will be made to use the second one, and so on. Each
524     network-id has the following format:
525     local/<HOST-NAME>:<PATH>
526     tcp/<HOST-NAME>:<PORT-NUMBER>
527     decnet/<HOST-NAME>::<OBJ>
528    
529     - :previous-id : if the client is restarted from a previous session, should
530     contain the previous client-id of that previous session. If :previous-id is
531     specified, but is determined to be invalid by the session manager, we will
532     re-register the client with a previous-id set to NIL. If the client is first
533     joining the session :previous-id can be NIL (default) or the empty string.
534    
535     Any authentication requirements are handled internally by the SM Library.
536     The method by which authentication data is obtained is implementation
537     dependent. We only use and know the default use of the ICEauthority file.
538     You will need to register your own methods for other authentication methods.
539     To do so see and use register-ice-authentication-protocol."
540     (declare (type (or null list) network-ids))
541     (declare (type (or null client-id) previous-id))
542     (declare (type boolean must-authenticate-p))
543     (unless network-ids
544     (setf network-ids (list (get-environment-variable)))
545     (when (null (car network-ids))
546     (signal-sm-error "SESSION_MANAGER environment variable is undefined.")))
547     (let ((sm-conn (make-instance 'sm-connection)))
548     (open-connection
549     network-ids :connection sm-conn :must-authenticate-p must-authenticate-p)
550     ;; Send protocol-setup request and wait for protocol-reply,then
551     ;; send register-client and wait for register-client-reply.
552     ;; Authentication will take place behind the scene.
553 ihatchondo 1.7 (let ((protocols
554 ihatchondo 1.1 (available-authentication-protocols
555     "XSMP" (ice-connection-string sm-conn) (ice-auth-proto-names)))
556     (versions (make-default-versions
557     :major +sm-proto-major+ :minor +sm-proto-minor+)))
558 ihatchondo 1.5 (declare (type (simple-array string (*)) protocols))
559     (declare (type versions versions))
560 ihatchondo 1.1 (post-request :protocol-setup sm-conn
561 ihatchondo 1.6 :protocol-name "XSMP"
562     :protocol-major-opcode +sm-proto-major+
563     :number-of-versions-offered (length versions)
564     :must-authenticate-p must-authenticate-p
565     :vendor-name +vendor-name+
566     :release-name +release-name+
567     :authentication-protocol-names protocols
568     :version-list versions
569     :number-of-authentication-protocol-names-offered (length protocols))
570 ihatchondo 1.7 (with-error-handler (sm-conn #'(lambda (x) x))
571     (request-case (sm-conn :timeout nil :place request :ice-flush-p nil)
572     (authentication-required ((index authentication-protocol-index))
573     (let ((handler (get-protocol-handler (aref protocols index))))
574     (declare (type function handler))
575     (funcall handler sm-conn request))
576     (values))
577     (protocol-reply (protocol-major-opcode vendor-name release-name)
578     ;; internally register the protocol.
579     (setf *xsmp* protocol-major-opcode)
580     (register-xsmp-protocol protocol-major-opcode)
581     ;; send the register-client request.
582     (post-request :register-client sm-conn :previous-id previous-id)
583     ;; collect some connection infos.
584     (with-slots (version-index) request
585     (let ((version (aref versions version-index)))
586     (declare (type version version))
587     (setf (sm-protocol-version sm-conn) (aref version 0))
588     (setf (sm-protocol-revision sm-conn) (aref version 1))))
589     (setf (sm-release sm-conn) release-name)
590     (setf (sm-vendor sm-conn) vendor-name)
591     (values))
592     (register-client-reply (client-id)
593     (setf (sm-client-id sm-conn) client-id))
594     (request-error ((omo offending-minor-opcode) (mo major-opcode))
595     (let ((offender (decode-ice-minor-opcode omo mo)))
596     (if (and (bad-value-p request) (eq offender :register-client))
597     ;; Could not register the client because the previous ID
598     ;; was bad. So now we register the client with the
599     ;; previous ID set to empy string.
600     (post-request :register-client sm-conn :previous-id "")
601     ;; signal an error.
602     (request-error-handler request)))
603     (values))
604     ;; bad state signal an error.
605     (t (signal-sm-error "bad state during protocol setup: ~a." request))))
606 ihatchondo 1.1 sm-conn)))
607 ihatchondo 1.2
608     (defun close-sm-connection (sm-conn &key reason)
609     "Close a connection with a session manager."
610     (declare (type sm-connection sm-conn))
611     (declare (type (or null string) reason))
612     (ice-lib:post-request :want-to-close sm-conn)
613     (ice-lib:post-request :connection-closed sm-conn :reason reason)
614     (ice-flush sm-conn)
615     (setf (sm-release sm-conn) nil)
616     (setf (sm-vendor sm-conn) nil)
617     (setf (ice-release sm-conn) nil)
618     (setf (ice-vendor sm-conn) nil)
619     (setf (ice-connection-string sm-conn) nil)
620     (close (ice-lib:connection-stream sm-conn)))

  ViewVC Help
Powered by ViewVC 1.1.5