source: trunk/source/cocoa-ide/ide-self-update.lisp @ 9668

Last change on this file since 9668 was 9668, checked in by mikel, 12 years ago

implemented code to support the update UI, and to ahndle error conditions that block the update from proceeding

File size: 11.4 KB
Line 
1;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: cl-user -*-
2;;;; ***********************************************************************
3;;;; FILE IDENTIFICATION
4;;;;
5;;;; Name:          svn-self.lisp
6;;;; Version:       0.1
7;;;; Project:       Cocoa IDE
8;;;; Purpose:       Cocoa UI for updating the Cocoa IDE from the source repo
9;;;;
10;;;; ***********************************************************************
11
12(in-package :ccl)
13
14;;; IDE: decide how and whether to handle cvs self-updates.
15;;; see the cvs/svn code in update-ccl in compile-ccl.lisp
16
17;;; use GUI::FIND-CCL-DIRECTORY to find the effective CCL directory
18;;; (it gracefully handles the case where we are running from an
19;;; app bundle, as well as the case where we are not)
20
21;;; How to self-update the IDE from the svn or cvs repo
22;;; 1. Find the ccl directory that corresponds to the running image
23;;; 2. determine whether this is an svn or cvs checkout
24;;; 3. SVN:
25;;;   a. find the .svn directory
26;;;   b. run svn info to get the svn URL
27;;;   c. determine from the URL whether we need to authenticate
28;;;   d. get auth tokens if we need them
29;;;   d. record the svn revision before we start (so we can roll back
30;;;      if things go horribly wrong)
31;;;   e. run svn status to check for potential merge conflicts before starting
32;;;      the update
33;;;   f. construct the svn command:
34;;;       i. cd to the proper CCL directory
35;;;      ii. run svn update
36;;;   g. run the svn command with external-process-status.
37;;;   h.  check the status of the external command for success or failure:
38;;;      i. if okay, queue a full-rebuild, and a rebuild of the IDE
39;;;         (need to make some infrastructure for queuing these activities
40;;;         and running them on next launch, or immediately in an external process)
41;;;     ii. if not okay, warn the user, and offer to roll back to the
42;;;         previously-recorded version (need to make some infrastructure for
43;;;         running a rollback)
44;;; TODO: make a cvs version if needed
45
46;;; -----------------------------------------------------------------
47;;; svn metadata utils
48;;; -----------------------------------------------------------------
49
50;;; VALIDATE-SVN-DATA-PATHNAME p
51;;; ---------------------
52;;; returns TRUE if P is really an existing directory that appears to
53;;; contain valid Subversion metadata; FALSE otherwise
54
55(defun validate-svn-data-pathname (p)
56  (and (probe-file p)
57       (directoryp p)
58       (string= ".svn" (first (last (pathname-directory p))))
59       ;; if we reached this point, it's an existing directory
60       ;; named ".svn". now, does it have Subversion metadata files
61       ;; in it?
62       (let ((subversion-metafiles '("dir-prop-base" "entries" "format"
63                                     "prop-base/" "props/" "text-base/")))
64         (every (lambda (f) (probe-file (merge-pathnames f p))) 
65                subversion-metafiles))))
66
67;;; given a valid-looking .svn directory, we should be able to use
68;;; the svn executable to get the repository URL. we call:
69;;;  svn info
70;;; and get a big block of info text. one line of the output
71;;; is of the form:
72;;;  URL: yatta-yatta
73;;; where yatta-yatta is the repository URL of the checked out directory
74;;; Another piece of information we want shows Up here, too: the
75;;; current revision, on a line of the form:
76;;; Revision: foobar
77
78(defun split-svn-info-line (line)
79  (let* ((split-sequence ": ")
80         (split-index (find-matching-subsequence split-sequence line :test #'char=))
81         (prefix (subseq line 0 split-index))
82         (suffix (subseq line (if split-index
83                                  (+ split-index (length split-sequence))
84                                  (length line)))))
85    (list prefix suffix)))
86
87(defun parse-svn-info (info-string)
88  (let ((info-lines (split-lines info-string)))
89    (mapcar #'split-svn-info-line info-lines)))
90
91(defun get-svn-info (p)
92  (parse-svn-info
93   (with-output-to-string (out)
94     (run-program "svn" `("info" ,(namestring p)) :output out))))
95
96;;; -----------------------------------------------------------------
97;;; authentication utils, for use with source control
98;;; -----------------------------------------------------------------
99
100;;; we infer from the information in the URL field of the svn info
101;;; whether we need to authenticate. The assumed criteria in this
102;;; implementation are that we don't need to authenticate if the
103;;; URL is an http:: URL; if it's an svn+ssh URL, then we do need
104;;; to authenticate
105
106(defparameter *authentication-window-controller* nil)
107
108(defclass authentication-window-controller (ns:ns-window-controller)
109    ((authentication-window :foreign-type :id :reader authentication-window)
110     (username-field :foreign-type :id :reader authentication-window-username-field)
111     (password-field :foreign-type :id :reader authentication-window-password-field))
112  (:metaclass ns:+ns-object))
113
114(objc:defmethod #/windowNibName ((self authentication-window-controller))
115  #@"Authenticate")
116
117(objc:defmethod (#/authOkay: :void) ((self authentication-window-controller) sender)
118  (declare (ignore sender))
119  (#/stopModalWithCode: (#/sharedApplication (@class ns-application)) 1)
120  (#/orderOut: (authentication-window *authentication-window-controller*) +null-ptr+))
121
122(objc:defmethod (#/authCancel: :void) ((self authentication-window-controller) sender)
123  (declare (ignore sender))
124  (#/stopModalWithCode: (#/sharedApplication (@class ns-application)) 0)
125  (#/orderOut: (authentication-window *authentication-window-controller*) +null-ptr+))
126
127(defun get-auth-window ()
128  (unless *authentication-window-controller*
129    (setf *authentication-window-controller* 
130          (make-instance 'authentication-window-controller))
131    (#/initWithWindowNibName: *authentication-window-controller* #@"Authenticate"))
132  (unless (#/isWindowLoaded *authentication-window-controller*)
133    (#/loadWindow *authentication-window-controller*))
134  (let ((window (authentication-window *authentication-window-controller*)))
135    (if (or (null window)
136            (%null-ptr-p window))
137        nil
138        window)))
139
140(defun get-svn-auth-data ()
141  (let ((auth-window (get-auth-window)))
142    (if auth-window
143        (let ((window-status (#/runModalForWindow: (#/sharedApplication (@class ns-application))
144                                                   auth-window)))
145          (if (zerop window-status)
146              nil
147              (let  ((username (lisp-string-from-nsstring (#/stringValue (authentication-window-username-field 
148                                                                          *authentication-window-controller*))))
149                     (password (lisp-string-from-nsstring (#/stringValue (authentication-window-password-field 
150                                                                          *authentication-window-controller*)))))
151                (cons username password))))
152        nil)))
153
154;;; -----------------------------------------------------------------
155;;; svn updates
156;;; -----------------------------------------------------------------
157
158(defun alert (&key 
159              (title "Alert")
160              (message "Something happened.")
161              (default-button "Okay")
162              alternate-button
163              other-button)
164  (let ((nstitle (%make-nsstring title))
165        (nsmessage (%make-nsstring message))
166        (ns-default-button (%make-nsstring default-button))
167        (ns-alternate-button (or (and alternate-button (%make-nsstring alternate-button))
168                                 +null-ptr+))
169        (ns-other-button (or (and other-button (%make-nsstring other-button))
170                             +null-ptr+)))
171    (#_NSRunAlertPanel nstitle nsmessage ns-default-button ns-alternate-button ns-other-button)
172    (#/release nstitle)
173    (#/release nsmessage)
174    (#/release ns-default-button)
175    (unless (eql ns-alternate-button +null-ptr+)
176      (#/release ns-alternate-button))
177    (unless (eql ns-other-button +null-ptr+)
178      (#/release ns-other-button))))
179
180(defun valid-revision-number-for-svn-update? (rev)
181  (and (stringp rev)
182       (plusp (length rev))))
183
184(defun valid-repository-for-svn-update? (url)
185  (and (stringp url)
186       ;; TODO: examine the url to see if it makes sense
187       ))
188
189(defun valid-directory-for-svn-update? (dir)
190  (and dir
191       (probe-file dir)
192       (directoryp dir)
193       (validate-svn-data-pathname (merge-pathnames ".svn/" dir))))
194
195(defun svn-update-ccl (&key directory repository last-revision)
196  (cond
197    ((not (valid-directory-for-svn-update? directory)) 
198     (alert :title "Update Failed"
199            :message (format nil "Subversion update failed. CCL directory '~A' doesn't exist, or lacks valid Subversion metadata."
200                             directory)))
201    ((not (valid-repository-for-svn-update? repository))
202     (alert :title "Update Failed"
203            :message (format nil "Subversion update failed. The supplied repository URL is invalid: '~A'"
204                             repository)))
205    ((not (valid-revision-number-for-svn-update? last-revision))
206     (alert :title "Update Failed"
207            :message (format nil "Subversion update failed. CCL found an invalid revision number for the current working copy: '~A'"
208                             last-revision)))
209    (t (alert :title "Update Succeeded"
210              :message "Subversion update succeeded. Soon we will actually run the update when it succeeds."))))
211
212(defun run-svn-update-for-directory (dir)
213  (let* ((svn-info (get-svn-info dir))
214         (revision-entry (assoc "Revision" svn-info :test #'string=))
215         (revision (and revision-entry (second revision-entry)))
216         (url-entry (assoc "URL" svn-info :test #'string=))
217         (url (and url-entry (second url-entry))))
218    (svn-update-ccl :directory dir :repository url :last-revision revision)))
219 
220(defun run-svn-update ()
221  (run-svn-update-for-directory (gui::find-ccl-directory)))
222
223;;; -----------------------------------------------------------------
224;;; app delegate extensions to handle self-update UI
225;;; -----------------------------------------------------------------
226
227(defparameter *update-ccl-window-controller* nil)
228
229(defclass update-ccl-window-controller (ns:ns-window-controller)
230    ((update-window :foreign-type :id :reader update-window))
231  (:metaclass ns:+ns-object))
232
233(objc:defmethod #/windowNibName ((self update-ccl-window-controller))
234  #@"updateCCL")
235
236(objc:defmethod (#/updateCCLOkay: :void) ((self update-ccl-window-controller) sender)
237  (declare (ignore sender))
238  (#/stopModalWithCode: (#/sharedApplication (@class ns-application)) 1)
239  (run-svn-update)
240  (#/orderOut: (update-window *update-ccl-window-controller*) +null-ptr+))
241
242(objc:defmethod (#/updateCCLCancel: :void) ((self update-ccl-window-controller) sender)
243  (declare (ignore sender))
244  (#/stopModalWithCode: (#/sharedApplication (@class ns-application)) 0)
245  (#/orderOut: (update-window *update-ccl-window-controller*) +null-ptr+))
246
247(objc:defmethod (#/updateCCL: :void) ((self lisp-application-delegate)
248                                                sender)
249  (declare (ignore sender))
250  (when (null *update-ccl-window-controller*)
251    (setf *update-ccl-window-controller*
252          (make-instance 'update-ccl-window-controller))
253    (#/initWithWindowNibName: *update-ccl-window-controller* #@"updateCCL"))
254  ;;(#/showWindow: *update-ccl-window-controller* self)
255  (unless (#/isWindowLoaded *update-ccl-window-controller*)
256    (#/loadWindow *update-ccl-window-controller*))
257  (#/runModalForWindow: (#/sharedApplication (@class ns-application)) 
258                        (update-window *update-ccl-window-controller*)))
259
Note: See TracBrowser for help on using the repository browser.