source: trunk/source/cocoa-ide/swank-listener.lisp @ 12214

Last change on this file since 12214 was 12214, checked in by mikel, 11 years ago

lots more errors get caught now. repeatedly using the emacs utility to request a swank load and connection correctly creates multiple swank connections. It's possible to disconnect from and reconnect to a CCl using a swank server loaded by the load request. It's possible to kill CCL and relaunch it, and reconnect to the new CCL using the emacs request.

the handshake is hairy enough that additional uncaught errors probably remain.

File size: 12.0 KB
Line 
1;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: cl-user -*-
2;;;; ***********************************************************************
3;;;; FILE IDENTIFICATION
4;;;;
5;;;; Name:          swank.lisp
6;;;; Project:       CCL IDE
7;;;; Purpose:       CCL's swank loader
8;;;;
9;;;; ***********************************************************************
10
11;;; ABOUT
12;;; ------------------------------------------------------------------------
13;;; implements tools used to locate and load a swank server at app startup.
14
15(in-package :GUI)
16
17(defparameter *ccl-swank-active-p* nil)
18(defparameter *default-swank-listener-port* 4884)
19(defparameter *active-gui-swank-listener-port* nil)
20(defparameter *ccl-swank-listener-active-p* nil)
21(defvar *swank-listener-process* nil)
22
23(defun swank-listener-active? ()
24  (and *swank-listener-process*
25       (typep *swank-listener-process* 'process)
26       (not (member (process-whostate *swank-listener-process*)
27                    '("Reset" "Exhausted")
28                    :test 'string-equal))))
29
30;;; preference-swank-listener-port
31;;; returns the current value of the "Swank Port" user preference
32(defun preference-swank-listener-port ()
33  (with-autorelease-pool
34    (let* ((defaults (handler-case (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller))
35                       (serious-condition (c) 
36                         (progn (log-debug "~%ERROR: Unable to get preferences from the Shared User Defaults Controller: ~A"
37                                           c)
38                                nil))))
39           (swank-port-pref (and defaults (#/valueForKey: defaults #@"swankListenerPort"))))
40      (cond
41        ;; the user default is not initialized
42        ((or (null swank-port-pref)
43             (%null-ptr-p swank-port-pref)) nil)
44        ;; examine the user default
45        ((or (typep swank-port-pref 'ns:ns-number)
46             (typep swank-port-pref 'ns:ns-string)) 
47         (handler-case (let* ((port (#/intValue swank-port-pref)))
48                         (or port *default-swank-listener-port*))
49           ;; parsing the port number failed
50           (serious-condition (c)
51             (declare (ignore c))
52             (setf *ccl-swank-listener-active-p* nil)
53             (#_NSLog #@"\nError starting swank listener; the user preference is not a valid port number: %@\n"
54                    :id swank-port-pref)
55             nil)))
56        ;; the user default value is incomprehensible
57        (t (progn
58             (#_NSLog #@"\nERROR: Unrecognized value type in user preference 'swankListenerPort': %@"
59                    :id swank-port-pref)
60             nil))))))
61
62;;; preference-start-swank-listener? 
63;;; returns the current value of the "Start swank listener?" user
64;;; preference
65(defun preference-start-swank-listener? ()
66  (with-autorelease-pool
67   (let* ((defaults (handler-case (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller))
68                     (serious-condition (c) 
69                       (progn (log-debug "~%ERROR: Unable to get preferences from the Shared User Defaults Controller: ~a" c)
70                              nil))))
71         (start-swank-pref (if (and defaults (not (%null-ptr-p defaults))) 
72                               (#/valueForKey: defaults #@"startSwankListener")         
73                               nil)))
74    (cond
75      ;; the user default is not initialized
76      ((or (null start-swank-pref)
77           (%null-ptr-p start-swank-pref)) nil)
78      ;; examine the user default
79      ;; intValue works on NSNumber or NSString
80      ;; BUG? if a string value is not a valid representation of an integer,
81      ;;      intValue returns 0, which means any non-numeric string will have the
82      ;;      same effect as "0"
83      ((or (typep start-swank-pref 'ns:ns-number)
84           (typep start-swank-pref 'ns:ns-string))
85       (case (#/intValue start-swank-pref)
86         ;; don't start swank listener
87         (0 nil)
88         ;; start swank listener
89         (1 t)
90         ;; the user default value is incomprehensible
91         (otherwise (progn
92                      (log-debug "~%ERROR: Unrecognized value in user preference 'startSwankServer': ~S"
93                                 start-swank-pref)
94                      nil))))
95      ;; the user default value is incomprehensible
96      (t (progn
97           (log-debug "~%ERROR: Unrecognized value type in user preference 'startSwankServer': ~S"
98                      start-swank-pref)
99           nil))))))
100
101;;; start-swank-listener
102;;; -----------------------------------------------------------------
103;;; starts up CCL's swank-listener server on the specified port
104
105;;; aux utils
106
107(defvar $emacs-ccl-swank-request-marker "[emacs-ccl-swank-request]")
108
109(defvar $last-swank-message-sent nil)
110
111(defun swank-server-running? ()
112  (and (find-package :swank)
113       (let ((active-listeners (symbol-value (intern "*LISTENER-SOCKETS*" :swank))))
114         (and (not (null active-listeners))
115              (first active-listeners)))))
116
117(defstruct (swank-status (:conc-name swank-))
118  (active? nil :read-only t)
119  (message nil :read-only t)
120  (requested-loader nil :read-only t)
121  (requested-port nil :read-only t))
122
123(defun read-swank-ping (tcp-stream) 
124  (read-line tcp-stream nil nil nil))
125
126(defun parse-swank-ping (p) 
127  (let ((sentinel-end (length $emacs-ccl-swank-request-marker)))
128    (if (typep p 'string)
129        (if (string= p $emacs-ccl-swank-request-marker :start1 0 :end1 sentinel-end)
130            (let* ((request (subseq p sentinel-end))
131                   (split-pos (position #\: request))
132                   (port-str (if split-pos
133                                 (subseq request 0 split-pos)
134                                 nil))
135                   (port (when port-str (parse-integer port-str :junk-allowed nil)))
136                   (path-str (if split-pos
137                                 (subseq request (1+ split-pos))
138                                 request)))
139              (values (string-trim '(#\space #\tab #\return #\newline) path-str) port))
140            nil)
141        nil)))
142
143
144(defun load-and-start-swank (path requested-port) 
145  (handler-case (let* ((active-swank-port (swank-server-running?))
146                       (msg (format nil "A swank server is already running on port ~A" active-swank-port)))
147                  (if active-swank-port
148                      (progn
149                        (log-debug msg)
150                        (make-swank-status :active? t :message msg :requested-loader path :requested-port requested-port))
151                      (progn
152                        (load path)
153                        (let ((swank-loader-package (find-package :swank-loader)))
154                          (if swank-loader-package
155                              ;; swank loaded. start the server
156                              (progn
157                                (funcall (intern "LOAD-SWANK" swank-loader-package))
158                                (funcall (intern "CREATE-SERVER" (find-package :swank)) :port requested-port :dont-close t)
159                                (make-swank-status :active? t :requested-loader path :requested-port requested-port))
160                              ;; swank failed to load. return failure status
161                              (make-swank-status :active? nil :message "swank load failed" :requested-loader path :requested-port requested-port))))))
162    (ccl::socket-creation-error (e) (log-debug "Unable to start a swank server on port: ~A; ~A"
163                                               requested-port e)
164                                (make-swank-status :active? nil :message "socket-creation error"
165                                                   :requested-loader path :requested-port requested-port))
166    (serious-condition (e) (log-debug "There was a problem creating the swank server on port ~A: ~A"
167                                      requested-port e)
168                       (make-swank-status :active? nil :message "error loading or starting swank"
169                                          :requested-loader path :requested-port requested-port))))
170
171(defun swank-ready? (status)
172  (swank-active? status))
173
174(defun send-swank-response (tcp-stream status)
175  (let ((response 
176         (let ((*print-case* :downcase))
177           (format nil "(:active ~S :loader ~S :message ~S :port ~D)"
178                   (swank-active? status)
179                   (swank-requested-loader status)
180                   (swank-message status)
181                   (swank-requested-port status)))))
182    (format tcp-stream response)
183    (finish-output tcp-stream)))
184
185(defun handle-swank-client (c)
186  (let* ((msg (read-swank-ping c)))
187    (multiple-value-bind (swank-path requested-port)
188        (parse-swank-ping msg)
189      (load-and-start-swank swank-path requested-port))))
190
191(defun stop-swank-listener ()
192  (process-kill *swank-listener-process*)
193  (setq *swank-listener-process* nil))
194
195;;; the real deal
196;;; if it succeeds, it returns a PROCESS object
197;;; if it fails, it returns a CONDITION object
198(defun start-swank-listener (&optional (port *default-swank-listener-port*))
199  (handler-case 
200      (if (swank-listener-active?)
201          (log-debug "in start-swank-listener: the swank listener process is already running")
202          (setq *swank-listener-process*
203                (process-run-function "Swank Listener"
204                                      #'(lambda ()
205                                          (with-open-socket (sock :type :stream :connect :passive 
206                                                                  :local-port port :reuse-address t :auto-close t)
207                                            (loop
208                                               (let* ((client-sock (accept-connection sock))
209                                                      (status (handle-swank-client client-sock)))
210                                                 (send-swank-response client-sock status))))))))
211    (ccl::socket-creation-error (c) (nslog-condition c "Unable to create a socket for the swank-listener: ") c)
212    (ccl::socket-error (c) (nslog-condition c "Swank-listener failed trying to accept a client connection: ") c)
213    (serious-condition (c) (nslog-condition c "Error starting in the swank-listener:") c)))
214
215;;; maybe-start-swank-listener
216;;; -----------------------------------------------------------------
217;;; checks whether to start the ccl swank listener, and starts it if
218;;; warranted.
219(defun maybe-start-swank-listener (&key (override-user-preference nil))
220  (unless *ccl-swank-listener-active-p*
221    ;; try to determine the user preferences concerning the
222    ;; swank-listener port number and whether the swank listener
223    ;; should be started. If the user says start it, and we can
224    ;; determine a valid port for it, start it up
225    (let* ((start-swank-listener? (or (preference-start-swank-listener?) override-user-preference))
226           (swank-listener-port (or (preference-swank-listener-port) *default-swank-listener-port*)))
227      (if (and start-swank-listener? swank-listener-port)
228          ;; try to start the swank listener
229          (handler-case (let ((swank-listener (start-swank-listener swank-listener-port)))
230                          (if (typep swank-listener 'process)
231                              (progn
232                                (setf *active-gui-swank-listener-port* swank-listener-port)
233                                (setf *ccl-swank-listener-active-p* t)
234                                swank-listener-port)
235                              (progn
236                                (setf *active-gui-swank-listener-port* nil)
237                                (setf *ccl-swank-listener-active-p* nil)
238                                nil)))
239            ;; swank listener creation failed
240            (serious-condition (c)
241              (setf *active-gui-swank-listener-port* nil)
242              (setf *ccl-swank-listener-active-p* nil)
243              (log-debug "~%Error starting swank listener: ~A~%" c)
244              nil))
245          ;; don't try to start the swank listener
246          (progn
247            (setf *active-gui-swank-listener-port* nil)
248            (setf *ccl-swank-listener-active-p* nil)
249            nil)))))
250
251(provide :swank-listener)
Note: See TracBrowser for help on using the repository browser.