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

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

swank loading works; SLIME/swank connections work; UI control of swank load and startup works. Likely need additional error-handlng.

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