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

  ViewVC Help
Powered by ViewVC 1.1.5